@@ -7,6 +7,8 @@ import Core.TT
77import Debug.Trace
88import Data.Maybe
99import Data.List
10+import Control.Monad
11+import Control.Monad.State
1012
1113data DExp = DV LVar
1214 | DApp Bool Name [DExp] -- True = tail call
@@ -39,11 +41,12 @@ defunctionalise :: Int -> LDefs -> DDefs
3941defunctionalise nexttag defs
4042 = let all = toAlist defs
4143 -- sort newcons so that EVAL and APPLY cons get sequential tags
42− newcons = sortBy conord $ concatMap toCons (getFn all)
44+ (allD, enames) = runState (mapM (addApps defs) all) []
45+ newcons = sortBy conord $ concatMap (toCons enames) (getFn all)
4346 eval = mkEval newcons
4447 app = mkApply newcons
4548 condecls = declare nexttag newcons in
46− addAlist (eval : app : condecls ++ (map (addApps defs) all)) emptyContext
49+ addAlist (eval : app : condecls ++ allD) emptyContext
4750 where conord (n, _, _) (n', _, _) = compare n n'
4851
4952getFn :: [(Name, LDecl)] -> [(Name, Int)]
@@ -64,57 +67,80 @@ getFn xs = mapMaybe fnData xs
6467-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
6568-- 8 Add explicit EVAL to case, primitives, and foreign calls
6669
67−addApps :: LDefs -> (Name, LDecl) -> (Name, DDecl)
68−addApps defs o@(n, LConstructor _ t a) = (n, DConstructor n t a)
69−addApps defs (n, LFun _ _ args e) = (n, DFun n args (aa args e))
70+addApps :: LDefs -> (Name, LDecl) -> State [Name] (Name, DDecl)
71+addApps defs o@(n, LConstructor _ t a)
72+ = return (n, DConstructor n t a)
73+addApps defs (n, LFun _ _ args e)
74+ = do e' <- aa args e
75+ return (n, DFun n args e')
7076 where
71− aa :: [Name] -> LExp -> DExp
72− aa env (LV (Glob n)) | n `elem` env = DV (Glob n)
77+ aa :: [Name] -> LExp -> State [Name] DExp
78+ aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)
7379 | otherwise = aa env (LApp False (LV (Glob n)) [])
7480-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e
7581 aa env (LApp tc (LV (Glob n)) args)
76− = let args' = map (aa env) args in
77− case lookupCtxt Nothing n defs of
78− [LConstructor _ i ar] -> DApp tc n args'
82+ = do args' <- mapM (aa env) args
83+ case lookupCtxt Nothing n defs of
84+ [LConstructor _ i ar] -> return $ DApp tc n args'
7985 [LFun _ _ as _] -> let arity = length as in
8086 fixApply tc n args' arity
81− [] -> chainAPPLY (DV (Glob n)) args'
87+ [] -> return $ chainAPPLY (DV (Glob n)) args'
8288 aa env (LLazyApp n args)
83− = let args' = map (aa env) args in
84− case lookupCtxt Nothing n defs of
85− [LConstructor _ i ar] -> DApp False n args'
89+ = do args' <- mapM (aa env) args
90+ case lookupCtxt Nothing n defs of
91+ [LConstructor _ i ar] -> return $ DApp False n args'
8692 [LFun _ _ as _] -> let arity = length as in
8793 fixLazyApply n args' arity
88− [] -> chainAPPLY (DV (Glob n)) args'
89− aa env (LForce e) = eEVAL (aa env e)
90− aa env (LLet n v sc) = DLet n (aa env v) (aa (n : env) sc)
91− aa env (LCon i n args) = DC i n (map (aa env) args)
94+ [] -> return $ chainAPPLY (DV (Glob n)) args'
95+ aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV (Glob n)) args)
96+ aa env (LForce e) = liftM eEVAL (aa env e)
97+ aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)
98+ aa env (LCon i n args) = liftM (DC i n) (mapM (aa env) args)
9299 aa env (LProj t@(LV (Glob n)) i)
93− = DProj (DUpdate n (eEVAL (aa env t))) i
94− aa env (LProj t i) = DProj (eEVAL (aa env t)) i
95− aa env (LCase e alts) = DCase (eEVAL (aa env e)) (map (aaAlt env) alts)
96− aa env (LConst c) = DConst c
97− aa env (LForeign l t n args) = DForeign l t n (map (aaF env) args)
98− aa env (LOp LFork args) = DOp LFork (map (aa env) args)
99− aa env (LOp f args) = DOp f (map (eEVAL . (aa env)) args)
100− aa env LNothing = DNothing
101− aa env (LError e) = DError e
102−
103− aaF env (t, e) = (t, eEVAL (aa env e))
104−
105− aaAlt env (LConCase i n args e) = DConCase i n args (aa (args ++ env) e)
106− aaAlt env (LConstCase c e) = DConstCase c (aa env e)
107− aaAlt env (LDefaultCase e) = DDefaultCase (aa env e)
100+ = do t' <- aa env t
101+ return $ DProj (DUpdate n (eEVAL t')) i
102+ aa env (LProj t i) = do t' <- aa env t
103+ return $ DProj (eEVAL t') i
104+ aa env (LCase e alts) = do e' <- aa env e
105+ alts' <- mapM (aaAlt env) alts
106+ return $ DCase (eEVAL e') alts'
107+ aa env (LConst c) = return $ DConst c
108+ aa env (LForeign l t n args) = liftM (DForeign l t n) (mapM (aaF env) args)
109+ aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args)
110+ aa env (LOp f args) = do args' <- mapM (aa env) args
111+ return $ DOp f (map eEVAL args')
112+ aa env LNothing = return DNothing
113+ aa env (LError e) = return $ DError e
114+
115+ aaF env (t, e) = do e' <- aa env e
116+ return (t, eEVAL e')
117+
118+ aaAlt env (LConCase i n args e)
119+ = liftM (DConCase i n args) (aa (args ++ env) e)
120+ aaAlt env (LConstCase c e) = liftM (DConstCase c) (aa env e)
121+ aaAlt env (LDefaultCase e) = liftM DDefaultCase (aa env e)
108122
109123 fixApply tc n args ar
110− | length args == ar = DApp tc n args
111− | length args < ar = DApp tc (mkUnderCon n (ar - length args)) args
112− | length args > ar = chainAPPLY (DApp tc n (take ar args)) (drop ar args)
124+ | length args == ar
125+ = return $ DApp tc n args
126+ | length args < ar
127+ = do ns <- get
128+ put $ nub (n : ns)
129+ return $ DApp tc (mkUnderCon n (ar - length args)) args
130+ | length args > ar
131+ = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)
113132
114133 fixLazyApply n args ar
115− | length args == ar = DApp False (mkFnCon n) args
116− | length args < ar = DApp False (mkUnderCon n (ar - length args)) args
117− | length args > ar = chainAPPLY (DApp False n (take ar args)) (drop ar args)
134+ | length args == ar
135+ = do ns <- get
136+ put $ nub (n : ns)
137+ return $ DApp False (mkFnCon n) args
138+ | length args < ar
139+ = do ns <- get
140+ put $ nub (n : ns)
141+ return $ DApp False (mkUnderCon n (ar - length args)) args
142+ | length args > ar
143+ = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)
118144
119145 chainAPPLY f [] = f
120146 chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as
@@ -154,14 +180,16 @@ data EvalApply a = EvalCase (Name -> a)
154180-- For a function name, generate a list of
155181-- data constuctors, and whether to handle them in EVAL or APPLY
156182
157−toCons :: (Name, Int) -> [(Name, Int, EvalApply DAlt)]
158−toCons (n, i)
159− = (mkFnCon n, i,
160− EvalCase (\tlarg ->
183+toCons :: [Name] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]
184+toCons ns (n, i)
185+ | n `elem` ns
186+ = (mkFnCon n, i,
187+ EvalCase (\tlarg ->
161188 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
162189 (dupdate tlarg
163190 (eEVAL (DApp False n (map (DV . Glob) (take i (genArgs 0)))))))))
164191 : mkApplyCase n 0 i
192+ | otherwise = []
165193 where dupdate tlarg x = x
166194
167195mkApplyCase fname n ar | n == ar = []