@@ -41,11 +41,12 @@ defunctionalise :: Int -> LDefs -> DDefs
4141defunctionalise nexttag defs
4242 = let all = toAlist defs
4343 -- sort newcons so that EVAL and APPLY cons get sequential tags
44− (allD, enames) = runState (mapM (addApps defs) all) []
45− newcons = sortBy conord $ concatMap (toCons enames) (getFn all)
46− eval = mkEval newcons
47− app = mkApply newcons
48− condecls = declare nexttag newcons in
44+ (allD, (enames, anames)) = runState (mapM (addApps defs) all) ([], [])
45+ newecons = sortBy conord $ concatMap (toCons enames) (getFn all)
46+ newacons = sortBy conord $ concatMap (toCons anames) (getFn all)
47+ eval = mkEval newecons
48+ app = mkApply newacons
49+ condecls = declare nexttag (newecons ++ newacons) in
4950 addAlist (eval : app : condecls ++ allD) emptyContext
5051 where conord (n, _, _) (n', _, _) = compare n n'
5152
@@ -67,17 +68,16 @@ getFn xs = mapMaybe fnData xs
6768-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
6869-- 8 Add explicit EVAL to case, primitives, and foreign calls
6970
70−addApps :: LDefs -> (Name, LDecl) -> State [Name] (Name, DDecl)
71+addApps :: LDefs -> (Name, LDecl) -> State ([Name], [Name]) (Name, DDecl)
7172addApps defs o@(n, LConstructor _ t a)
7273 = return (n, DConstructor n t a)
7374addApps defs (n, LFun _ _ args e)
7475 = do e' <- aa args e
7576 return (n, DFun n args e')
7677 where
77− aa :: [Name] -> LExp -> State [Name] DExp
78+ aa :: [Name] -> LExp -> State ([Name], [Name]) DExp
7879 aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)
7980 | otherwise = aa env (LApp False (LV (Glob n)) [])
80−-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e
8181 aa env (LApp tc (LV (Glob n)) args)
8282 = do args' <- mapM (aa env) args
8383 case lookupCtxtExact n defs of
@@ -124,20 +124,20 @@ addApps defs (n, LFun _ _ args e)
124124 | length args == ar
125125 = return $ DApp tc n args
126126 | length args < ar
127− = do ns <- get
128− put $ nub (n : ns)
127+ = do (ens, ans) <- get
128+ put (ens, nub (n : ans))
129129 return $ DApp tc (mkUnderCon n (ar - length args)) args
130130 | length args > ar
131131 = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)
132132
133133 fixLazyApply n args ar
134134 | length args == ar
135− = do ns <- get
136− put $ nub (n : ns)
135+ = do (ens, ans) <- get
136+ put (nub (n : ens), ans)
137137 return $ DApp False (mkFnCon n) args
138138 | length args < ar
139− = do ns <- get
140− put $ nub (n : ns)
139+ = do (ens, ans) <- get
140+ put (ens, nub (n : ans))
141141 return $ DApp False (mkUnderCon n (ar - length args)) args
142142 | length args > ar
143143 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)
@@ -175,7 +175,6 @@ eEVAL x = DApp False (sMN 0 "EVAL") [x]
175175
176176data EvalApply a = EvalCase (Name -> a)
177177 | ApplyCase a
178−-- deriving Show
179178
180179-- For a function name, generate a list of
181180-- 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"]
216215 [] -> DNothing
217216 cases ->
218217 mkBigCase (sMN 0 "APPLY") 256
219− (DApp False (sMN 0 "EVAL")
220− [DV (Glob (sMN 0 "fn"))])
218+ (DV (Glob (sMN 0 "fn")))
221219 (cases ++
222220 [DDefaultCase DNothing])))
223221 where