@@ -10,7 +10,7 @@ import Control.Monad.State
1010
1111data SExp = SV LVar
1212 | SApp Bool Name [LVar]
13− | SLet Name SExp SExp
13+ | SLet LVar SExp SExp
1414 | SCon Int Name [LVar]
1515 | SCase LVar [SAlt]
1616 | SConst Const
@@ -25,19 +25,27 @@ data SAlt = SConCase Int Name [Name] SExp
2525data SDecl = SFun Name [Name] SExp
2626 deriving Show
2727
28−hvar :: State Int Int
29−hvar = do h <- get
30− put (h + 1)
28+hvar :: State (LDefs, Int) Int
29+hvar = do (l, h) <- get
30+ put (l, h + 1)
3131 return h
3232
33−simplify :: LExp -> State Int SExp
33+ldefs :: State (LDefs, Int) LDefs
34+ldefs = do (l, h) <- get
35+ return l
36+
37+simplify :: LExp -> State (LDefs, Int) SExp
3438simplify (LV (Loc i)) = return (SV (Loc i))
35−simplify (LV x) = return (SV x)
39+simplify (LV (Glob x))
40+ = do ctxt <- ldefs
41+ case lookupCtxt Nothing x ctxt of
42+ [LConstructor _ t 0] -> return $ SCon t x []
43+ _ -> return $ SV (Glob x)
3644simplify (LApp tc n args) = do args' <- mapM sVar args
3745 mkapp (SApp tc n) args'
3846simplify (LLet n v e) = do v' <- simplify v
3947 e' <- simplify e
40− return (SLet n v' e')
48+ return (SLet (Glob n) v' e')
4149simplify (LCon i n args) = do args' <- mapM sVar args
4250 mkapp (SCon i n) args'
4351simplify (LCase e alts) = do v <- sVar e
@@ -45,11 +53,16 @@ simplify (LCase e alts) = do v <- sVar e
4553 case v of
4654 (x, Nothing) -> return (SCase x alts')
4755 (Glob x, Just e) ->
48− return (SLet x e (SCase (Glob x) alts'))
56+ return (SLet (Glob x) e (SCase (Glob x) alts'))
4957simplify (LConst c) = return (SConst c)
5058simplify (LOp p args) = do args' <- mapM sVar args
5159 mkapp (SOp p) args'
5260
61+sVar (LV (Glob x))
62+ = do ctxt <- ldefs
63+ case lookupCtxt Nothing x ctxt of
64+ [LConstructor _ t 0] -> sVar (LCon t x [])
65+ _ -> return (Glob x, Nothing)
5366sVar (LV x) = return (x, Nothing)
5467sVar e = do e' <- simplify e
5568 i <- hvar
@@ -58,8 +71,8 @@ sVar e = do e' <- simplify e
5871mkapp f args = mkapp' f args [] where
5972 mkapp' f [] args = return $ f (reverse args)
6073 mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)
61− mkapp' f ((Glob x, Just e) : xs) args
62− = do sc <- mkapp' f xs (Glob x : args)
74+ mkapp' f ((x, Just e) : xs) args
75+ = do sc <- mkapp' f xs (x : args)
6376 return (SLet x e sc)
6477
6578sAlt (LConCase i n args e) = do e' <- simplify e
@@ -75,15 +88,15 @@ checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)
7588 = do xs' <- checkDefs ctxt xs
7689 return xs'
7790checkDefs ctxt ((n, LFun n' args exp) : xs)
78− = do let sexp = evalState (simplify exp) 0
91+ = do let sexp = evalState (simplify exp) (ctxt, 0)
7992 exp' <- scopecheck ctxt (zip args [0..]) sexp
8093 xs' <- checkDefs ctxt xs
8194 return ((n, SFun n' args exp') : xs')
8295
8396scopecheck :: LDefs -> [(Name, Int)] -> SExp -> TC SExp
8497scopecheck ctxt env tm = sc env tm where
85− sc env (SV (Glob n))
86− = case lookup n (reverse env) of -- most recent first
98+ sc env (SV (Glob n)) =
99+ case lookup n (reverse env) of -- most recent first
87100 Just i -> return (SV (Loc i))
88101 Nothing -> case lookupCtxt Nothing n ctxt of
89102 [LConstructor _ i ar] ->
@@ -93,25 +106,49 @@ scopecheck ctxt env tm = sc env tm where
93106 [_] -> return (SV (Glob n))
94107 [] -> fail $ "Codegen error: No such variable " ++ show n
95108 sc env (SApp tc f args)
96− = do case lookupCtxt Nothing f ctxt of
109+ = do args' <- mapM (scVar env) args
110+ case lookupCtxt Nothing f ctxt of
97111 [LConstructor n tag ar] ->
98112 if (ar == length args)
99− then return $ SCon tag n args
113+ then return $ SCon tag n args'
100114 else fail $ "Codegen error: Constructor " ++ show f ++
101115 " has arity " ++ show ar
102− [_] -> return $ SApp tc f args
116+ [_] -> return $ SApp tc f args'
103117 [] -> fail $ "Codegen error: No such variable " ++ show f
118+ sc env (SCon tag f args)
119+ = do args' <- mapM (scVar env) args
120+ case lookupCtxt Nothing f ctxt of
121+ [LConstructor n tag ar] ->
122+ if (ar == length args)
123+ then return $ SCon tag n args'
124+ else fail $ "Codegen error: Constructor " ++ show f ++
125+ " has arity " ++ show ar
126+ _ -> fail $ "Codegen error: No such constructor " ++ show f
104127 sc env (SCase e alts)
105− = do alts' <- mapM (scalt env) alts
106− return (SCase e alts')
107− sc env (SLet n v e)
108− = do v' <- sc env v
109− e' <- sc (env ++ [(n, length env)]) e
110− return (SLet n v' e')
128+ = do e' <- scVar env e
129+ alts' <- mapM (scalt env) alts
130+ return (SCase e' alts')
131+ sc env (SLet (Glob n) v e)
132+ = do let env' = env ++ [(n, length env)]
133+ v' <- sc env v
134+ n' <- scVar env' (Glob n)
135+ e' <- sc env' e
136+ return (SLet n' v' e')
111137 sc env (SOp prim args)
112− = do return (SOp prim args)
138+ = do args' <- mapM (scVar env) args
139+ return (SOp prim args')
113140 sc env x = return x
114141
142+ scVar env (Glob n) =
143+ case lookup n (reverse env) of -- most recent first
144+ Just i -> return (Loc i)
145+ Nothing -> case lookupCtxt Nothing n ctxt of
146+ [LConstructor _ i ar] ->
147+ fail $ "Codegen error : can't pass constructor here"
148+ [_] -> return (Glob n)
149+ [] -> fail $ "Codegen error: No such variable " ++ show n
150+ scVar _ x = return x
151+
115152 scalt env (SConCase i n args e)
116153 = do let env' = env ++ zip args [length env..]
117154 tag <- case lookupCtxt Nothing n ctxt of