module SSTG.Core.Execution.Engine
( loadState
, loadStateEntry
, LoadResult (..)
, RunFlags (..)
, StepType (..)
, execute
, execute1
) where
import SSTG.Core.Language
import SSTG.Core.Execution.Stepping
data LoadResult = LoadOkay State
| LoadGuess State [Bind]
| LoadError String
deriving (Show, Eq, Read)
loadState :: Program -> LoadResult
loadState prog = loadStateEntry main_occ_name prog
where
main_occ_name = "main"
loadStateEntry :: String -> Program -> LoadResult
loadStateEntry entry (Program bnds) = if length matches == 0
then LoadError ("No entry candidates found for: [" ++ entry ++ "]")
else if length others == 0
then LoadOkay state
else LoadGuess state (map fst others)
where
status = init_status
stack = empty_stack
heap0 = empty_heap
(glist, heap1, bnd_addrss) = initGlobals bnds heap0
globals0 = insertGlobalsList glist empty_globals
(heap2, localss) = liftBinds bnd_addrss globals0 heap1
bnd_locs = zip bnds localss
matches = entryMatches entry bnd_locs
((tgt_bnd, tgt_loc):others) = matches
((tgt_var, tgt_rhs):_) = lhsMatches entry tgt_bnd
(code, globals, heap) = loadCode tgt_var tgt_rhs tgt_loc globals0 heap2
state0 = State { state_status = status
, state_stack = stack
, state_heap = heap
, state_globals = globals
, state_code = code
, state_names = []
, state_paths = empty_pathcons }
state = state0 { state_names = allNames state0 }
allocBind :: Bind -> Heap -> (Heap, [MemAddr])
allocBind (Bind _ pairs) heap = (heap', addrs)
where
hfakes = map (const Blackhole) pairs
(heap', addrs) = allocHeapList hfakes heap
allocBindList :: [Bind] -> Heap -> (Heap, [[MemAddr]])
allocBindList [] heap = (heap, [])
allocBindList (b:bs) heap = (heapf, addrs : as)
where
(heap', addrs) = allocBind b heap
(heapf, as) = allocBindList bs heap'
bndAddrsToVarVals :: (Bind, [MemAddr]) -> [(Var, Value)]
bndAddrsToVarVals (Bind _ rhss, addrs) = zip (map fst rhss) mem_vals
where
mem_vals = map (\a -> MemVal a) addrs
initGlobals :: [Bind] -> Heap -> ([(Var, Value)], Heap, [(Bind, [MemAddr])])
initGlobals bnds heap = (var_vals, heap', bnd_addrss)
where
(heap', addrss) = allocBindList bnds heap
bnd_addrss = zip bnds addrss
var_vals = concatMap bndAddrsToVarVals bnd_addrss
forceLookupValue :: Atom -> Locals -> Globals -> Value
forceLookupValue (LitAtom lit) _ _ = LitVal lit
forceLookupValue (VarAtom var) locals globals =
case lookupValue var locals globals of
Nothing -> LitVal BlankAddr
Just val -> val
forceRhsObj :: BindRhs -> Locals -> Globals -> HeapObj
forceRhsObj (FunForm prms expr) locals _ = FunObj prms expr locals
forceRhsObj (ConForm dcon args) locals globals = ConObj dcon arg_vals
where
arg_vals = map (\a -> forceLookupValue a locals globals) args
liftBind :: (Bind, [MemAddr]) -> Globals -> Heap -> (Heap, Locals)
liftBind (Bind rec pairs, addrs) globals heap = (heap', locals)
where
(vars, rhss) = unzip pairs
mem_vals = map (\a -> MemVal a) addrs
e_locs = empty_locals
r_locs = insertLocalsList (zip vars mem_vals) e_locs
locals = case rec of { Rec -> r_locs; NonRec -> e_locs }
hobjs = map (\r -> forceRhsObj r locals globals) rhss
heap' = insertHeapList (zip addrs hobjs) heap
liftBinds :: [(Bind, [MemAddr])] -> Globals -> Heap -> (Heap, [Locals])
liftBinds [] _ heap = (heap, [])
liftBinds (bm:bms) globals heap = (heapf, locals : ls)
where
(heap', locals) = liftBind bm globals heap
(heapf, ls) = liftBinds bms globals heap'
entryMatches :: String -> [(Bind, Locals)] -> [(Bind, Locals)]
entryMatches entry bnd_locs = filter (bindFilter entry) bnd_locs
bindFilter :: String -> (Bind, Locals) -> Bool
bindFilter entry (bnd, _) = lhsMatches entry bnd /= []
lhsMatches :: String -> Bind -> [(Var, BindRhs)]
lhsMatches st (Bind _ pairs) =
filter (\(var, _) -> st == (nameOccStr . varName) var) pairs
loadCode :: Var -> BindRhs -> Locals -> Globals -> Heap -> (Code,Globals,Heap)
loadCode ent (ConForm _ _) locals globals heap = (code, globals, heap)
where
code = Evaluate (Atom (VarAtom ent)) locals
loadCode ent (FunForm params expr) locals globals heap = (code, globals, heap')
where
actuals = traceArgs params expr locals globals heap
confs = map varName actuals
names' = freshSeededNameList confs confs
adjusted = map (\(n, t) -> Var n t) (zip names' (map varType actuals))
sym_objs = map (\p -> SymObj (Symbol p Nothing)) adjusted
(heap', addrs) = allocHeapList sym_objs heap
mem_vals = map (\a -> MemVal a) addrs
locals' = insertLocalsList (zip adjusted mem_vals) locals
args = map (\p -> VarAtom p) adjusted
code = Evaluate (FunApp ent args) locals'
traceArgs :: [Var] -> Expr -> Locals -> Globals -> Heap -> [Var]
traceArgs base expr locals globals heap
| FunApp var [] <- expr
, Just (_, hobj) <- vlookupHeap var locals globals heap
, FunObj params _ _ <- hobj
, length params > 0
, length base == 0 = params
| otherwise = base
data RunFlags = RunFlags { flag_step_count :: Int
, flag_step_type :: StepType
, flag_dump_dir :: Maybe FilePath
} deriving (Show, Eq, Read)
data StepType = BFS | DFS | BFSLogged | DFSLogged deriving (Show, Eq, Read)
execute :: RunFlags -> State -> [([LiveState], [DeadState])]
execute flags state = step (flag_step_count flags) state
where
step :: Int -> State -> [([LiveState], [DeadState])]
step = case flag_step_type flags of
BFS -> \k s -> [runBoundedBFS k s]
BFSLogged -> runBoundedBFSLogged
DFS -> \k s -> [runBoundedDFS k s]
DFSLogged -> runBoundedDFSLogged
execute1 :: Int -> State -> ([LiveState], [DeadState])
execute1 n state | n < 1 = ([([], state)], [])
| otherwise = runBoundedBFS n state