@@ -10,7 +10,7 @@ import Control.Monad.State
11data SExp = SV LVar
11data SExp = SV LVar
12 | SApp Bool Name [LVar]
12 | SApp Bool Name [LVar]
13− | SLet Name SExp SExp
13+ | SLet LVar SExp SExp
14 | SCon Int Name [LVar]
14 | SCon Int Name [LVar]
15 | SCase LVar [SAlt]
15 | SCase LVar [SAlt]
16 | SConst Const
16 | SConst Const
@@ -25,19 +25,27 @@ data SAlt = SConCase Int Name [Name] SExp
25data SDecl = SFun Name [Name] SExp
25data SDecl = SFun Name [Name] SExp
26 deriving Show
26 deriving Show
28−hvar :: State Int Int
28+hvar :: State (LDefs, Int) Int
29−hvar = do h <- get
29+hvar = do (l, h) <- get
30− put (h + 1)
30+ put (l, h + 1)
33+ldefs :: State (LDefs, Int) LDefs
34+ldefs = do (l, h) <- get
33−simplify :: LExp -> State Int SExp
37+simplify :: LExp -> State (LDefs, Int) SExp
34simplify (LV (Loc i)) = return (SV (Loc i))
38simplify (LV (Loc i)) = return (SV (Loc i))
35−simplify (LV x) = return (SV x)
39+simplify (LV (Glob x))
41+ case lookupCtxt Nothing x ctxt of
42+ [LConstructor _ t 0] -> return $ SCon t x []
43+ _ -> return $ SV (Glob x)
36simplify (LApp tc n args) = do args' <- mapM sVar args
44simplify (LApp tc n args) = do args' <- mapM sVar args
37 mkapp (SApp tc n) args'
45 mkapp (SApp tc n) args'
38simplify (LLet n v e) = do v' <- simplify v
46simplify (LLet n v e) = do v' <- simplify v
39 e' <- simplify e
47 e' <- simplify e
40− return (SLet n v' e')
48+ return (SLet (Glob n) v' e')
41simplify (LCon i n args) = do args' <- mapM sVar args
49simplify (LCon i n args) = do args' <- mapM sVar args
42 mkapp (SCon i n) args'
50 mkapp (SCon i n) args'
43simplify (LCase e alts) = do v <- sVar e
51simplify (LCase e alts) = do v <- sVar e
@@ -45,11 +53,16 @@ simplify (LCase e alts) = do v <- sVar e
45 case v of
53 case v of
46 (x, Nothing) -> return (SCase x alts')
54 (x, Nothing) -> return (SCase x alts')
47 (Glob x, Just e) ->
55 (Glob x, Just e) ->
48− return (SLet x e (SCase (Glob x) alts'))
56+ return (SLet (Glob x) e (SCase (Glob x) alts'))
49simplify (LConst c) = return (SConst c)
57simplify (LConst c) = return (SConst c)
50simplify (LOp p args) = do args' <- mapM sVar args
58simplify (LOp p args) = do args' <- mapM sVar args
51 mkapp (SOp p) args'
59 mkapp (SOp p) args'
63+ case lookupCtxt Nothing x ctxt of
64+ [LConstructor _ t 0] -> sVar (LCon t x [])
65+ _ -> return (Glob x, Nothing)
53sVar (LV x) = return (x, Nothing)
66sVar (LV x) = return (x, Nothing)
54sVar e = do e' <- simplify e
67sVar e = do e' <- simplify e
@@ -58,8 +71,8 @@ sVar e = do e' <- simplify e
58mkapp f args = mkapp' f args [] where
71mkapp f args = mkapp' f args [] where
59 mkapp' f [] args = return $ f (reverse args)
72 mkapp' f [] args = return $ f (reverse args)
60 mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)
73 mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)
61− mkapp' f ((Glob x, Just e) : xs) args
74+ mkapp' f ((x, Just e) : xs) args
62− = do sc <- mkapp' f xs (Glob x : args)
75+ = do sc <- mkapp' f xs (x : args)
63 return (SLet x e sc)
76 return (SLet x e sc)
65sAlt (LConCase i n args e) = do e' <- simplify e
78sAlt (LConCase i n args e) = do e' <- simplify e
@@ -75,15 +88,15 @@ checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)
75 = do xs' <- checkDefs ctxt xs
88 = do xs' <- checkDefs ctxt xs
76 return xs'
89 return xs'
77checkDefs ctxt ((n, LFun n' args exp) : xs)
90checkDefs ctxt ((n, LFun n' args exp) : xs)
78− = do let sexp = evalState (simplify exp) 0
91+ = do let sexp = evalState (simplify exp) (ctxt, 0)
79 exp' <- scopecheck ctxt (zip args [0..]) sexp
92 exp' <- scopecheck ctxt (zip args [0..]) sexp
80 xs' <- checkDefs ctxt xs
93 xs' <- checkDefs ctxt xs
81 return ((n, SFun n' args exp') : xs')
94 return ((n, SFun n' args exp') : xs')
83scopecheck :: LDefs -> [(Name, Int)] -> SExp -> TC SExp
96scopecheck :: LDefs -> [(Name, Int)] -> SExp -> TC SExp
84scopecheck ctxt env tm = sc env tm where
97scopecheck ctxt env tm = sc env tm where
85− sc env (SV (Glob n))
98+ sc env (SV (Glob n)) =
86− = case lookup n (reverse env) of -- most recent first
99+ case lookup n (reverse env) of -- most recent first
87 Just i -> return (SV (Loc i))
100 Just i -> return (SV (Loc i))
88 Nothing -> case lookupCtxt Nothing n ctxt of
101 Nothing -> case lookupCtxt Nothing n ctxt of
89 [LConstructor _ i ar] ->
102 [LConstructor _ i ar] ->
@@ -93,25 +106,49 @@ scopecheck ctxt env tm = sc env tm where
93 [_] -> return (SV (Glob n))
106 [_] -> return (SV (Glob n))
94 [] -> fail $ "Codegen error: No such variable " ++ show n
107 [] -> fail $ "Codegen error: No such variable " ++ show n
95 sc env (SApp tc f args)
108 sc env (SApp tc f args)
109+ = do args' <- mapM (scVar env) args
96− = do case lookupCtxt Nothing f ctxt of
110+ case lookupCtxt Nothing f ctxt of
97 [LConstructor n tag ar] ->
111 [LConstructor n tag ar] ->
98 if (ar == length args)
112 if (ar == length args)
99− then return $ SCon tag n args
113+ then return $ SCon tag n args'
100 else fail $ "Codegen error: Constructor " ++ show f ++
114 else fail $ "Codegen error: Constructor " ++ show f ++
101 " has arity " ++ show ar
115 " has arity " ++ show ar
102− [_] -> return $ SApp tc f args
116+ [_] -> return $ SApp tc f args'
103 [] -> fail $ "Codegen error: No such variable " ++ show f
117 [] -> 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
104 sc env (SCase e alts)
127 sc env (SCase e alts)
128+ = do e' <- scVar env e
105− = do alts' <- mapM (scalt env) alts
129+ alts' <- mapM (scalt env) alts
106− return (SCase e alts')
130+ return (SCase e' alts')
107− sc env (SLet n v e)
131+ sc env (SLet (Glob n) v e)
109− e' <- sc (env ++ [(n, length env)]) e
132+ = do let env' = env ++ [(n, length env)]
134+ n' <- scVar env' (Glob n)
110− return (SLet n v' e')
136+ return (SLet n' v' e')
111 sc env (SOp prim args)
137 sc env (SOp prim args)
138+ = do args' <- mapM (scVar env) args
112− = do return (SOp prim args)
139+ return (SOp prim args')
113 sc env x = return x
140 sc env x = return x
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
115 scalt env (SConCase i n args e)
152 scalt env (SConCase i n args e)
116 = do let env' = env ++ zip args [length env..]
153 = do let env' = env ++ zip args [length env..]
117 tag <- case lookupCtxt Nothing n ctxt of
154 tag <- case lookupCtxt Nothing n ctxt of