e956eca · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Don't lambda lift unused arguments

e956ecaEdwin Brady14 years ago

idris.cabal−1

compare with master

unifiedsplit

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

71 Util.Pretty,

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

74 IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,

73 IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,

75 IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Compiler,

74 IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Compiler,

rts/idris_main.c+1−1

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

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

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

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

3 _idris__123_runMain0_125_(vm, NULL);

4 //_idris_main(vm, NULL);

5#ifdef IDRIS_TRACE

src/IRTS/Compiler.hs+1−1

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

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

33 let ctxtIn = addAlist tagged emptyContext

34 let defuns = defunctionalise nexttag ctxtIn

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

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

36 let checked = checkDefs defuns (toAlist defuns)

37 case checked of

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

src/IRTS/Lang.hs+56−7

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

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

22 | LOp PrimFn [LExp]

23 | LError String

24− deriving (Show, Eq)

24+ deriving Eq

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

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

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

92lift :: [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...

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

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

96lift 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

102 return (LLazyApp n args')

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

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

105+ let usedArgs = nub $ usedIn env e'

105 fn <- getNextName

106 fn <- getNextName

106− addFn fn (LFun fn env e')

107+ addFn fn (LFun fn usedArgs e')

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

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

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

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

109 return (LForce e')

110 return (LForce e')

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

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

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

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

112 return (LLet n v' e')

113 return (LLet n v' e')

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

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

115+ let usedArgs = nub $ usedIn env e'

114 fn <- getNextName

116 fn <- getNextName

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

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

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

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

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

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

118 return (LCon i n args')

120 return (LCon i n args')

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

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

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

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

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

138

140

139

141

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

141

190

142

191

143

192

src/Idris/AbsSyntax.hs−1

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

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

9import Core.Typecheck

10import Idris.AbsSyntaxTree

11−import RTS.SC

13import Paths_idris

12import Paths_idris