git.iko.soy/Idris-dev
on master help sign in
Merge pull request #3919 from geigerzaehler/simplify-language-var
50d0e48Ahmad Salim Al-Sibahi
src/IRTS/Compiler.hs+13−13
compare with master
unifiedsplit
@@ -214,7 +214,7 @@ build (n, d)
214 Just (ar, op) ->
214 Just (ar, op) ->
215 let args = map (\x -> sMN x "op") [0..] in
215 let args = map (\x -> sMN x "op") [0..] in
216 return (n, (LFun [] n (take ar args)
216 return (n, (LFun [] n (take ar args)
217− (LOp op (map (LV . Glob) (take ar args)))))
217+ (LOp op (map LV (take ar args)))))
218 _ -> do def <- mkLDecl n d
218 _ -> do def <- mkLDecl n d
219 logCodeGen 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
219 logCodeGen 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
220 return (n, def)
220 return (n, def)
@@ -398,7 +398,7 @@ irTerm top vs env tm@(App _ f a) = do
398 -> irTerm top vs env (head argsPruned)
398 -> irTerm top vs env (head argsPruned)
399
399
400 | otherwise -- not newtype, plain data ctor
400 | otherwise -- not newtype, plain data ctor
401− -> buildApp (LV $ Glob n) argsPruned
401+ -> buildApp (LV n) argsPruned
402
402
403 -- not saturated, underapplied
403 -- not saturated, underapplied
404 LT | isNewtype -- newtype
404 LT | isNewtype -- newtype
@@ -407,11 +407,11 @@ irTerm top vs env tm@(App _ f a) = do
407 <$> irTerm top vs env (head argsPruned)
407 <$> irTerm top vs env (head argsPruned)
408
408
409 | isNewtype -- newtype but the value is not among args yet
409 | isNewtype -- newtype but the value is not among args yet
410− -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]
410+ -> return . padLams $ \[vn] -> LApp False (LV n) [LV vn]
411
411
412 -- not a newtype, just apply to a constructor
412 -- not a newtype, just apply to a constructor
413 | otherwise
413 | otherwise
414− -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned
414+ -> padLams . applyToNames <$> buildApp (LV n) argsPruned
415
415
416 -- type constructor
416 -- type constructor
417 (P (TCon t a) n _, args) -> return LNothing
417 (P (TCon t a) n _, args) -> return LNothing
@@ -446,7 +446,7 @@ irTerm top vs env tm@(App _ f a) = do
446
446
447 applyToNames :: LExp -> [Name] -> LExp
447 applyToNames :: LExp -> [Name] -> LExp
448 applyToNames tm [] = tm
448 applyToNames tm [] = tm
449− applyToNames tm ns = LApp False tm $ map (LV . Glob) ns
449+ applyToNames tm ns = LApp False tm $ map LV ns
450
450
451 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp
451 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp
452 padLambdas used startIdx endSIdx mkTerm
452 padLambdas used startIdx endSIdx mkTerm
@@ -457,7 +457,7 @@ irTerm top vs env tm@(App _ f a) = do
457
457
458 applyName :: Name -> IState -> [Term] -> Idris LExp
458 applyName :: Name -> IState -> [Term] -> Idris LExp
459 applyName n ist args =
459 applyName n ist args =
460− LApp False (LV $ Glob n) <$> mapM (irTerm top vs env . erase) (zip [0..] args)
460+ LApp False (LV n) <$> mapM (irTerm top vs env . erase) (zip [0..] args)
461 where
461 where
462 erase (i, x)
462 erase (i, x)
463 | i >= arity || i `elem` used = x
463 | i >= arity || i `elem` used = x
@@ -479,9 +479,9 @@ irTerm top vs env tm@(App _ f a) = do
479 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
479 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
480 fst4 (x,_,_,_,_,_) = x
480 fst4 (x,_,_,_,_,_) = x
481
481
482−irTerm top vs env (P _ n _) = return $ LV (Glob n)
482+irTerm top vs env (P _ n _) = return $ LV n
483irTerm top vs env (V i)
483irTerm top vs env (V i)
484− | i >= 0 && i < length env = return $ LV (Glob (env!!i))
484+ | i >= 0 && i < length env = return $ LV (env!!i)
485 | otherwise = ifail $ "bad de bruijn index: " ++ show i
485 | otherwise = ifail $ "bad de bruijn index: " ++ show i
486
486
487irTerm top vs env (Bind n (Lam _ _) sc) = LLam [n'] <$> irTerm top vs (n':env) sc
487irTerm top vs env (Bind n (Lam _ _) sc) = LLam [n'] <$> irTerm top vs (n':env) sc
@@ -546,7 +546,7 @@ irSC top vs (ProjCase tm alts) = do
546irSC top vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])
546irSC top vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])
547 | delay == txt "Delay"
547 | delay == txt "Delay"
548 = do sc' <- irSC top vs sc -- mkForce n' n sc
548 = do sc' <- irSC top vs sc -- mkForce n' n sc
549− return $ lsubst n' (LForce (LV (Glob n))) sc'
549+ return $ lsubst n' (LForce (LV n)) sc'
550
550
551-- There are two transformations in this case:
551-- There are two transformations in this case:
552--
552--
@@ -583,10 +583,10 @@ irSC top vs (Case up n [alt]) = do
583 case replacement of
583 case replacement of
584 Just sc -> irSC top vs sc
584 Just sc -> irSC top vs sc
585 _ -> do
585 _ -> do
586− alt' <- irAlt top vs (LV (Glob n)) alt
586+ alt' <- irAlt top vs (LV n) alt
587 return $ case namesBoundIn alt' `usedIn` subexpr alt' of
587 return $ case namesBoundIn alt' `usedIn` subexpr alt' of
588 [] -> subexpr alt' -- strip the unused top-most case
588 [] -> subexpr alt' -- strip the unused top-most case
589− _ -> LCase up (LV (Glob n)) [alt']
589+ _ -> LCase up (LV n) [alt']
590 where
590 where
591 namesBoundIn :: LAlt -> [Name]
591 namesBoundIn :: LAlt -> [Name]
592 namesBoundIn (LConCase cn i ns sc) = ns
592 namesBoundIn (LConCase cn i ns sc) = ns
@@ -618,7 +618,7 @@ irSC top vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do
618 detag <- fgetState (opt_detaggable . ist_optimisation cn)
618 detag <- fgetState (opt_detaggable . ist_optimisation cn)
619 if detag
619 if detag
620 then irSC top vs (Case up n [ConCase cn a ns sc])
620 then irSC top vs (Case up n [ConCase cn a ns sc])
621− else LCase up (LV (Glob n)) <$> mapM (irAlt top vs (LV (Glob n))) alts
621+ else LCase up (LV n) <$> mapM (irAlt top vs (LV n)) alts
622
622
623irSC top vs sc@(Case up n alts) = do
623irSC top vs sc@(Case up n alts) = do
624 -- check that neither alternative needs the newtype optimisation,
624 -- check that neither alternative needs the newtype optimisation,
@@ -628,7 +628,7 @@ irSC top vs sc@(Case up n alts) = do
628 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)
628 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)
629
629
630 -- everything okay
630 -- everything okay
631− LCase up (LV (Glob n)) <$> mapM (irAlt top vs (LV (Glob n))) alts
631+ LCase up (LV n) <$> mapM (irAlt top vs (LV n)) alts
632 where
632 where
633 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn
633 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn
634 isDetaggable _ = return False
634 isDetaggable _ = return False
src/IRTS/Defunctionalise.hs+23−24
@@ -34,12 +34,12 @@ import Data.List
34import Data.Maybe
34import Data.Maybe
35import Debug.Trace
35import Debug.Trace
36
36
37−data DExp = DV LVar
37+data DExp = DV Name
38 | DApp Bool Name [DExp] -- True = tail call
38 | DApp Bool Name [DExp] -- True = tail call
39 | DLet Name DExp DExp -- name just for pretty printing
39 | DLet Name DExp DExp -- name just for pretty printing
40 | DUpdate Name DExp -- eval expression, then update var with it
40 | DUpdate Name DExp -- eval expression, then update var with it
41 | DProj DExp Int
41 | DProj DExp Int
42− | DC (Maybe LVar) Int Name [DExp]
42+ | DC (Maybe Name) Int Name [DExp]
43 | DCase CaseType DExp [DAlt]
43 | DCase CaseType DExp [DAlt]
44 | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY)
44 | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY)
45 | DConst Const
45 | DConst Const
@@ -90,27 +90,27 @@ addApps defs (n, LFun _ _ args e)
90 return (n, DFun n args e')
90 return (n, DFun n args e')
91 where
91 where
92 aa :: [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
92 aa :: [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
93− aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)
93+ aa env (LV n) | n `elem` env = return $ DV n
94− | otherwise = aa env (LApp False (LV (Glob n)) [])
94+ | otherwise = aa env (LApp False (LV n) [])
95− aa env (LApp tc (LV (Glob n)) args)
95+ aa env (LApp tc (LV n) args)
96 = do args' <- mapM (aa env) args
96 = do args' <- mapM (aa env) args
97 case lookupCtxtExact n defs of
97 case lookupCtxtExact n defs of
98 Just (LConstructor _ i ar) -> return $ DApp tc n args'
98 Just (LConstructor _ i ar) -> return $ DApp tc n args'
99 Just (LFun _ _ as _) -> let arity = length as in
99 Just (LFun _ _ as _) -> let arity = length as in
100 fixApply tc n args' arity
100 fixApply tc n args' arity
101− Nothing -> return $ chainAPPLY (DV (Glob n)) args'
101+ Nothing -> return $ chainAPPLY (DV n) args'
102 aa env (LLazyApp n args)
102 aa env (LLazyApp n args)
103 = do args' <- mapM (aa env) args
103 = do args' <- mapM (aa env) args
104 case lookupCtxtExact n defs of
104 case lookupCtxtExact n defs of
105 Just (LConstructor _ i ar) -> return $ DApp False n args'
105 Just (LConstructor _ i ar) -> return $ DApp False n args'
106 Just (LFun _ _ as _) -> let arity = length as in
106 Just (LFun _ _ as _) -> let arity = length as in
107 fixLazyApply n args' arity
107 fixLazyApply n args' arity
108− Nothing -> return $ chainAPPLY (DV (Glob n)) args'
108+ Nothing -> return $ chainAPPLY (DV n) args'
109− aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV (Glob n)) args)
109+ aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV n) args)
110 aa env (LForce e) = liftM eEVAL (aa env e)
110 aa env (LForce e) = liftM eEVAL (aa env e)
111 aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)
111 aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)
112 aa env (LCon loc i n args) = liftM (DC loc i n) (mapM (aa env) args)
112 aa env (LCon loc i n args) = liftM (DC loc i n) (mapM (aa env) args)
113− aa env (LProj t@(LV (Glob n)) i)
113+ aa env (LProj t@(LV n) i)
114 | n `elem` env = do t' <- aa env t
114 | n `elem` env = do t' <- aa env t
115 return $ DProj (DUpdate n t') i
115 return $ DProj (DUpdate n t') i
116 aa env (LProj t i) = do t' <- aa env t
116 aa env (LProj t i) = do t' <- aa env t
@@ -170,7 +170,7 @@ addApps defs (n, LFun _ _ args e)
170
170
171 preEval [] t = t
171 preEval [] t = t
172 preEval (x : xs) t
172 preEval (x : xs) t
173− | needsEval x t = DLet x (DV (Glob x)) (preEval xs t)
173+ | needsEval x t = DLet x (DV x) (preEval xs t)
174 | otherwise = preEval xs t
174 | otherwise = preEval xs t
175
175
176 needsEval x (DApp _ _ args) = any (needsEval x) args
176 needsEval x (DApp _ _ args) = any (needsEval x) args
@@ -188,7 +188,7 @@ addApps defs (n, LFun _ _ args e)
188 | otherwise = needsEval x v || needsEval x e
188 | otherwise = needsEval x v || needsEval x e
189 needsEval x (DForeign _ _ args) = any (needsEval x) (map snd args)
189 needsEval x (DForeign _ _ args) = any (needsEval x) (map snd args)
190 needsEval x (DOp op args) = any (needsEval x) args
190 needsEval x (DOp op args) = any (needsEval x) args
191− needsEval x (DProj (DV (Glob x')) _) = x == x'
191+ needsEval x (DProj (DV x') _) = x == x'
192 needsEval x _ = False
192 needsEval x _ = False
193
193
194eEVAL x = DApp False (sMN 0 "EVAL") [x]
194eEVAL x = DApp False (sMN 0 "EVAL") [x]
@@ -207,7 +207,7 @@ toCons ns (n, i)
207 EvalCase (\tlarg ->
207 EvalCase (\tlarg ->
208 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
208 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
209 (dupdate tlarg
209 (dupdate tlarg
210− (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))
210+ (DApp False n (map DV (take i (genArgs 0))))))))
211 : [] -- mkApplyCase n 0 i
211 : [] -- mkApplyCase n 0 i
212 | otherwise = []
212 | otherwise = []
213 where dupdate tlarg x = DUpdate tlarg x
213 where dupdate tlarg x = DUpdate tlarg x
@@ -219,7 +219,7 @@ toConsA ns (n, i)
219-- EvalCase (\tlarg ->
219-- EvalCase (\tlarg ->
220-- (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
220-- (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
221-- (dupdate tlarg
221-- (dupdate tlarg
222−-- (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))
222+-- (DApp False n (map DV (take i (genArgs 0))))))))
223 = mkApplyCase n ar i
223 = mkApplyCase n ar i
224 | otherwise = []
224 | otherwise = []
225 where dupdate tlarg x = x
225 where dupdate tlarg x = x
@@ -229,13 +229,13 @@ mkApplyCase fname n ar
229 = let nm = mkUnderCon fname (ar - n) in
229 = let nm = mkUnderCon fname (ar - n) in
230 (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))
230 (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))
231 (DApp False (mkUnderCon fname (ar - (n + 1)))
231 (DApp False (mkUnderCon fname (ar - (n + 1)))
232− (map (DV . Glob) (take n (genArgs 0) ++
232+ (map DV (take n (genArgs 0) ++
233 [sMN 0 "arg"])))))
233 [sMN 0 "arg"])))))
234 :
234 :
235 if (ar - (n + 2) >=0 )
235 if (ar - (n + 2) >=0 )
236 then (nm, n, Apply2Case (DConCase (-1) nm (take n (genArgs 0))
236 then (nm, n, Apply2Case (DConCase (-1) nm (take n (genArgs 0))
237 (DApp False (mkUnderCon fname (ar - (n + 2)))
237 (DApp False (mkUnderCon fname (ar - (n + 2)))
238− (map (DV . Glob) (take n (genArgs 0) ++
238+ (map DV (take n (genArgs 0) ++
239 [sMN 0 "arg0", sMN 0 "arg1"])))))
239 [sMN 0 "arg0", sMN 0 "arg1"])))))
240 :
240 :
241 mkApplyCase fname (n + 1) ar
241 mkApplyCase fname (n + 1) ar
@@ -243,9 +243,9 @@ mkApplyCase fname n ar
243
243
244mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
244mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
245mkEval xs = (sMN 0 "EVAL", DFun (sMN 0 "EVAL") [sMN 0 "arg"]
245mkEval xs = (sMN 0 "EVAL", DFun (sMN 0 "EVAL") [sMN 0 "arg"]
246− (mkBigCase (sMN 0 "EVAL") 256 (DV (Glob (sMN 0 "arg")))
246+ (mkBigCase (sMN 0 "EVAL") 256 (DV (sMN 0 "arg"))
247 (mapMaybe evalCase xs ++
247 (mapMaybe evalCase xs ++
248− [DDefaultCase (DV (Glob (sMN 0 "arg")))])))
248+ [DDefaultCase (DV (sMN 0 "arg"))])))
249 where
249 where
250 evalCase (n, t, EvalCase x) = Just (x (sMN 0 "arg"))
250 evalCase (n, t, EvalCase x) = Just (x (sMN 0 "arg"))
251 evalCase _ = Nothing
251 evalCase _ = Nothing
@@ -256,7 +256,7 @@ mkApply xs = (sMN 0 "APPLY", DFun (sMN 0 "APPLY") [sMN 0 "fn", sMN 0 "arg"]
256 [] -> DNothing
256 [] -> DNothing
257 cases ->
257 cases ->
258 mkBigCase (sMN 0 "APPLY") 256
258 mkBigCase (sMN 0 "APPLY") 256
259− (DV (Glob (sMN 0 "fn")))
259+ (DV (sMN 0 "fn"))
260 (cases ++
260 (cases ++
261 [DDefaultCase DNothing])))
261 [DDefaultCase DNothing])))
262 where
262 where
@@ -269,14 +269,14 @@ mkApply2 xs = (sMN 0 "APPLY2", DFun (sMN 0 "APPLY2") [sMN 0 "fn", sMN 0 "arg0",
269 [] -> DNothing
269 [] -> DNothing
270 cases ->
270 cases ->
271 mkBigCase (sMN 0 "APPLY") 256
271 mkBigCase (sMN 0 "APPLY") 256
272− (DV (Glob (sMN 0 "fn")))
272+ (DV (sMN 0 "fn"))
273 (cases ++
273 (cases ++
274 [DDefaultCase
274 [DDefaultCase
275 (DApp False (sMN 0 "APPLY")
275 (DApp False (sMN 0 "APPLY")
276 [DApp False (sMN 0 "APPLY")
276 [DApp False (sMN 0 "APPLY")
277− [DV (Glob (sMN 0 "fn")),
277+ [DV (sMN 0 "fn"),
278− DV (Glob (sMN 0 "arg0"))],
278+ DV (sMN 0 "arg0")],
279− DV (Glob (sMN 0 "arg1"))])
279+ DV (sMN 0 "arg1")])
280 ])))
280 ])))
281 where
281 where
282 applyCase (n, t, Apply2Case x) = Just x
282 applyCase (n, t, Apply2Case x) = Just x
@@ -297,8 +297,7 @@ mkUnderCon n missing = sMN missing ("U_" ++ show n)
297
297
298instance Show DExp where
298instance Show DExp where
299 show e = show' [] e where
299 show e = show' [] e where
300− show' env (DV (Loc i)) = "var " ++ env!!i
300+ show' env (DV n) = show n
301− show' env (DV (Glob n)) = "GLOB " ++ show n
302 show' env (DApp _ e args) = show e ++ "(" ++
301 show' env (DApp _ e args) = show e ++ "(" ++
303 showSep ", " (map (show' env) args) ++")"
302 showSep ", " (map (show' env) args) ++")"
304 show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++
303 show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++
src/IRTS/JavaScript/Codegen.hs+5−5
@@ -333,15 +333,15 @@ cgBody rt expr =
333 expr -> cgBody' rt expr
333 expr -> cgBody' rt expr
334
334
335cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
335cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
336−cgBody' rt (LV (Glob n)) =
336+cgBody' rt (LV n) =
337 do
337 do
338 argsFn <- getArgList n
338 argsFn <- getArgList n
339 case argsFn of
339 case argsFn of
340− Just a -> cgBody' rt (LApp False (LV (Glob n)) [])
340+ Just a -> cgBody' rt (LApp False (LV n) [])
341 Nothing -> do
341 Nothing -> do
342 n' <- cgName n
342 n' <- cgName n
343 pure $ ([], addRT rt n')
343 pure $ ([], addRT rt n')
344−cgBody' rt (LApp tailcall (LV (Glob fn)) args) =
344+cgBody' rt (LApp tailcall (LV fn) args) =
345 do
345 do
346 let fname = jsName fn
346 let fname = jsName fn
347 st <- get
347 st <- get
@@ -360,10 +360,10 @@ cgBody' rt (LApp tailcall (LV (Glob fn)) args) =
360 app <- formApp fn argVals
360 app <- formApp fn argVals
361 pure (preDecs, addRT rt app)
361 pure (preDecs, addRT rt app)
362
362
363−cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
363+cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV n) args)
364cgBody' rt (LLazyApp n args) =
364cgBody' rt (LLazyApp n args) =
365 do
365 do
366− (d,v) <- cgBody ReturnBT (LApp False (LV (Glob n)) args)
366+ (d,v) <- cgBody ReturnBT (LApp False (LV n) args)
367 pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)
367 pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)
368cgBody' rt (LForce e) =
368cgBody' rt (LForce e) =
369 do
369 do
src/IRTS/JavaScript/LangTransforms.hs+2−2
@@ -57,7 +57,7 @@ mapMapListKeys f (t:r) x = mapMapListKeys f r $ Map.adjust f t x
57extractGlobs :: Map Name LDecl -> LDecl -> [Name]
57extractGlobs :: Map Name LDecl -> LDecl -> [Name]
58extractGlobs defs (LConstructor _ _ _) = []
58extractGlobs defs (LConstructor _ _ _) = []
59extractGlobs defs (LFun _ _ _ e) =
59extractGlobs defs (LFun _ _ _ e) =
60− let f (LV (Glob x)) = Just x
60+ let f (LV x) = Just x
61 f (LLazyApp x _) = Just x
61 f (LLazyApp x _) = Just x
62 f _ = Nothing
62 f _ = Nothing
63 in [x | Just x <- map f $ universe e, Map.member x defs]
63 in [x | Just x <- map f $ universe e, Map.member x defs]
@@ -102,7 +102,7 @@ globlToCon x =
102 transformBi (f x) x
102 transformBi (f x) x
103 where
103 where
104 f :: Map Name LDecl -> LExp -> LExp
104 f :: Map Name LDecl -> LExp -> LExp
105− f y x@(LV (Glob n)) =
105+ f y x@(LV n) =
106 case Map.lookup n y of
106 case Map.lookup n y of
107 Just (LConstructor _ conId arity) -> LCon Nothing conId n []
107 Just (LConstructor _ conId arity) -> LCon Nothing conId n []
108 _ -> x
108 _ -> x
src/IRTS/Lang.hs+15−16
@@ -28,7 +28,7 @@ data LVar = Loc Int | Glob Name
28
28
29-- ASSUMPTION: All variable bindings have unique names here
29-- ASSUMPTION: All variable bindings have unique names here
30-- Constructors commented as lifted are not present in the LIR provided to the different backends.
30-- Constructors commented as lifted are not present in the LIR provided to the different backends.
31−data LExp = LV LVar
31+data LExp = LV Name
32 | LApp Bool LExp [LExp] -- True = tail call
32 | LApp Bool LExp [LExp] -- True = tail call
33 | LLazyApp Name [LExp] -- True = tail call
33 | LLazyApp Name [LExp] -- True = tail call
34 | LLazyExp LExp -- lifted out before compiling
34 | LLazyExp LExp -- lifted out before compiling
@@ -36,7 +36,7 @@ data LExp = LV LVar
36 | LLet Name LExp LExp -- name just for pretty printing
36 | LLet Name LExp LExp -- name just for pretty printing
37 | LLam [Name] LExp -- lambda, lifted out before compiling
37 | LLam [Name] LExp -- lambda, lifted out before compiling
38 | LProj LExp Int -- projection
38 | LProj LExp Int -- projection
39− | LCon (Maybe LVar) -- Location to reallocate, if available
39+ | LCon (Maybe Name) -- Location to reallocate, if available
40 Int Name [LExp]
40 Int Name [LExp]
41 | LCase CaseType LExp [LAlt]
41 | LCase CaseType LExp [LAlt]
42 | LConst Const
42 | LConst Const
@@ -168,13 +168,13 @@ addFn fn d = do LS n i ds <- get
168
168
169lift :: [Name] -> LExp -> State LiftState LExp
169lift :: [Name] -> LExp -> State LiftState LExp
170lift env (LV v) = return (LV v) -- Lifting happens before these can exist...
170lift env (LV v) = return (LV v) -- Lifting happens before these can exist...
171−lift env (LApp tc (LV (Glob n)) args) = do args' <- mapM (lift env) args
171+lift env (LApp tc (LV n) args) = do args' <- mapM (lift env) args
172− return (LApp tc (LV (Glob n)) args')
172+ return (LApp tc (LV n) args')
173lift env (LApp tc f args) = do f' <- lift env f
173lift env (LApp tc f args) = do f' <- lift env f
174 fn <- getNextName
174 fn <- getNextName
175 addFn fn (LFun [Inline] fn env f')
175 addFn fn (LFun [Inline] fn env f')
176 args' <- mapM (lift env) args
176 args' <- mapM (lift env) args
177− return (LApp tc (LV (Glob fn)) (map (LV . Glob) env ++ args'))
177+ return (LApp tc (LV fn) (map LV env ++ args'))
178lift env (LLazyApp n args) = do args' <- mapM (lift env) args
178lift env (LLazyApp n args) = do args' <- mapM (lift env) args
179 return (LLazyApp n args')
179 return (LLazyApp n args')
180lift env (LLazyExp (LConst c)) = return (LConst c)
180lift env (LLazyExp (LConst c)) = return (LConst c)
@@ -184,7 +184,7 @@ lift env (LLazyExp e) = do e' <- lift env e
184 let usedArgs = nub $ usedIn env e'
184 let usedArgs = nub $ usedIn env e'
185 fn <- getNextName
185 fn <- getNextName
186 addFn fn (LFun [NoInline] fn usedArgs e')
186 addFn fn (LFun [NoInline] fn usedArgs e')
187− return (LLazyApp fn (map (LV . Glob) usedArgs))
187+ return (LLazyApp fn (map LV usedArgs))
188lift env (LForce e) = do e' <- lift env e
188lift env (LForce e) = do e' <- lift env e
189 return (LForce e')
189 return (LForce e')
190lift env (LLet n v e) = do v' <- lift env v
190lift env (LLet n v e) = do v' <- lift env v
@@ -194,7 +194,7 @@ lift env (LLam args e) = do e' <- lift (env ++ args) e
194 let usedArgs = nub $ usedIn env e'
194 let usedArgs = nub $ usedIn env e'
195 fn <- getNextName
195 fn <- getNextName
196 addFn fn (LFun [Inline] fn (usedArgs ++ args) e')
196 addFn fn (LFun [Inline] fn (usedArgs ++ args) e')
197− return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))
197+ return (LApp False (LV fn) (map LV usedArgs))
198lift env (LProj t i) = do t' <- lift env t
198lift env (LProj t i) = do t' <- lift env t
199 return (LProj t' i)
199 return (LProj t' i)
200lift env (LCon loc i n args) = do args' <- mapM (lift env) args
200lift env (LCon loc i n args) = do args' <- mapM (lift env) args
@@ -229,11 +229,11 @@ allocUnique defs (n, LFun opts fn args e)
229 -- Keep track of 'updatable' names in the state, i.e. names whose heap
229 -- Keep track of 'updatable' names in the state, i.e. names whose heap
230 -- entry may be reused, along with the arity which was there
230 -- entry may be reused, along with the arity which was there
231 findUp :: LExp -> State [(Name, Int)] LExp
231 findUp :: LExp -> State [(Name, Int)] LExp
232− findUp (LApp t (LV (Glob n)) as)
232+ findUp (LApp t (LV n) as)
233 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,
233 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,
234 ar == length as
234 ar == length as
235 = findUp (LCon Nothing i n as)
235 = findUp (LCon Nothing i n as)
236− findUp (LV (Glob n))
236+ findUp (LV n)
237 | Just (LConstructor _ i 0) <- lookupCtxtExact n defs
237 | Just (LConstructor _ i 0) <- lookupCtxtExact n defs
238 = return $ LCon Nothing i n [] -- nullary cons are global, no need to update
238 = return $ LCon Nothing i n [] -- nullary cons are global, no need to update
239 findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as
239 findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as
@@ -253,7 +253,7 @@ allocUnique defs (n, LFun opts fn args e)
253 = LForeign t s <$> mapM (\ (t, e) -> do e' <- findUp e
253 = LForeign t s <$> mapM (\ (t, e) -> do e' <- findUp e
254 return (t, e')) es
254 return (t, e')) es
255 findUp (LOp o es) = LOp o <$> mapM findUp es
255 findUp (LOp o es) = LOp o <$> mapM findUp es
256− findUp (LCase Updatable e@(LV (Glob n)) as)
256+ findUp (LCase Updatable e@(LV n) as)
257 = LCase Updatable e <$> mapM (doUpAlt n) as
257 = LCase Updatable e <$> mapM (doUpAlt n) as
258 findUp (LCase t e as)
258 findUp (LCase t e as)
259 = LCase t <$> findUp e <*> mapM findUpAlt as
259 = LCase t <$> findUp e <*> mapM findUpAlt as
@@ -277,7 +277,7 @@ allocUnique defs (n, LFun opts fn args e)
277
277
278 findVar _ [] i = return Nothing
278 findVar _ [] i = return Nothing
279 findVar acc ((n, l) : ns) i | l == i = do put (reverse acc ++ ns)
279 findVar acc ((n, l) : ns) i | l == i = do put (reverse acc ++ ns)
280− return (Just (Glob n))
280+ return (Just n)
281 findVar acc (n : ns) i = findVar (n : acc) ns i
281 findVar acc (n : ns) i = findVar (n : acc) ns i
282
282
283
283
@@ -287,7 +287,7 @@ usedArg env n | n `elem` env = [n]
287 | otherwise = []
287 | otherwise = []
288
288
289usedIn :: [Name] -> LExp -> [Name]
289usedIn :: [Name] -> LExp -> [Name]
290−usedIn env (LV (Glob n)) = usedArg env n
290+usedIn env (LV n) = usedArg env n
291usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
291usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
292usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
292usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
293usedIn env (LLazyExp e) = usedIn env e
293usedIn env (LLazyExp e) = usedIn env e
@@ -297,7 +297,7 @@ usedIn env (LLam ns e) = usedIn (env \\ ns) e
297usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in
297usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in
298 case v of
298 case v of
299 Nothing -> rest
299 Nothing -> rest
300− Just (Glob n) -> usedArg env n ++ rest
300+ Just n -> usedArg env n ++ rest
301usedIn env (LProj t i) = usedIn env t
301usedIn env (LProj t i) = usedIn env t
302usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts
302usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts
303 where usedInA env (LConCase i n ns e) = usedIn env e
303 where usedInA env (LConCase i n ns e) = usedIn env e
@@ -308,7 +308,7 @@ usedIn env (LOp f args) = concatMap (usedIn env) args
308usedIn env _ = []
308usedIn env _ = []
309
309
310lsubst :: Name -> LExp -> LExp -> LExp
310lsubst :: Name -> LExp -> LExp -> LExp
311−lsubst n new (LV (Glob x)) | n == x = new
311+lsubst n new (LV x) | n == x = new
312lsubst n new (LApp t e args) = let e' = lsubst n new e
312lsubst n new (LApp t e args) = let e' = lsubst n new e
313 args' = map (lsubst n new) args in
313 args' = map (lsubst n new) args in
314 LApp t e' args'
314 LApp t e' args'
@@ -333,8 +333,7 @@ lsubst n new tm = tm
333
333
334instance Show LExp where
334instance Show LExp where
335 show e = show' [] "" e where
335 show e = show' [] "" e where
336− show' env ind (LV (Loc i)) = env!!i
336+ show' env ind (LV n) = show n
337− show' env ind (LV (Glob n)) = show n
338
337
339 show' env ind (LLazyApp e args)
338 show' env ind (LLazyApp e args)
340 = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"
339 = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"
src/IRTS/LangOpts.hs+9−9
@@ -35,14 +35,14 @@ nextN = do i <- get
35doInline :: LDefs -> LDecl -> LDecl
35doInline :: LDefs -> LDecl -> LDecl
36doInline defs d@(LConstructor _ _ _) = d
36doInline defs d@(LConstructor _ _ _) = d
37doInline defs (LFun opts topn args exp)
37doInline defs (LFun opts topn args exp)
38− = let res = evalState (inlineWith [topn] (map (\n -> (n, LV (Glob n))) args) exp) 0 in
38+ = let res = evalState (inlineWith [topn] (map (\n -> (n, LV n)) args) exp) 0 in
39 LFun opts topn args res
39 LFun opts topn args res
40 where
40 where
41 inlineWith :: [Name] -> [(Name, LExp)] -> LExp -> State Int LExp
41 inlineWith :: [Name] -> [(Name, LExp)] -> LExp -> State Int LExp
42− inlineWith done env var@(LV (Glob n))
42+ inlineWith done env var@(LV n)
43− = case lookup n env of
43+ = case lookup n env of
44− Just t -> return t
44+ Just t -> return t
45− Nothing -> return var
45+ Nothing -> return var
46 inlineWith done env (LLazyApp n es) = LLazyApp n <$> (mapM (inlineWith done env) es)
46 inlineWith done env (LLazyApp n es) = LLazyApp n <$> (mapM (inlineWith done env) es)
47 inlineWith done env (LForce e) = LForce <$> inlineWith done env e
47 inlineWith done env (LForce e) = LForce <$> inlineWith done env e
48 inlineWith done env (LLazyExp e) = LLazyExp <$> inlineWith done env e
48 inlineWith done env (LLazyExp e) = LLazyExp <$> inlineWith done env e
@@ -51,12 +51,12 @@ doInline defs (LFun opts topn args exp)
51 inlineWith done env (LLet n val sc)
51 inlineWith done env (LLet n val sc)
52 = do n' <- nextN
52 = do n' <- nextN
53 LLet n' <$> inlineWith done env val <*>
53 LLet n' <$> inlineWith done env val <*>
54− inlineWith done ((n, LV (Glob n')) : env) sc
54+ inlineWith done ((n, LV n') : env) sc
55 inlineWith done env (LLam args sc)
55 inlineWith done env (LLam args sc)
56 = do ns' <- mapM (\n -> do n' <- nextN
56 = do ns' <- mapM (\n -> do n' <- nextN
57 return (n, n')) args
57 return (n, n')) args
58 LLam (map snd ns') <$>
58 LLam (map snd ns') <$>
59− inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) sc
59+ inlineWith done (map (\ (n,n') -> (n, LV n')) ns' ++ env) sc
60 inlineWith done env (LProj exp i) = LProj <$> inlineWith done env exp <*> return i
60 inlineWith done env (LProj exp i) = LProj <$> inlineWith done env exp <*> return i
61 inlineWith done env (LCon loc i n es)
61 inlineWith done env (LCon loc i n es)
62 = LCon loc i n <$> mapM (inlineWith done env) es
62 = LCon loc i n <$> mapM (inlineWith done env) es
@@ -64,7 +64,7 @@ doInline defs (LFun opts topn args exp)
64 = LCase ty <$> inlineWith done env e <*> mapM (inlineWithAlt done env) alts
64 = LCase ty <$> inlineWith done env e <*> mapM (inlineWithAlt done env) alts
65 inlineWith done env (LOp f es) = LOp f <$> mapM (inlineWith done env) es
65 inlineWith done env (LOp f es) = LOp f <$> mapM (inlineWith done env) es
66 -- the interesting case!
66 -- the interesting case!
67− inlineWith done env (LApp t (LV (Glob n)) es)
67+ inlineWith done env (LApp t (LV n) es)
68 | n `notElem` done,
68 | n `notElem` done,
69 [LFun opts _ args body] <- lookupCtxt n defs,
69 [LFun opts _ args body] <- lookupCtxt n defs,
70 Inline `elem` opts,
70 Inline `elem` opts,
@@ -82,6 +82,6 @@ doInline defs (LFun opts topn args exp)
82 = do ns' <- mapM (\n -> do n' <- nextN
82 = do ns' <- mapM (\n -> do n' <- nextN
83 return (n, n')) es
83 return (n, n')) es
84 LConCase i n (map snd ns') <$>
84 LConCase i n (map snd ns') <$>
85− inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) rhs
85+ inlineWith done (map (\ (n,n') -> (n, LV n')) ns' ++ env) rhs
86 inlineWithAlt done env (LConstCase c e) = LConstCase c <$> inlineWith done env e
86 inlineWithAlt done env (LConstCase c e) = LConstCase c <$> inlineWith done env e
87 inlineWithAlt done env (LDefaultCase e) = LDefaultCase <$> inlineWith done env e
87 inlineWithAlt done env (LDefaultCase e) = LDefaultCase <$> inlineWith done env e
src/IRTS/Simplified.hs+3−5
@@ -53,8 +53,7 @@ ldefs = do (l, h) <- get
53-- The boolean parameter indicates whether the expression is at tail
53-- The boolean parameter indicates whether the expression is at tail
54-- call position.
54-- call position.
55simplify :: Bool -> DExp -> State (DDefs, Int) SExp
55simplify :: Bool -> DExp -> State (DDefs, Int) SExp
56−simplify tl (DV (Loc i)) = return (SV (Loc i))
56+simplify tl (DV x)
57−simplify tl (DV (Glob x))
58 = do ctxt <- ldefs
57 = do ctxt <- ldefs
59 case lookupCtxtExact x ctxt of
58 case lookupCtxtExact x ctxt of
60 Just (DConstructor _ t 0) -> return $ SCon Nothing t x []
59 Just (DConstructor _ t 0) -> return $ SCon Nothing t x []
@@ -68,7 +67,7 @@ simplify tl (DLet n v e) = do v' <- simplify False v
68 return (SLet (Glob n) v' e')
67 return (SLet (Glob n) v' e')
69simplify tl (DUpdate n e) = do e' <- simplify False e
68simplify tl (DUpdate n e) = do e' <- simplify False e
70 return (SUpdate (Glob n) e')
69 return (SUpdate (Glob n) e')
71−simplify tl (DC loc i n args) = bindExprs args (SCon loc i n)
70+simplify tl (DC loc i n args) = bindExprs args (SCon (Glob <$> loc) i n)
72simplify tl (DProj t i) = bindExpr t (\var -> SProj var i)
71simplify tl (DProj t i) = bindExpr t (\var -> SProj var i)
73simplify tl (DCase up e alts)
72simplify tl (DCase up e alts)
74 = do alts' <- mapM (sAlt tl) alts
73 = do alts' <- mapM (sAlt tl) alts
@@ -97,12 +96,11 @@ bindExpr :: DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp
97bindExpr e f = bindExprM e (return . f)
96bindExpr e f = bindExprM e (return . f)
98
97
99bindExprM :: DExp -> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
98bindExprM :: DExp -> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
100−bindExprM (DV (Glob x)) f
99+bindExprM (DV x) f
101 = do ctxt <- ldefs
100 = do ctxt <- ldefs
102 case lookupCtxtExact x ctxt of
101 case lookupCtxtExact x ctxt of
103 Just (DConstructor _ t 0) -> bindExprM (DC Nothing t x []) f
102 Just (DConstructor _ t 0) -> bindExprM (DC Nothing t x []) f
104 _ -> f (Glob x)
103 _ -> f (Glob x)
105−bindExprM (DV var) f = f var
106bindExprM e f =
104bindExprM e f =
107 do e' <- simplify False e
105 do e' <- simplify False e
108 var <- freshVar
106 var <- freshVar