module SSTG.Core.Execution.Engine
( loadState
, loadStateEntry
, LoadResult (..)
, RunFlags (..)
, StepType (..)
, execute
, execute1
) where
import SSTG.Core.Syntax
import SSTG.Core.Execution.Models
import SSTG.Core.Execution.Naming
import SSTG.Core.Execution.Stepping
import qualified Data.Map as M
data LoadResult = LoadOkay State
| LoadGuess State [Binding]
| 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 = Status { steps = 0 }
stack = Stack []
heap0 = Heap M.empty (MemAddr 0)
(glist, heap1, bnd_addrss) = initGlobals bnds heap0
globals0 = Globals (M.fromList glist)
(heap2, localss) = liftBindings 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 = []
, state_links = SymLinks M.empty }
state = state0 { state_names = allNames state0 }
allocBinding :: Binding -> Heap -> (Heap, [MemAddr])
allocBinding (Binding _ pairs) heap = (heap', addrs)
where hfakes = map (const Blackhole) pairs
(heap', addrs) = allocHeapList hfakes heap
allocBindingList :: [Binding] -> Heap -> (Heap, [[MemAddr]])
allocBindingList [] heap = (heap, [])
allocBindingList (b:bs) heap = (res_heap, addrs : as)
where (heap', addrs) = allocBinding b heap
(res_heap, as) = allocBindingList bs heap'
bndAddrsToNameVals :: (Binding, [MemAddr]) -> [(Name, Value)]
bndAddrsToNameVals (Binding _ rhss, addrs) = zip names pointers
where names = map (varName . fst) rhss
pointers = map (\a -> MemVal a) addrs
initGlobals :: [Binding] -> Heap ->
([(Name, Value)], Heap, [(Binding, [MemAddr])])
initGlobals bnds heap = (name_vals, heap', bnd_addrss)
where (heap', addrss) = allocBindingList bnds heap
bnd_addrss = zip bnds addrss
name_vals = concatMap bndAddrsToNameVals 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
liftBinding :: (Binding, [MemAddr]) -> Globals -> Heap -> (Heap, Locals)
liftBinding (Binding rec pairs, addrs) globals heap = (heap', locals)
where (vars, rhss) = unzip pairs
mem_vals = map (\a -> MemVal a) addrs
e_locs = Locals M.empty
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
liftBindings :: [(Binding, [MemAddr])] -> Globals -> Heap -> (Heap, [Locals])
liftBindings [] _ heap = (heap, [])
liftBindings (bm:bms) globals heap = (res_heap, locals : ls)
where (heap', locals) = liftBinding bm globals heap
(res_heap, ls) = liftBindings bms globals heap'
entryMatches :: String -> [(Binding, Locals)] -> [(Binding, Locals)]
entryMatches entry bnd_locs = filter (bindFilter entry) bnd_locs
bindFilter :: String -> (Binding, Locals) -> Bool
bindFilter entry (bnd, _) = lhsMatches entry bnd /= []
lhsMatches :: String -> Binding -> [(Var, BindRhs)]
lhsMatches st (Binding _ 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 { step_count :: Int
, step_type :: StepType
, 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 (step_count flags) state
where step :: Int -> State -> [([LiveState], [DeadState])]
step = case 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