git.iko.soy/Idris-dev
on master help sign in
Lambda lifting in FOVM
29ba32eEdwin Brady
iif/testmap.iif+2−1
compare with master
unifiedsplit
@@ -15,4 +15,5 @@ fun dumpList(xs) = case xs of {
15
15
16fun double(x) = x + x
16fun double(x) = x + x
17
17
18+fun main() = let mult = 2 in
18−fun main() = %WriteString(dumpList(map(twice(double), Cons(4, Cons(6, Nil)))))
19+ %WriteString(dumpList(map(twice(\ x => x*mult), Cons(4, Cons(6, Nil)))))
src/IRTS/LParser.hs+5−1
@@ -47,7 +47,7 @@ lchar = lexeme.char
47
47
48fovm :: FilePath -> IO ()
48fovm :: FilePath -> IO ()
49fovm f = do defs <- parseFOVM f
49fovm f = do defs <- parseFOVM f
50− let (nexttag, tagged) = addTags 0 defs
50+ let (nexttag, tagged) = addTags 0 (liftAll defs)
51 let ctxtIn = addAlist tagged emptyContext
51 let ctxtIn = addAlist tagged emptyContext
52 let defuns = defunctionalise nexttag ctxtIn
52 let defuns = defunctionalise nexttag ctxtIn
53-- print defuns
53-- print defuns
@@ -131,6 +131,10 @@ pLExp' = try (do lchar '%'; pCast)
131 <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
131 <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
132 reserved "in"; e <- pLExp
132 reserved "in"; e <- pLExp
133 return (LLet x v e)
133 return (LLet x v e)
134+ <|> do lchar '\\'; xs <- sepBy (iName []) (lchar ',')
135+ symbol "=>"
136+ e <- pLExp
137+ return (LLam xs e)
134 <|> do reserved "foreign"; l <- pLang; t <- pType
138 <|> do reserved "foreign"; l <- pLang; t <- pType
135 fname <- strlit
139 fname <- strlit
136 lchar '('
140 lchar '('
src/IRTS/Lang.hs+67
@@ -1,6 +1,7 @@
1module IRTS.Lang where
1module IRTS.Lang where
2
2
3import Core.TT
3import Core.TT
4+import Control.Monad.State hiding(lift)
4
5
5data LVar = Loc Int | Glob Name
6data LVar = Loc Int | Glob Name
6 deriving Show
7 deriving Show
@@ -9,6 +10,7 @@ data LExp = LV LVar
9 | LApp Bool Name [LExp] -- True = tail call
10 | LApp Bool Name [LExp] -- True = tail call
10 | LLazyApp Name [LExp] -- True = tail call
11 | LLazyApp Name [LExp] -- True = tail call
11 | LLet Name LExp LExp -- name just for pretty printing
12 | LLet Name LExp LExp -- name just for pretty printing
13+ | LLam [Name] LExp -- lambda, lifted out before compiling
12 | LCon Int Name [LExp]
14 | LCon Int Name [LExp]
13 | LCase LExp [LAlt]
15 | LCase LExp [LAlt]
14 | LConst Const
16 | LConst Const
@@ -49,3 +51,68 @@ addTags i ds = tag i ds []
49 tag i (x : as) acc = tag i as (x : acc)
51 tag i (x : as) acc = tag i as (x : acc)
50 tag i [] acc = (i, reverse acc)
52 tag i [] acc = (i, reverse acc)
51
53
54+data LiftState = LS Name Int [(Name, LDecl)]
55+
56+lname (NS n x) i = NS (lname n i) x
57+lname (UN n) i = MN i n
58+lname x i = MN i (show x)
59+
60+liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
61+liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
62+
63+lambdaLift :: Name -> LDecl -> [(Name, LDecl)]
64+lambdaLift n (LFun _ args e)
65+ = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in
66+ (n, LFun n args e') : decls
67+lambdaLift n x = [(n, x)]
68+
69+getNextName :: State LiftState Name
70+getNextName = do LS n i ds <- get
71+ put (LS n (i + 1) ds)
72+ return (lname n i)
73+
74+addFn :: Name -> LDecl -> State LiftState ()
75+addFn fn d = do LS n i ds <- get
76+ put (LS n i ((fn, d) : ds))
77+
78+lift :: [Name] -> LExp -> State LiftState LExp
79+lift env (LV v) = return (LV v)
80+lift env (LApp tc n args) = do args' <- mapM (lift env) args
81+ return (LApp tc n args')
82+lift env (LLazyApp n args) = do args' <- mapM (lift env) args
83+ return (LLazyApp n args')
84+lift env (LLet n v e) = do v' <- lift env v
85+ e' <- lift (env ++ [n]) e
86+ return (LLet n v' e')
87+lift env (LLam args e) = do e' <- lift (env ++ args) e
88+ fn <- getNextName
89+ addFn fn (LFun fn (env ++ args) e')
90+ return (LApp False fn (map (LV . Glob) env))
91+lift env (LCon i n args) = do args' <- mapM (lift env) args
92+ return (LCon i n args')
93+lift env (LCase e alts) = do alts' <- mapM liftA alts
94+ e' <- lift env e
95+ return (LCase e' alts')
96+ where
97+ liftA (LConCase i n args e) = do e' <- lift (env ++ args) e
98+ return (LConCase i n args e')
99+ liftA (LConstCase c e) = do e' <- lift env e
100+ return (LConstCase c e')
101+ liftA (LDefaultCase e) = do e' <- lift env e
102+ return (LDefaultCase e')
103+lift env (LConst c) = return (LConst c)
104+lift env (LForeign l t s args) = do args' <- mapM (liftF env) args
105+ return (LForeign l t s args')
106+ where
107+ liftF env (t, e) = do e' <- lift env e
108+ return (t, e')
109+lift env (LOp f args) = do args' <- mapM (lift env) args
110+ return (LOp f args')
111+
112+
113+
114+
115+
116+
117+
118+