git.iko.soy/Idris-dev
on master help sign in
New datatype for defunctionalised programs
783d45fEdwin Brady
src/IRTS/Defunctionalise.hs+92−44
compare with master
unifiedsplit
@@ -7,7 +7,30 @@ import Debug.Trace
7import Data.Maybe
7import Data.Maybe
8import Data.List
8import Data.List
9
9
10+data DExp = DV LVar
11+ | DApp Bool Name [DExp] -- True = tail call
12+ | DLet Name DExp DExp -- name just for pretty printing
13+ | DLam [Name] DExp -- lambda, lifted out before compiling
14+ | DC Int Name [DExp]
15+ | DCase DExp [DAlt]
16+ | DConst Const
17+ | DForeign FLang FType String [(FType, DExp)]
18+ | DOp PrimFn [DExp]
19+ | DError String
20+ deriving Eq
21+
22+data DAlt = DConCase Int Name [Name] DExp
23+ | DConstCase Const DExp
24+ | DDefaultCase DExp
25+ deriving (Show, Eq)
26+
27+data DDecl = DFun Name [Name] DExp -- name, arg names, definition
28+ | DConstructor Name Int Int -- constructor name, tag, arity
29+ deriving (Show, Eq)
30+
31+type DDefs = Ctxt DDecl
32+
10−defunctionalise :: Int -> LDefs -> LDefs
33+defunctionalise :: Int -> LDefs -> DDefs
11defunctionalise nexttag defs
34defunctionalise nexttag defs
12 = let all = toAlist defs
35 = let all = toAlist defs
13 -- sort newcons so that EVAL and APPLY cons get sequential tags
36 -- sort newcons so that EVAL and APPLY cons get sequential tags
@@ -36,57 +59,58 @@ getFn xs = mapMaybe fnData xs
36-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
59-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
37-- 8 Add explicit EVAL to case, primitives, and foreign calls
60-- 8 Add explicit EVAL to case, primitives, and foreign calls
38
61
39−addApps :: LDefs -> (Name, LDecl) -> (Name, LDecl)
62+addApps :: LDefs -> (Name, LDecl) -> (Name, DDecl)
40−addApps defs o@(n, LConstructor _ _ _) = o
63+addApps defs o@(n, LConstructor _ t a) = (n, DConstructor n t a)
41−addApps defs (n, LFun _ args e) = (n, LFun n args (aa args e))
64+addApps defs (n, LFun _ args e) = (n, DFun n args (aa args e))
42 where
65 where
66+ aa :: [Name] -> LExp -> DExp
43− aa env (LV (Glob n)) | n `elem` env = LV (Glob n)
67+ aa env (LV (Glob n)) | n `elem` env = DV (Glob n)
44 | otherwise = aa env (LApp False (LV (Glob n)) [])
68 | otherwise = aa env (LApp False (LV (Glob n)) [])
45-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e
69-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e
46 aa env (LApp tc (LV (Glob n)) args)
70 aa env (LApp tc (LV (Glob n)) args)
47 = let args' = map (aa env) args in
71 = let args' = map (aa env) args in
48 case lookupCtxt Nothing n defs of
72 case lookupCtxt Nothing n defs of
49− [LConstructor _ i ar] -> LApp tc (LV (Glob n)) args'
73+ [LConstructor _ i ar] -> DApp tc n args'
50 [LFun _ as _] -> let arity = length as in
74 [LFun _ as _] -> let arity = length as in
51 fixApply tc n args' arity
75 fixApply tc n args' arity
52− [] -> chainAPPLY (LV (Glob n)) args'
76+ [] -> chainAPPLY (DV (Glob n)) args'
53 aa env (LLazyApp n args)
77 aa env (LLazyApp n args)
54 = let args' = map (aa env) args in
78 = let args' = map (aa env) args in
55 case lookupCtxt Nothing n defs of
79 case lookupCtxt Nothing n defs of
56− [LConstructor _ i ar] -> LApp False (LV (Glob n)) args'
80+ [LConstructor _ i ar] -> DApp False n args'
57 [LFun _ as _] -> let arity = length as in
81 [LFun _ as _] -> let arity = length as in
58 fixLazyApply n args' arity
82 fixLazyApply n args' arity
59− [] -> chainAPPLY (LV (Glob n)) args'
83+ [] -> chainAPPLY (DV (Glob n)) args'
60 aa env (LForce e) = eEVAL (aa env e)
84 aa env (LForce e) = eEVAL (aa env e)
61− aa env (LLet n v sc) = LLet n (aa env v) (aa (n : env) sc)
85+ aa env (LLet n v sc) = DLet n (aa env v) (aa (n : env) sc)
62− aa env (LCon i n args) = LCon i n (map (aa env) args)
86+ aa env (LCon i n args) = DC i n (map (aa env) args)
63− aa env (LCase e alts) = LCase (eEVAL (aa env e)) (map (aaAlt env) alts)
87+ aa env (LCase e alts) = DCase (eEVAL (aa env e)) (map (aaAlt env) alts)
64− aa env (LConst c) = LConst c
88+ aa env (LConst c) = DConst c
65− aa env (LForeign l t n args) = LForeign l t n (map (aaF env) args)
89+ aa env (LForeign l t n args) = DForeign l t n (map (aaF env) args)
66− aa env (LOp LFork args) = LOp LFork (map (aa env) args)
90+ aa env (LOp LFork args) = DOp LFork (map (aa env) args)
67− aa env (LOp f args) = LOp f (map (eEVAL . (aa env)) args)
91+ aa env (LOp f args) = DOp f (map (eEVAL . (aa env)) args)
68− aa env (LError e) = LError e
92+ aa env (LError e) = DError e
69
93
70 aaF env (t, e) = (t, eEVAL (aa env e))
94 aaF env (t, e) = (t, eEVAL (aa env e))
71
95
72− aaAlt env (LConCase i n args e) = LConCase i n args (aa (args ++ env) e)
96+ aaAlt env (LConCase i n args e) = DConCase i n args (aa (args ++ env) e)
73− aaAlt env (LConstCase c e) = LConstCase c (aa env e)
97+ aaAlt env (LConstCase c e) = DConstCase c (aa env e)
74− aaAlt env (LDefaultCase e) = LDefaultCase (aa env e)
98+ aaAlt env (LDefaultCase e) = DDefaultCase (aa env e)
75
99
76 fixApply tc n args ar
100 fixApply tc n args ar
77− | length args == ar = LApp tc (LV (Glob n)) args
101+ | length args == ar = DApp tc n args
78− | length args < ar = LApp tc (LV (Glob (mkUnderCon n (ar - length args)))) args
102+ | length args < ar = DApp tc (mkUnderCon n (ar - length args)) args
79− | length args > ar = chainAPPLY (LApp tc (LV (Glob n)) (take ar args)) (drop ar args)
103+ | length args > ar = chainAPPLY (DApp tc n (take ar args)) (drop ar args)
80
104
81 fixLazyApply n args ar
105 fixLazyApply n args ar
82− | length args == ar = LApp False (LV (Glob (mkFnCon n))) args
106+ | length args == ar = DApp False (mkFnCon n) args
83− | length args < ar = LApp False (LV (Glob (mkUnderCon n (ar - length args)))) args
107+ | length args < ar = DApp False (mkUnderCon n (ar - length args)) args
84− | length args > ar = chainAPPLY (LApp False (LV (Glob n)) (take ar args)) (drop ar args)
108+ | length args > ar = chainAPPLY (DApp False n (take ar args)) (drop ar args)
85
109
86 chainAPPLY f [] = f
110 chainAPPLY f [] = f
87− chainAPPLY f (a : as) = chainAPPLY (LApp False (LV (Glob (MN 0 "APPLY"))) [f, a]) as
111+ chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as
88
112
89−eEVAL x = LApp False (LV (Glob (MN 0 "EVAL"))) [x]
113+eEVAL x = DApp False (MN 0 "EVAL") [x]
90
114
91data EvalApply a = EvalCase a
115data EvalApply a = EvalCase a
92 | ApplyCase a
116 | ApplyCase a
@@ -95,44 +119,44 @@ data EvalApply a = EvalCase a
95-- For a function name, generate a list of
119-- For a function name, generate a list of
96-- data constuctors, and whether to handle them in EVAL or APPLY
120-- data constuctors, and whether to handle them in EVAL or APPLY
97
121
98−toCons :: (Name, Int) -> [(Name, Int, EvalApply LAlt)]
122+toCons :: (Name, Int) -> [(Name, Int, EvalApply DAlt)]
99toCons (n, i)
123toCons (n, i)
100 = (mkFnCon n, i,
124 = (mkFnCon n, i,
101− EvalCase (LConCase (-1) (mkFnCon n) (take i (genArgs 0))
125+ EvalCase (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
102− (eEVAL (LApp False (LV (Glob n)) (map (LV . Glob) (take i (genArgs 0)))))))
126+ (eEVAL (DApp False n (map (DV . Glob) (take i (genArgs 0)))))))
103 : mkApplyCase n 0 i
127 : mkApplyCase n 0 i
104
128
105mkApplyCase fname n ar | n == ar = []
129mkApplyCase fname n ar | n == ar = []
106mkApplyCase fname n ar
130mkApplyCase fname n ar
107 = let nm = mkUnderCon fname (ar - n) in
131 = let nm = mkUnderCon fname (ar - n) in
108− (nm, n, ApplyCase (LConCase (-1) nm (take n (genArgs 0))
132+ (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))
109− (LApp False (LV (Glob (mkUnderCon fname (ar - (n + 1)))))
133+ (DApp False (mkUnderCon fname (ar - (n + 1)))
110− (map (LV . Glob) (take n (genArgs 0) ++
134+ (map (DV . Glob) (take n (genArgs 0) ++
111 [MN 0 "arg"])))))
135 [MN 0 "arg"])))))
112 : mkApplyCase fname (n + 1) ar
136 : mkApplyCase fname (n + 1) ar
113
137
114−mkEval :: [(Name, Int, EvalApply LAlt)] -> (Name, LDecl)
138+mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
115−mkEval xs = (MN 0 "EVAL", LFun (MN 0 "EVAL") [MN 0 "arg"]
139+mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"]
116− (LCase (LV (Glob (MN 0 "arg")))
140+ (DCase (DV (Glob (MN 0 "arg")))
117 (mapMaybe evalCase xs ++
141 (mapMaybe evalCase xs ++
118− [LDefaultCase (LV (Glob (MN 0 "arg")))])))
142+ [DDefaultCase (DV (Glob (MN 0 "arg")))])))
119 where
143 where
120 evalCase (n, t, EvalCase x) = Just x
144 evalCase (n, t, EvalCase x) = Just x
121 evalCase _ = Nothing
145 evalCase _ = Nothing
122
146
123−mkApply :: [(Name, Int, EvalApply LAlt)] -> (Name, LDecl)
147+mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
124−mkApply xs = (MN 0 "APPLY", LFun (MN 0 "APPLY") [MN 0 "fn", MN 0 "arg"]
148+mkApply xs = (MN 0 "APPLY", DFun (MN 0 "APPLY") [MN 0 "fn", MN 0 "arg"]
125− (LCase (LApp False (LV (Glob (MN 0 "EVAL")))
149+ (DCase (DApp False (MN 0 "EVAL")
126− [LV (Glob (MN 0 "fn"))])
150+ [DV (Glob (MN 0 "fn"))])
127 (mapMaybe applyCase xs)))
151 (mapMaybe applyCase xs)))
128 where
152 where
129 applyCase (n, t, ApplyCase x) = Just x
153 applyCase (n, t, ApplyCase x) = Just x
130 applyCase _ = Nothing
154 applyCase _ = Nothing
131
155
132−declare :: Int -> [(Name, Int, EvalApply LAlt)] -> [(Name, LDecl)]
156+declare :: Int -> [(Name, Int, EvalApply DAlt)] -> [(Name, DDecl)]
133declare t xs = dec' t xs [] where
157declare t xs = dec' t xs [] where
134 dec' t [] acc = reverse acc
158 dec' t [] acc = reverse acc
135− dec' t ((n, ar, _) : xs) acc = dec' (t + 1) xs ((n, LConstructor n t ar) : acc)
159+ dec' t ((n, ar, _) : xs) acc = dec' (t + 1) xs ((n, DConstructor n t ar) : acc)
136
160
137
161
138genArgs i = MN i "P_c" : genArgs (i + 1)
162genArgs i = MN i "P_c" : genArgs (i + 1)
@@ -141,3 +165,27 @@ mkFnCon n = MN 0 ("P_" ++ show n)
141mkUnderCon n 0 = n
165mkUnderCon n 0 = n
142mkUnderCon n missing = MN missing ("U_" ++ show n)
166mkUnderCon n missing = MN missing ("U_" ++ show n)
143
167
168+instance Show DExp where
169+ show e = show' [] e where
170+ show' env (DV (Loc i)) = env!!i
171+ show' env (DV (Glob n)) = show n
172+ show' env (DApp _ e args) = show e ++ "(" ++
173+ showSep ", " (map (show' env) args) ++")"
174+ show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++
175+ show' (env ++ [show n]) e
176+ show' env (DLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++
177+ show' (env ++ (map show args)) e
178+ show' env (DC i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"
179+ show' env (DCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++
180+ showSep "\n\t| " (map (showAlt env) alts)
181+ show' env (DConst c) = show c
182+ show' env (DForeign lang ty n args)
183+ = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"
184+ show' env (DOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"
185+ show' env (DError str) = "error " ++ show str
186+
187+ showAlt env (DConCase _ n args e)
188+ = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
189+ ++ show' env e
190+ showAlt env (DConstCase c e) = show c ++ " => " ++ show' env e
191+ showAlt env (DDefaultCase e) = "_ => " ++ show' env e
src/IRTS/Simplified.hs+31−31
@@ -1,6 +1,7 @@
1module IRTS.Simplified where
1module IRTS.Simplified where
2
2
3import IRTS.Lang
3import IRTS.Lang
4+import IRTS.Defunctionalise
4import Core.TT
5import Core.TT
5import Data.Maybe
6import Data.Maybe
6import Control.Monad.State
7import Control.Monad.State
@@ -27,51 +28,50 @@ data SAlt = SConCase Int Int Name [Name] SExp
27data SDecl = SFun Name [Name] Int SExp
28data SDecl = SFun Name [Name] Int SExp
28 deriving Show
29 deriving Show
29
30
30−hvar :: State (LDefs, Int) Int
31+hvar :: State (DDefs, Int) Int
31hvar = do (l, h) <- get
32hvar = do (l, h) <- get
32 put (l, h + 1)
33 put (l, h + 1)
33 return h
34 return h
34
35
35−ldefs :: State (LDefs, Int) LDefs
36+ldefs :: State (DDefs, Int) DDefs
36ldefs = do (l, h) <- get
37ldefs = do (l, h) <- get
37 return l
38 return l
38
39
39−simplify :: Bool -> LExp -> State (LDefs, Int) SExp
40+simplify :: Bool -> DExp -> State (DDefs, Int) SExp
40−simplify tl (LV (Loc i)) = return (SV (Loc i))
41+simplify tl (DV (Loc i)) = return (SV (Loc i))
41−simplify tl (LV (Glob x))
42+simplify tl (DV (Glob x))
42 = do ctxt <- ldefs
43 = do ctxt <- ldefs
43 case lookupCtxt Nothing x ctxt of
44 case lookupCtxt Nothing x ctxt of
44− [LConstructor _ t 0] -> return $ SCon t x []
45+ [DConstructor _ t 0] -> return $ SCon t x []
45 _ -> return $ SV (Glob x)
46 _ -> return $ SV (Glob x)
46−simplify tl (LApp tc (LV (Glob n)) args)
47− = do args' <- mapM sVar args
47+simplify tl (DApp tc n args) = do args' <- mapM sVar args
48 mkapp (SApp (tl || tc) n) args'
48 mkapp (SApp (tl || tc) n) args'
49−simplify tl (LForeign lang ty fn args)
49+simplify tl (DForeign lang ty fn args)
50 = do args' <- mapM sVar (map snd args)
50 = do args' <- mapM sVar (map snd args)
51 let fargs = zip (map fst args) args'
51 let fargs = zip (map fst args) args'
52 mkfapp (SForeign lang ty fn) fargs
52 mkfapp (SForeign lang ty fn) fargs
53−simplify tl (LLet n v e) = do v' <- simplify False v
53+simplify tl (DLet n v e) = do v' <- simplify False v
54 e' <- simplify tl e
54 e' <- simplify tl e
55 return (SLet (Glob n) v' e')
55 return (SLet (Glob n) v' e')
56−simplify tl (LCon i n args) = do args' <- mapM sVar args
56+simplify tl (DC i n args) = do args' <- mapM sVar args
57− mkapp (SCon i n) args'
57+ mkapp (SCon i n) args'
58−simplify tl (LCase e alts) = do v <- sVar e
58+simplify tl (DCase e alts) = do v <- sVar e
59 alts' <- mapM (sAlt tl) alts
59 alts' <- mapM (sAlt tl) alts
60 case v of
60 case v of
61 (x, Nothing) -> return (SCase x alts')
61 (x, Nothing) -> return (SCase x alts')
62 (Glob x, Just e) ->
62 (Glob x, Just e) ->
63 return (SLet (Glob x) e (SCase (Glob x) alts'))
63 return (SLet (Glob x) e (SCase (Glob x) alts'))
64−simplify tl (LConst c) = return (SConst c)
64+simplify tl (DConst c) = return (SConst c)
65−simplify tl (LOp p args) = do args' <- mapM sVar args
65+simplify tl (DOp p args) = do args' <- mapM sVar args
66 mkapp (SOp p) args'
66 mkapp (SOp p) args'
67−simplify tl (LError str) = return $ SError str
67+simplify tl (DError str) = return $ SError str
68
68
69−sVar (LV (Glob x))
69+sVar (DV (Glob x))
70 = do ctxt <- ldefs
70 = do ctxt <- ldefs
71 case lookupCtxt Nothing x ctxt of
71 case lookupCtxt Nothing x ctxt of
72− [LConstructor _ t 0] -> sVar (LCon t x [])
72+ [DConstructor _ t 0] -> sVar (DC t x [])
73 _ -> return (Glob x, Nothing)
73 _ -> return (Glob x, Nothing)
74−sVar (LV x) = return (x, Nothing)
74+sVar (DV x) = return (x, Nothing)
75sVar e = do e' <- simplify False e
75sVar e = do e' <- simplify False e
76 i <- hvar
76 i <- hvar
77 return (Glob (MN i "R"), Just e')
77 return (Glob (MN i "R"), Just e')
@@ -90,19 +90,19 @@ mkfapp f args = mkapp' f args [] where
90 = do sc <- mkapp' f xs ((ty, x) : args)
90 = do sc <- mkapp' f xs ((ty, x) : args)
91 return (SLet x e sc)
91 return (SLet x e sc)
92
92
93−sAlt tl (LConCase i n args e) = do e' <- simplify tl e
93+sAlt tl (DConCase i n args e) = do e' <- simplify tl e
94 return (SConCase (-1) i n args e')
94 return (SConCase (-1) i n args e')
95−sAlt tl (LConstCase c e) = do e' <- simplify tl e
95+sAlt tl (DConstCase c e) = do e' <- simplify tl e
96 return (SConstCase c e')
96 return (SConstCase c e')
97−sAlt tl (LDefaultCase e) = do e' <- simplify tl e
97+sAlt tl (DDefaultCase e) = do e' <- simplify tl e
98 return (SDefaultCase e')
98 return (SDefaultCase e')
99
99
100−checkDefs :: LDefs -> [(Name, LDecl)] -> TC [(Name, SDecl)]
100+checkDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]
101checkDefs ctxt [] = return []
101checkDefs ctxt [] = return []
102−checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)
102+checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)
103 = do xs' <- checkDefs ctxt xs
103 = do xs' <- checkDefs ctxt xs
104 return xs'
104 return xs'
105−checkDefs ctxt ((n, LFun n' args exp) : xs)
105+checkDefs ctxt ((n, DFun n' args exp) : xs)
106 = do let sexp = evalState (simplify True exp) (ctxt, 0)
106 = do let sexp = evalState (simplify True exp) (ctxt, 0)
107 (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)
107 (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)
108 xs' <- checkDefs ctxt xs
108 xs' <- checkDefs ctxt xs
@@ -111,13 +111,13 @@ checkDefs ctxt ((n, LFun n' args exp) : xs)
111lvar v = do i <- get
111lvar v = do i <- get
112 put (max i v)
112 put (max i v)
113
113
114−scopecheck :: LDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
114+scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
115scopecheck ctxt env tm = sc env tm where
115scopecheck ctxt env tm = sc env tm where
116 sc env (SV (Glob n)) =
116 sc env (SV (Glob n)) =
117 case lookup n (reverse env) of -- most recent first
117 case lookup n (reverse env) of -- most recent first
118 Just i -> do lvar i; return (SV (Loc i))
118 Just i -> do lvar i; return (SV (Loc i))
119 Nothing -> case lookupCtxt Nothing n ctxt of
119 Nothing -> case lookupCtxt Nothing n ctxt of
120− [LConstructor _ i ar] ->
120+ [DConstructor _ i ar] ->
121 if True -- ar == 0
121 if True -- ar == 0
122 then return (SCon i n [])
122 then return (SCon i n [])
123 else fail $ "Codegen error: Constructor " ++ show n ++
123 else fail $ "Codegen error: Constructor " ++ show n ++
@@ -127,7 +127,7 @@ scopecheck ctxt env tm = sc env tm where
127 sc env (SApp tc f args)
127 sc env (SApp tc f args)
128 = do args' <- mapM (scVar env) args
128 = do args' <- mapM (scVar env) args
129 case lookupCtxt Nothing f ctxt of
129 case lookupCtxt Nothing f ctxt of
130− [LConstructor n tag ar] ->
130+ [DConstructor n tag ar] ->
131 if True -- (ar == length args)
131 if True -- (ar == length args)
132 then return $ SCon tag n args'
132 then return $ SCon tag n args'
133 else fail $ "Codegen error: Constructor " ++ show f ++
133 else fail $ "Codegen error: Constructor " ++ show f ++
@@ -141,7 +141,7 @@ scopecheck ctxt env tm = sc env tm where
141 sc env (SCon tag f args)
141 sc env (SCon tag f args)
142 = do args' <- mapM (scVar env) args
142 = do args' <- mapM (scVar env) args
143 case lookupCtxt Nothing f ctxt of
143 case lookupCtxt Nothing f ctxt of
144− [LConstructor n tag ar] ->
144+ [DConstructor n tag ar] ->
145 if True -- (ar == length args)
145 if True -- (ar == length args)
146 then return $ SCon tag n args'
146 then return $ SCon tag n args'
147 else fail $ "Codegen error: Constructor " ++ show f ++
147 else fail $ "Codegen error: Constructor " ++ show f ++
@@ -166,7 +166,7 @@ scopecheck ctxt env tm = sc env tm where
166 case lookup n (reverse env) of -- most recent first
166 case lookup n (reverse env) of -- most recent first
167 Just i -> do lvar i; return (Loc i)
167 Just i -> do lvar i; return (Loc i)
168 Nothing -> case lookupCtxt Nothing n ctxt of
168 Nothing -> case lookupCtxt Nothing n ctxt of
169− [LConstructor _ i ar] ->
169+ [DConstructor _ i ar] ->
170 fail $ "Codegen error : can't pass constructor here"
170 fail $ "Codegen error : can't pass constructor here"
171 [_] -> return (Glob n)
171 [_] -> return (Glob n)
172 [] -> fail $ "Codegen error: No such variable " ++ show n
172 [] -> fail $ "Codegen error: No such variable " ++ show n
@@ -175,7 +175,7 @@ scopecheck ctxt env tm = sc env tm where
175 scalt env (SConCase _ i n args e)
175 scalt env (SConCase _ i n args e)
176 = do let env' = env ++ zip args [length env..]
176 = do let env' = env ++ zip args [length env..]
177 tag <- case lookupCtxt Nothing n ctxt of
177 tag <- case lookupCtxt Nothing n ctxt of
178− [LConstructor _ i ar] ->
178+ [DConstructor _ i ar] ->
179 if True -- (length args == ar)
179 if True -- (length args == ar)
180 then return i
180 then return i
181 else fail $ "Codegen error: Constructor " ++ show n ++
181 else fail $ "Codegen error: Constructor " ++ show n ++