|
definition:
|
evalFirstTask :: State -> [Task] -> State
evalFirstTask _ [] = error "step: empty tasks"
evalFirstTask st (Task (CNode nid) stk fp : tsks) =
case lookupNode nid (graph st) of
ConsNode _ _ -> case stk of
[] -> addResult nid (st { tasks = tsks })
((fnid,_) : rstk) ->
let st1 = st { tasks = Task (CNode fnid) rstk fp : tsks }
in invokeFunction st1 (tasks st1)
-- partial calls are treated as constructors:
PartNode _ _ _ -> case stk of
[] -> addResult nid (st { tasks = tsks })
((fnid,_) : rstk) ->
let st1 = st { tasks = Task (CNode fnid) rstk fp : tsks }
in invokeFunction st1 (tasks st1)
FuncNode f _ -> case demandOf f (program st) of
Nothing -> invokeFunction st (tasks st)
Just di -> let ni = followPath (graph st) nid [di]
in st { tasks = Task (CNode ni) ((nid,di) : stk) fp : tsks }
ChoiceNode cid n1 n2 -> case stk of
[] -> case lookup cid fp of
Just c -> let ns = if c==1 then n1 else n2
in st { tasks = Task (CNode ns) stk fp : tsks }
Nothing -> let newtasks = [Task (CNode n1) [] ((cid,1) : fp),
Task (CNode n2) [] ((cid,2) : fp)]
in st { tasks = tsks ++ newtasks }
((fnid,di) : nids) -> -- pull-tab step:
let g0 = graph st in
case lookupNode fnid g0 of
FuncNode f ns ->
let (g1,n1') = addNode (FuncNode f (replace n1 di ns)) g0
(g2,n2') = addNode (FuncNode f (replace n2 di ns)) g1
in st { graph = updateNode g2 fnid (ChoiceNode cid n1' n2')
, tasks = Task (CNode fnid) nids fp : tsks }
_ -> error "step: stack does not refer to function node"
FreeNode -> case stk of
[] -> addResult nid (st { tasks = tsks })
((fnid,_) : rstk) ->
-- bind free node to choice structure corresponding to case expression
maybe
(let newtsks = Task (CNode fnid) rstk fp : tsks
in invokeFunction (st { tasks = newtsks }) newtsks)
(\chexp ->
let (gr1,nd) = extendGraph (graph st) [] chexp
chnd = either (error "evalFirstTask: no choice") id nd
in st { graph = updateNode gr1 nid chnd })
(choiceOfDemand st fnid)
evalFirstTask st (Task (IBlockEnv (IBlock vs asgns stm) ienv) stk fp : tsks) =
let (g0,ienv0) = addVarDecls (graph st) ienv vs
(g1,ienv1) = addAssigns g0 ienv0 asgns in
case stm of
IExempt -> st { tasks = tsks } -- failure: remove current task
IReturn iexp -> -- return statement: replace current ROOT node
let (g2,nexp) = extendGraph g1 ienv1 iexp
rootid = lookupInEnv 0 ienv
in either (\ni -> st { graph = replaceNode g2 rootid ni,
tasks = Task (CNode ni) stk fp : tsks })
(\nd -> st { graph = updateNode g2 rootid nd,
tasks = Task (CNode rootid) stk fp : tsks })
nexp
ICaseCons cv branches -> -- constructor case: select branch
let bn = lookupInEnv cv ienv1
sb = selectConsBranch (lookupNode bn g1) branches
in st { graph = g1
, tasks = Task (IBlockEnv sb ienv1) stk fp : tsks }
ICaseLit cv branches -> -- literal case: select branch
let bn = lookupInEnv cv ienv1
sb = selectLitBranch (lookupNode bn g1) branches
in st { graph = g1
, tasks = Task (IBlockEnv sb ienv1) stk fp : tsks }
|