module SSTG.Core.Execution.Engine
( loadState
, loadStateEntry
, LoadResult (..)
, RunFlags (..)
, StepType (..)
, execute
, execute1
) where
import SSTG.Core.Language
import SSTG.Core.Execution.Stepping
import SSTG.Core.Execution.Support
data LoadResult = LoadOkay State
| LoadGuess State [Binds]
| 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 bindss) = 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, binds_addrss) = initGlobals bindss heap0
globals0 = insertGlobalsVals glist empty_globals
(heap2, localss) = liftBindsAddrss binds_addrss globals0 heap1
binds_locs = zip bindss localss
matches = entryMatches entry binds_locs
((tgt_binds, tgt_loc):others) = matches
((tgt_var, tgt_rhs):_) = lhsMatches entry tgt_binds
(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_path = empty_pathcons }
state = state0 { state_names = allNames (Program bindss) }
allocBinds :: Binds -> Heap -> (Heap, [MemAddr])
allocBinds (Binds _ kvs) heap = (heap', addrs)
where
hfakes = map (const Blackhole) kvs
(heap', addrs) = allocHeapObjs hfakes heap
allocBindss :: [Binds] -> Heap -> (Heap, [[MemAddr]])
allocBindss [] heap = (heap, [])
allocBindss (bind:bs) heap = (heapf, addrs : as)
where
(heap', addrs) = allocBinds bind heap
(heapf, as) = allocBindss bs heap'
bindsAddrsToVarVals :: (Binds, [MemAddr]) -> [(Var, Val)]
bindsAddrsToVarVals (Binds _ kvs, addrs) = zip (map fst kvs) mem_vals
where
mem_vals = map (\a -> MemVal a) addrs
initGlobals :: [Binds] -> Heap -> ([(Var, Val)], Heap, [(Binds, [MemAddr])])
initGlobals bindss heap = (var_vals, heap', binds_addrss)
where
(heap', addrss) = allocBindss bindss heap
binds_addrss = zip bindss addrss
var_vals = concatMap bindsAddrsToVarVals binds_addrss
forceLookupVal :: Atom -> Locals -> Globals -> Val
forceLookupVal (LitAtom lit) _ _ = LitVal lit
forceLookupVal (VarAtom var) locals globals =
case lookupVal var locals globals of
Just val -> val
Nothing -> LitVal BlankAddr
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 -> forceLookupVal a locals globals) args
liftBindsAddrs :: (Binds, [MemAddr]) -> Globals -> Heap -> (Heap, Locals)
liftBindsAddrs (Binds rec kvs, addrs) globals heap = (heap', locals)
where
(vars, rhss) = unzip kvs
mem_vals = map (\a -> MemVal a) addrs
e_locs = empty_locals
r_locs = insertLocalsVals (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' = insertHeapObjs (zip addrs hobjs) heap
liftBindsAddrss :: [(Binds, [MemAddr])] -> Globals -> Heap -> (Heap, [Locals])
liftBindsAddrss [] _ heap = (heap, [])
liftBindsAddrss (bind_addr:bms) globals heap = (heapf, locals : ls)
where
(heap', locals) = liftBindsAddrs bind_addr globals heap
(heapf, ls) = liftBindsAddrss bms globals heap'
entryMatches :: String -> [(Binds, Locals)] -> [(Binds, Locals)]
entryMatches entry binds_locs = filter (isEntryBinds entry) binds_locs
isEntryBinds :: String -> (Binds, Locals) -> Bool
isEntryBinds entry (binds, _) = lhsMatches entry binds /= []
lhsMatches :: String -> Binds -> [(Var, BindRhs)]
lhsMatches st (Binds _ kvs) =
filter (\(var, _) -> st == (nameOccStr . varName) var) kvs
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' = freshSeededNames confs confs
adjusted = map (\(n, t) -> Var n t) (zip names' (map typeOf actuals))
sym_objs = map (\p -> SymObj (Symbol p Nothing)) adjusted
(heap', addrs) = allocHeapObjs sym_objs heap
mem_vals = map (\a -> MemVal a) addrs
locals' = insertLocalsVals (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