e956eca · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Don't lambda lift unused arguments

commite956eca179ac0b2a2b1ee1607357915fe8142eb6 authorEdwin Brady <eb@cs.st-andrews.ac.uk> dateFri 14 Sep 2012, 09:26 (14 years ago) parent371bd9a

5 files changed+58−11

compare with master

unifiedsplit

idris.cabal−1 rts/idris_main.c+1−1 src/IRTS/Compiler.hs+1−1 src/IRTS/Lang.hs+56−7 src/Idris/AbsSyntax.hs−1

idris.cabal−1

@@ -70,7 +70,6 @@ Executable idris

7070

7171 Util.Pretty,

7272

73− RTS.Bytecode, RTS.SC, RTS.PreC, RTS.CodegenC,

7473 IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,

7574 IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Compiler,

7675

rts/idris_main.c+1−1

@@ -1,5 +1,5 @@

11int main(int argc, char* argv[]) {

2− VM* vm = init_vm(4096000, 512000); // 1024000);

2+ VM* vm = init_vm(4096000, 2048000); // 1024000);

33 _idris__123_runMain0_125_(vm, NULL);

44 //_idris_main(vm, NULL);

55#ifdef IDRIS_TRACE

src/IRTS/Compiler.hs+1−1

@@ -32,7 +32,7 @@ compileC f tm = do checkMVs

3232 let (nexttag, tagged) = addTags 0 (liftAll defs)

3333 let ctxtIn = addAlist tagged emptyContext

3434 let defuns = defunctionalise nexttag ctxtIn

35−-- iputStrLn $ showSep "\n" (map show (toAlist defuns))

35+ -- iputStrLn $ showSep "\n" (map show (toAlist defuns))

3636 let checked = checkDefs defuns (toAlist defuns)

3737 case checked of

3838 OK c -> do -- iputStrLn $ showSep "\n" (map show c)

src/IRTS/Lang.hs+56−7

@@ -21,7 +21,7 @@ data LExp = LV LVar

2121 | LForeign FLang FType String [(FType, LExp)]

2222 | LOp PrimFn [LExp]

2323 | LError String

24− deriving (Show, Eq)

24+ deriving Eq

2525

2626data PrimFn = LPlus | LMinus | LTimes | LDiv | LEq | LLt | LLe | LGt | LGe

@@ -90,7 +90,7 @@ addFn fn d = do LS n i ds <- get

9090 put (LS n i ((fn, d) : ds))

9191

9292lift :: [Name] -> LExp -> State LiftState LExp

93−lift env (LV v) = return (LV v)

93+lift env (LV v) = return (LV v) -- Lifting happens before these can exist...

9494lift env (LApp tc (LV (Glob n)) args) = do args' <- mapM (lift env) args

9595 return (LApp tc (LV (Glob n)) args')

9696lift env (LApp tc f args) = do f' <- lift env f

@@ -102,18 +102,20 @@ lift env (LLazyApp n args) = do args' <- mapM (lift env) args

102102 return (LLazyApp n args')

103103lift env (LLazyExp (LConst c)) = return (LConst c)

104104lift env (LLazyExp e) = do e' <- lift env e

105+ let usedArgs = nub $ usedIn env e'

105106 fn <- getNextName

106− addFn fn (LFun fn env e')

107− return (LLazyApp fn (map (LV . Glob) env))

107+ addFn fn (LFun fn usedArgs e')

108+ return (LLazyApp fn (map (LV . Glob) usedArgs))

108109lift env (LForce e) = do e' <- lift env e

109110 return (LForce e')

110111lift env (LLet n v e) = do v' <- lift env v

111112 e' <- lift (env ++ [n]) e

112113 return (LLet n v' e')

113114lift env (LLam args e) = do e' <- lift (env ++ args) e

115+ let usedArgs = nub $ usedIn env e'

114116 fn <- getNextName

115− addFn fn (LFun fn (env ++ args) e')

116− return (LApp False (LV (Glob fn)) (map (LV . Glob) env))

117+ addFn fn (LFun fn (usedArgs ++ args) e')

118+ return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))

117119lift env (LCon i n args) = do args' <- mapM (lift env) args

118120 return (LCon i n args')

119121lift env (LCase e alts) = do alts' <- mapM liftA alts

@@ -137,7 +139,54 @@ lift env (LOp f args) = do args' <- mapM (lift env) args

137139lift env (LError str) = return $ LError str

138140

139141

140−

142+-- Return variables in list which are used in the expression

143+

144+usedArg env n | n `elem` env = [n]

145+ | otherwise = []

146+

147+usedIn :: [Name] -> LExp -> [Name]

148+usedIn env (LV (Glob n)) = usedArg env n

149+usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args

150+usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n

151+usedIn env (LLazyExp e) = usedIn env e

152+usedIn env (LForce e) = usedIn env e

153+usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e

154+usedIn env (LLam ns e) = usedIn (env \\ ns) e

155+usedIn env (LCon i n args) = concatMap (usedIn env) args

156+usedIn env (LCase e alts) = concatMap (usedInA env) alts

157+ where usedInA env (LConCase i n ns e) = usedIn env e

158+ usedInA env (LConstCase c e) = usedIn env e

159+ usedInA env (LDefaultCase e) = usedIn env e

160+usedIn env (LForeign _ _ _ args) = concatMap (usedIn env) (map snd args)

161+usedIn env (LOp f args) = concatMap (usedIn env) args

162+usedIn env _ = []

163+

164+instance Show LExp where

165+ show e = show' [] e where

166+ show' env (LV (Loc i)) = env!!i

167+ show' env (LV (Glob n)) = show n

168+ show' env (LApp _ e args) = show' env e ++ "(" ++

169+ showSep ", " (map (show' env) args) ++")"

170+ show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"

171+ show' env (LForce e) = "%force(" ++ show' env e ++ ")"

172+ show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++

173+ show' (env ++ [show n]) e

174+ show' env (LLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++

175+ show' (env ++ (map show args)) e

176+ show' env (LCon i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"

177+ show' env (LCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++

178+ showSep "\n\t| " (map (showAlt env) alts)

179+ show' env (LConst c) = show c

180+ show' env (LForeign lang ty n args)

181+ = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"

182+ show' env (LOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"

183+ show' env (LError str) = "error " ++ show str

184+

185+ showAlt env (LConCase _ n args e)

186+ = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "

187+ ++ show' env e

188+ showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e

189+ showAlt env (LDefaultCase e) = "_ => " ++ show' env e

141190

142191

143192

src/Idris/AbsSyntax.hs−1

@@ -8,7 +8,6 @@ import Core.Evaluate

88import Core.Elaborate hiding (Tactic(..))

99import Core.Typecheck

1010import Idris.AbsSyntaxTree

11−import RTS.SC

1211

1312import Paths_idris

1413