fb3c24c · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Make EVAL and APPLY smaller

fb3c24cEdwin Brady13 years ago

src/IRTS/Compiler.hs+10−3

compare with master

unifiedsplit

@@ -220,9 +220,16 @@ instance ToIR (TT Name) where

220 tm == txt "trace_malloc"

221 = do t' <- ir' env t

222 return t' -- TODO

223−-- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm

223+ -- This case is here until we get more general inlining. It's just

224+ -- a really common case, and the laziness hurts...

225+ | (P _ (NS (UN be) [b,p]) _, [_,x,(App (P _ (UN d) _) t),

226+ (App (P _ (UN d') _) e)]) <- unApply tm,

227+ be == txt "boolElim" && d == txt "Delay" && d' == txt "Delay"

224−-- = do k' <- ir' env k

228+ = do x' <- ir' env x

225−-- return (LOp LBPlus [k', LConst (BI 1)])

229+ t' <- ir' env t

230+ e' <- ir' env e

231+ return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e',

232+ LConCase 1 (sNS (sUN "True") ["Bool","Prelude"]) [] t'])

226 | (P (DCon t a) n _, args) <- unApply tm

233 | (P (DCon t a) n _, args) <- unApply tm

227 = irCon env t a n args

234 = irCon env t a n args

228 | (P (TCon t a) n _, args) <- unApply tm

235 | (P (TCon t a) n _, args) <- unApply tm

src/IRTS/Defunctionalise.hs+23−6

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

1+{-# LANGUAGE PatternGuards #-}

1module IRTS.Defunctionalise(module IRTS.Defunctionalise,

3module IRTS.Defunctionalise(module IRTS.Defunctionalise,

2 module IRTS.Lang) where

4 module IRTS.Lang) where

@@ -42,8 +44,9 @@ defunctionalise nexttag defs

42 = let all = toAlist defs

44 = let all = toAlist defs

43 -- sort newcons so that EVAL and APPLY cons get sequential tags

45 -- sort newcons so that EVAL and APPLY cons get sequential tags

44 (allD, (enames, anames)) = runState (mapM (addApps defs) all) ([], [])

46 (allD, (enames, anames)) = runState (mapM (addApps defs) all) ([], [])

47+ anames' = sort anames

45 newecons = sortBy conord $ concatMap (toCons enames) (getFn all)

48 newecons = sortBy conord $ concatMap (toCons enames) (getFn all)

46− newacons = sortBy conord $ concatMap (toCons anames) (getFn all)

49+ newacons = sortBy conord $ concatMap (toConsA anames') (getFn all)

47 eval = mkEval newecons

50 eval = mkEval newecons

48 app = mkApply newacons

51 app = mkApply newacons

49 condecls = declare nexttag (newecons ++ newacons) in

52 condecls = declare nexttag (newecons ++ newacons) in

@@ -68,14 +71,14 @@ getFn xs = mapMaybe fnData xs

68-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY

71-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY

69-- 8 Add explicit EVAL to case, primitives, and foreign calls

72-- 8 Add explicit EVAL to case, primitives, and foreign calls

71−addApps :: LDefs -> (Name, LDecl) -> State ([Name], [Name]) (Name, DDecl)

74+addApps :: LDefs -> (Name, LDecl) -> State ([Name], [(Name, Int)]) (Name, DDecl)

72addApps defs o@(n, LConstructor _ t a)

75addApps defs o@(n, LConstructor _ t a)

73 = return (n, DConstructor n t a)

76 = return (n, DConstructor n t a)

74addApps defs (n, LFun _ _ args e)

77addApps defs (n, LFun _ _ args e)

75 = do e' <- aa args e

78 = do e' <- aa args e

76 return (n, DFun n args e')

79 return (n, DFun n args e')

77 where

80 where

78− aa :: [Name] -> LExp -> State ([Name], [Name]) DExp

81+ aa :: [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp

79 aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)

82 aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)

80 | otherwise = aa env (LApp False (LV (Glob n)) [])

83 | otherwise = aa env (LApp False (LV (Glob n)) [])

81 aa env (LApp tc (LV (Glob n)) args)

84 aa env (LApp tc (LV (Glob n)) args)

@@ -125,7 +128,8 @@ addApps defs (n, LFun _ _ args e)

125 = return $ DApp tc n args

128 = return $ DApp tc n args

126 | length args < ar

129 | length args < ar

127 = do (ens, ans) <- get

130 = do (ens, ans) <- get

131+ let alln = map (\x -> (n, x)) [length args .. ar]

128− put (ens, nub (n : ans))

132+ put (ens, nub (alln ++ ans))

129 return $ DApp tc (mkUnderCon n (ar - length args)) args

133 return $ DApp tc (mkUnderCon n (ar - length args)) args

130 | length args > ar

134 | length args > ar

131 = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)

135 = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)

@@ -137,7 +141,8 @@ addApps defs (n, LFun _ _ args e)

137 return $ DApp False (mkFnCon n) args

141 return $ DApp False (mkFnCon n) args

138 | length args < ar

142 | length args < ar

139 = do (ens, ans) <- get

143 = do (ens, ans) <- get

144+ let alln = map (\x -> (n, x)) [length args .. ar]

140− put (ens, nub (n : ans))

145+ put (ens, nub (alln ++ ans))

141 return $ DApp False (mkUnderCon n (ar - length args)) args

146 return $ DApp False (mkUnderCon n (ar - length args)) args

142 | length args > ar

147 | length args > ar

143 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)

148 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)

@@ -187,7 +192,19 @@ toCons ns (n, i)

187 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))

192 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))

188 (dupdate tlarg

193 (dupdate tlarg

189 (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))

194 (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))

190− : mkApplyCase n 0 i

195+ : [] -- mkApplyCase n 0 i

196+ | otherwise = []

197+ where dupdate tlarg x = x

198+

199+toConsA :: [(Name, Int)] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]

200+toConsA ns (n, i)

201+ | Just ar <- lookup n ns

202+-- = (mkFnCon n, i,

203+-- EvalCase (\tlarg ->

204+-- (DConCase (-1) (mkFnCon n) (take i (genArgs 0))

205+-- (dupdate tlarg

206+-- (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))

207+ = mkApplyCase n ar i

191 | otherwise = []

208 | otherwise = []

192 where dupdate tlarg x = x

209 where dupdate tlarg x = x

193

210