git.iko.soy/Idris-dev
on master help sign in
Make EVAL and APPLY smaller

(Also shortcut inlining for boolElim, until we make it more general, which is the source of a lot of the cases in EVAL in practice)

commitfb3c24cc683e518a79fb2614e5ab0a6e21d5eea2 authorEdwin Brady <ecb10@st-andrews.ac.uk> dateThu 13 Feb 2014, 22:48 (13 years ago) parent0043db9
2 files changed+33−9
compare with master
unifiedsplit
src/IRTS/Compiler.hs+10−3 src/IRTS/Defunctionalise.hs+23−6
src/IRTS/Compiler.hs+10−3
@@ -220,9 +220,16 @@ instance ToIR (TT Name) where
220220 tm == txt "trace_malloc"
221221 = do t' <- ir' env t
222222 return t' -- TODO
223−-- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm
224−-- = do k' <- ir' env k
225−-- return (LOp LBPlus [k', LConst (BI 1)])
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"
228+ = do x' <- ir' env x
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'])
226233 | (P (DCon t a) n _, args) <- unApply tm
227234 = irCon env t a n args
228235 | (P (TCon t a) n _, args) <- unApply tm
src/IRTS/Defunctionalise.hs+23−6
@@ -1,3 +1,5 @@
1+{-# LANGUAGE PatternGuards #-}
2+
13module IRTS.Defunctionalise(module IRTS.Defunctionalise,
24 module IRTS.Lang) where
35
@@ -42,8 +44,9 @@ defunctionalise nexttag defs
4244 = let all = toAlist defs
4345 -- sort newcons so that EVAL and APPLY cons get sequential tags
4446 (allD, (enames, anames)) = runState (mapM (addApps defs) all) ([], [])
47+ anames' = sort anames
4548 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)
4750 eval = mkEval newecons
4851 app = mkApply newacons
4952 condecls = declare nexttag (newecons ++ newacons) in
@@ -68,14 +71,14 @@ getFn xs = mapMaybe fnData xs
6871-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
6972-- 8 Add explicit EVAL to case, primitives, and foreign calls
7073
71−addApps :: LDefs -> (Name, LDecl) -> State ([Name], [Name]) (Name, DDecl)
74+addApps :: LDefs -> (Name, LDecl) -> State ([Name], [(Name, Int)]) (Name, DDecl)
7275addApps defs o@(n, LConstructor _ t a)
7376 = return (n, DConstructor n t a)
7477addApps defs (n, LFun _ _ args e)
7578 = do e' <- aa args e
7679 return (n, DFun n args e')
7780 where
78− aa :: [Name] -> LExp -> State ([Name], [Name]) DExp
81+ aa :: [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
7982 aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)
8083 | otherwise = aa env (LApp False (LV (Glob n)) [])
8184 aa env (LApp tc (LV (Glob n)) args)
@@ -125,7 +128,8 @@ addApps defs (n, LFun _ _ args e)
125128 = return $ DApp tc n args
126129 | length args < ar
127130 = do (ens, ans) <- get
128− put (ens, nub (n : ans))
131+ let alln = map (\x -> (n, x)) [length args .. ar]
132+ put (ens, nub (alln ++ ans))
129133 return $ DApp tc (mkUnderCon n (ar - length args)) args
130134 | length args > ar
131135 = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)
@@ -137,7 +141,8 @@ addApps defs (n, LFun _ _ args e)
137141 return $ DApp False (mkFnCon n) args
138142 | length args < ar
139143 = do (ens, ans) <- get
140− put (ens, nub (n : ans))
144+ let alln = map (\x -> (n, x)) [length args .. ar]
145+ put (ens, nub (alln ++ ans))
141146 return $ DApp False (mkUnderCon n (ar - length args)) args
142147 | length args > ar
143148 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)
@@ -187,7 +192,19 @@ toCons ns (n, i)
187192 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
188193 (dupdate tlarg
189194 (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
191208 | otherwise = []
192209 where dupdate tlarg x = x
193210