@@ -41,11 +41,12 @@ defunctionalise :: Int -> LDefs -> DDefs
41defunctionalise nexttag defs
41defunctionalise nexttag defs
42 = let all = toAlist defs
42 = let all = toAlist defs
43 -- sort newcons so that EVAL and APPLY cons get sequential tags
43 -- sort newcons so that EVAL and APPLY cons get sequential tags
44− (allD, enames) = runState (mapM (addApps defs) all) []
44+ (allD, (enames, anames)) = runState (mapM (addApps defs) all) ([], [])
45− newcons = sortBy conord $ concatMap (toCons enames) (getFn all)
45+ newecons = sortBy conord $ concatMap (toCons enames) (getFn all)
46+ newacons = sortBy conord $ concatMap (toCons anames) (getFn all)
46− eval = mkEval newcons
47+ eval = mkEval newecons
47− app = mkApply newcons
48+ app = mkApply newacons
48− condecls = declare nexttag newcons in
49+ condecls = declare nexttag (newecons ++ newacons) in
49 addAlist (eval : app : condecls ++ allD) emptyContext
50 addAlist (eval : app : condecls ++ allD) emptyContext
50 where conord (n, _, _) (n', _, _) = compare n n'
51 where conord (n, _, _) (n', _, _) = compare n n'
@@ -67,17 +68,16 @@ getFn xs = mapMaybe fnData xs
67-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
68-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
68-- 8 Add explicit EVAL to case, primitives, and foreign calls
69-- 8 Add explicit EVAL to case, primitives, and foreign calls
70−addApps :: LDefs -> (Name, LDecl) -> State [Name] (Name, DDecl)
71+addApps :: LDefs -> (Name, LDecl) -> State ([Name], [Name]) (Name, DDecl)
71addApps defs o@(n, LConstructor _ t a)
72addApps defs o@(n, LConstructor _ t a)
72 = return (n, DConstructor n t a)
73 = return (n, DConstructor n t a)
73addApps defs (n, LFun _ _ args e)
74addApps defs (n, LFun _ _ args e)
74 = do e' <- aa args e
75 = do e' <- aa args e
75 return (n, DFun n args e')
76 return (n, DFun n args e')
77− aa :: [Name] -> LExp -> State [Name] DExp
78+ aa :: [Name] -> LExp -> State ([Name], [Name]) DExp
78 aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)
79 aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)
79 | otherwise = aa env (LApp False (LV (Glob n)) [])
80 | otherwise = aa env (LApp False (LV (Glob n)) [])
80−-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e
81 aa env (LApp tc (LV (Glob n)) args)
81 aa env (LApp tc (LV (Glob n)) args)
82 = do args' <- mapM (aa env) args
82 = do args' <- mapM (aa env) args
83 case lookupCtxtExact n defs of
83 case lookupCtxtExact n defs of
@@ -124,20 +124,20 @@ addApps defs (n, LFun _ _ args e)
124 | length args == ar
124 | length args == ar
125 = return $ DApp tc n args
125 = return $ DApp tc n args
126 | length args < ar
126 | length args < ar
127− = do ns <- get
127+ = do (ens, ans) <- get
128− put $ nub (n : ns)
128+ put (ens, nub (n : ans))
129 return $ DApp tc (mkUnderCon n (ar - length args)) args
129 return $ DApp tc (mkUnderCon n (ar - length args)) args
130 | length args > ar
130 | length args > ar
131 = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)
131 = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)
133 fixLazyApply n args ar
133 fixLazyApply n args ar
134 | length args == ar
134 | length args == ar
135− = do ns <- get
135+ = do (ens, ans) <- get
136− put $ nub (n : ns)
136+ put (nub (n : ens), ans)
137 return $ DApp False (mkFnCon n) args
137 return $ DApp False (mkFnCon n) args
138 | length args < ar
138 | length args < ar
139− = do ns <- get
139+ = do (ens, ans) <- get
140− put $ nub (n : ns)
140+ put (ens, nub (n : ans))
141 return $ DApp False (mkUnderCon n (ar - length args)) args
141 return $ DApp False (mkUnderCon n (ar - length args)) args
142 | length args > ar
142 | length args > ar
143 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)
143 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)
@@ -175,7 +175,6 @@ eEVAL x = DApp False (sMN 0 "EVAL") [x]
176data EvalApply a = EvalCase (Name -> a)
176data EvalApply a = EvalCase (Name -> a)
177 | ApplyCase a
177 | ApplyCase a
180-- For a function name, generate a list of
179-- For a function name, generate a list of
181-- data constuctors, and whether to handle them in EVAL or APPLY
180-- data constuctors, and whether to handle them in EVAL or APPLY
@@ -216,8 +215,7 @@ mkApply xs = (sMN 0 "APPLY", DFun (sMN 0 "APPLY") [sMN 0 "fn", sMN 0 "arg"]
216 [] -> DNothing
215 [] -> DNothing
218 mkBigCase (sMN 0 "APPLY") 256
217 mkBigCase (sMN 0 "APPLY") 256
219− (DApp False (sMN 0 "EVAL")
220− [DV (Glob (sMN 0 "fn"))])
218+ (DV (Glob (sMN 0 "fn")))
221 (cases ++
219 (cases ++
222 [DDefaultCase DNothing])))
220 [DDefaultCase DNothing])))