8353de5 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Find updatable constructors after destructive case

8353de5Edwin Brady12 years ago

idris.cabal+1

compare with master

unifiedsplit

@@ -633,6 +633,7 @@ Library

633 , IRTS.Java.Mangling

634 , IRTS.Java.Pom

635 , IRTS.Lang

636+ , IRTS.LangOpts

636 , IRTS.Simplified

637 , IRTS.Simplified

637 , IRTS.System

638 , IRTS.System

638

639

rts/idris_gc.c+3

@@ -147,4 +147,7 @@ void idris_gcInfo(VM* vm, int doGC) {

147 printf("Final heap use %d\n", (int)(vm->heap.next - vm->heap.heap));

148 if (doGC) { idris_gc(vm); }

149 printf("Final heap use after GC %d\n", (int)(vm->heap.next - vm->heap.heap));

150+

151+ printf("Total allocations %d\n", vm->stats.allocations);

152+ printf("Number of collections %d\n", vm->stats.collections);

150}

153}

src/IRTS/Compiler.hs+4−1

@@ -3,6 +3,7 @@

3module IRTS.Compiler(compile, generate) where

5import IRTS.Lang

6+import IRTS.LangOpts

6import IRTS.Defunctionalise

7import IRTS.Defunctionalise

7import IRTS.Simplified

8import IRTS.Simplified

8import IRTS.CodegenCommon

9import IRTS.CodegenCommon

@@ -67,8 +68,10 @@ compile codegen f tm

67 -- iputStrLn $ showSep "\n" (map show defs)

68 -- iputStrLn $ showSep "\n" (map show defs)

68 -- Inlined top level LDecl made here

69 -- Inlined top level LDecl made here

69 let defsInlined = inlineAll defs

70 let defsInlined = inlineAll defs

71+ let defsUniq = map (allocUnique (addAlist defsInlined emptyContext))

72+ defsInlined

71− let (nexttag, tagged) = addTags 65536 (liftAll defsInlined)

74+ let (nexttag, tagged) = addTags 65536 (liftAll defsUniq)

72 let ctxtIn = addAlist tagged emptyContext

75 let ctxtIn = addAlist tagged emptyContext

74 iLOG "Defunctionalising"

77 iLOG "Defunctionalising"

src/IRTS/Defunctionalise.hs+1−1

@@ -263,7 +263,7 @@ instance Show DExp where

263 show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++

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

265 show' env (DUpdate n e) = "!update " ++ show n ++ "(" ++ show' env e ++ ")"

266− show' env (DC loc i n args) = atloc loc ++ show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"

266+ show' env (DC loc i n args) = atloc loc ++ show n ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"

267 where atloc Nothing = ""

268 atloc (Just l) = "@" ++ show (LV l) ++ ":"

269 show' env (DProj t i) = show t ++ "!" ++ show i

src/IRTS/Lang.hs+60−91

@@ -4,8 +4,10 @@ module IRTS.Lang where

5import Control.Monad.State hiding (lift)

6import Control.Applicative hiding (Const)

7import Idris.Core.TT

8import Idris.Core.TT

8import Idris.Core.CaseTree

9import Idris.Core.CaseTree

10+

9import Data.List

11import Data.List

10import Debug.Trace

12import Debug.Trace

@@ -200,98 +202,65 @@ lift env (LOp f args) = do args' <- mapM (lift env) args

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

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

201lift env LNothing = return $ LNothing

203lift env LNothing = return $ LNothing

202

204

203−allocUnique :: LDecl -> LDecl

204−allocUnique x = x

205−

206−inlineAll :: [(Name, LDecl)] -> [(Name, LDecl)]

207−inlineAll lds = let defs = addAlist lds emptyContext in

208− map (\ (n, def) -> (n, doInline defs def)) lds

209−

210−nextN :: State Int Name

211−nextN = do i <- get

212− put (i + 1)

213− return $ sMN i "in"

214−

215−-- Inline inside a declaration. Variables are still Name at this stage.

216−-- Need to preserve uniqueness of variable names in the resulting definition,

217−-- so invent a new name for every variable we encounter

218−doInline :: LDefs -> LDecl -> LDecl

205+allocUnique :: LDefs -> (Name, LDecl) -> (Name, LDecl)

219−doInline defs d@(LConstructor _ _ _) = d

206+allocUnique defs p@(n, LConstructor _ _ _) = p

220−doInline defs (LFun opts topn args exp)

207+allocUnique defs (n, LFun opts fn args e)

221− = let res = evalState (inlineWith [topn] (map (\n -> (n, LV (Glob n))) args) exp) 0 in

208+ = let e' = evalState (findUp e) [] in

222− LFun opts topn args res

209+ (n, LFun opts fn args e')

223 where

210 where

211+ -- Keep track of 'updatable' names in the state, i.e. names whose heap

212+ -- entry may be reused, along with the arity which was there

224− inlineWith :: [Name] -> [(Name, LExp)] -> LExp -> State Int LExp

213+ findUp :: LExp -> State [(Name, Int)] LExp

225− inlineWith done env var@(LV (Glob n))

214+ findUp (LApp t (LV (Glob n)) as)

226− = case lookup n env of

215+ | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,

227− Just t -> return t

216+ ar == length as

228− Nothing -> return var

217+ = findUp (LCon Nothing i n as)

229− inlineWith done env (LLazyApp n es) = LLazyApp n <$> (mapM (inlineWith done env) es)

218+ findUp (LV (Glob n))

230− inlineWith done env (LForce e) = LForce <$> inlineWith done env e

219+ | Just (LConstructor _ i 0) <- lookupCtxtExact n defs

220+ = findUp (LCon Nothing i n [])

221+ findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as

222+ findUp (LLazyApp n as) = LLazyApp n <$> mapM findUp as

231− inlineWith done env (LLazyExp e) = LLazyExp <$> inlineWith done env e

223+ findUp (LLazyExp e) = LLazyExp <$> findUp e

232− -- Extend the environment for Let and Lam so that bound names aren't

224+ findUp (LForce e) = LForce <$> findUp e

233− -- expanded with any top level argument definitions they shadow

225+ -- use assumption that names are unique!

234− inlineWith done env (LLet n val sc)

226+ findUp (LLet n val sc) = LLet n <$> findUp val <*> findUp sc

235− = do n' <- nextN

227+ findUp (LLam ns sc) = LLam ns <$> findUp sc

236− LLet n' <$> inlineWith done env val <*>

228+ findUp (LProj e i) = LProj <$> findUp e <*> return i

237− inlineWith done ((n, LV (Glob n')) : env) sc

229+ findUp (LCon (Just l) i n es) = LCon (Just l) i n <$> mapM findUp es

238− inlineWith done env (LLam args sc)

230+ findUp (LCon Nothing i n es)

239− = do ns' <- mapM (\n -> do n' <- nextN

231+ = do avail <- get

240− return (n, n')) args

232+ v <- findVar [] avail (length es)

241− LLam (map snd ns') <$>

233+ LCon v i n <$> mapM findUp es

242− inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) sc

243− inlineWith done env (LProj exp i) = LProj <$> inlineWith done env exp <*> return i

244− inlineWith done env (LCon loc i n es)

245− = LCon loc i n <$> mapM (inlineWith done env) es

246− inlineWith done env (LCase ty e alts)

247− = LCase ty <$> inlineWith done env e <*> mapM (inlineWithAlt done env) alts

248− inlineWith done env (LOp f es) = LOp f <$> mapM (inlineWith done env) es

249− -- the interesting case!

250− inlineWith done env (LApp t (LV (Glob n)) es)

251− | n `notElem` done,

252− [LFun opts _ args body] <- lookupCtxt n defs,

253− Inline `elem` opts,

254− length es == length args

255− = do es' <- mapM (inlineWith done env) es

256− inlineWith (n : done) (zip args es' ++ env) body

257− inlineWith done env (LApp t f es)

258− = LApp t <$> inlineWith done env f <*> mapM (inlineWith done env) es

259− inlineWith done env (LForeign l t s args)

234+ findUp (LForeign l t s es)

260− = LForeign l t s <$> mapM (\(t, e) -> do e' <- inlineWith done env e

235+ = LForeign l t s <$> mapM (\ (t, e) -> do e' <- findUp e

261− return (t, e')) args

236+ return (t, e')) es

262− inlineWith done env t = return t

237+ findUp (LOp o es) = LOp o <$> mapM findUp es

263−

238+ findUp (LCase Updatable e@(LV (Glob n)) as)

264− inlineWithAlt done env (LConCase i n es rhs)

239+ = LCase Updatable e <$> mapM (doUpAlt n) as

265− = do ns' <- mapM (\n -> do n' <- nextN

240+ findUp (LCase t e as)

266− return (n, n')) es

241+ = LCase t <$> findUp e <*> mapM findUpAlt as

267− LConCase i n (map snd ns') <$>

242+ findUp t = return t

268− inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) rhs

243+

269− inlineWithAlt done env (LConstCase c e) = LConstCase c <$> inlineWith done env e

244+ findUpAlt (LConCase i t args rhs) = do avail <- get

270− inlineWithAlt done env (LDefaultCase e) = LDefaultCase <$> inlineWith done env e

245+ rhs' <- findUp rhs

271−

246+ put avail

272−-- substLExp :: [(Name, LExp)] -> LExp -> LExp

247+ return $ LConCase i t args rhs'

273−-- substLExp env (LV (Glob n)) | Just t <- lookup n env = t

248+ findUpAlt (LConstCase i rhs) = LConstCase i <$> findUp rhs

274−-- substLExp env (LApp t f as) = LApp t (substLExp env f) (map (substLExp env) as)

249+ findUpAlt (LDefaultCase rhs) = LDefaultCase <$> findUp rhs

275−-- substLExp env (LLazyApp n as) = LLazyApp n (map (substLExp env) as)

250+

276−-- substLExp env (LLazyExp e) = LLazyExp (substLExp env e)

251+ doUpAlt n (LConCase i t args rhs)

277−-- substLExp env (LForce e) = LForce (substLExp env e)

252+ = do avail <- get

278−-- substLExp env (LLet n v sc) = LLet n (substLExp env v)

253+ put ((n, length args) : avail)

279−-- (substLExp ((n, LV (Glob n)) : env) sc)

254+ rhs' <- findUp rhs

280−-- substLExp env (LLam args sc)

255+ put avail

281−-- = LLam args (substLExp (map (\n -> (n, LV (Glob n))) args ++ env) sc)

256+ return $ LConCase i t args rhs'

282−-- substLExp env (LProj e i) = LProj (substLExp env e) i

257+ doUpAlt n (LConstCase i rhs) = LConstCase i <$> findUp rhs

283−-- substLExp env (LCon up i n es) = LCon up i n (map (substLExp env) es)

258+ doUpAlt n (LDefaultCase rhs) = LDefaultCase <$> findUp rhs

284−-- substLExp env (LCase ty e alts) = LCase ty (substLExp env e) (map substC alts)

259+

285−-- where

260+ findVar _ [] i = return Nothing

286−-- substC (LConCase i n args e)

261+ findVar acc ((n, l) : ns) i | l == i = do put (reverse acc ++ ns)

287−-- = LConCase i n args

262+ return (Just (Glob n))

288−-- (substLExp (map (\n -> (n, LV (Glob n))) args ++ env) e)

263+ findVar acc (n : ns) i = findVar (n : acc) ns i

289−-- substC (LConstCase i e) = LConstCase i (substLExp env e)

290−-- substC (LDefaultCase e) = LDefaultCase (substLExp env e)

291−-- substLExp env (LForeign l t s args)

292−-- = LForeign l t s (map (\ (ty, e) -> (ty, substLExp env e)) args)

293−-- substLExp env (LOp fn es) = LOp fn (map (substLExp env) es)

294−-- substLExp env t = t

295

264

296

265

297-- Return variables in list which are used in the expression

266-- Return variables in list which are used in the expression

src/IRTS/LangOpts.hsnew file+79

@@ -0,0 +1,79 @@

1+{-# LANGUAGE PatternGuards, DeriveFunctor #-}

3+module IRTS.LangOpts where

5+import Control.Monad.State hiding (lift)

6+import Control.Applicative hiding (Const)

8+import IRTS.Lang

9+import Idris.Core.TT

10+import Idris.Core.CaseTree

11+import Data.List

12+import Debug.Trace

13+

14+inlineAll :: [(Name, LDecl)] -> [(Name, LDecl)]

15+inlineAll lds = let defs = addAlist lds emptyContext in

16+ map (\ (n, def) -> (n, doInline defs def)) lds

17+

18+nextN :: State Int Name

19+nextN = do i <- get

20+ put (i + 1)

21+ return $ sMN i "in"

22+

23+-- Inline inside a declaration. Variables are still Name at this stage.

24+-- Need to preserve uniqueness of variable names in the resulting definition,

25+-- so invent a new name for every variable we encounter

26+doInline :: LDefs -> LDecl -> LDecl

27+doInline defs d@(LConstructor _ _ _) = d

28+doInline defs (LFun opts topn args exp)

29+ = let res = evalState (inlineWith [topn] (map (\n -> (n, LV (Glob n))) args) exp) 0 in

30+ LFun opts topn args res

31+ where

32+ inlineWith :: [Name] -> [(Name, LExp)] -> LExp -> State Int LExp

33+ inlineWith done env var@(LV (Glob n))

34+ = case lookup n env of

35+ Just t -> return t

36+ Nothing -> return var

37+ inlineWith done env (LLazyApp n es) = LLazyApp n <$> (mapM (inlineWith done env) es)

38+ inlineWith done env (LForce e) = LForce <$> inlineWith done env e

39+ inlineWith done env (LLazyExp e) = LLazyExp <$> inlineWith done env e

40+ -- Extend the environment for Let and Lam so that bound names aren't

41+ -- expanded with any top level argument definitions they shadow

42+ inlineWith done env (LLet n val sc)

43+ = do n' <- nextN

44+ LLet n' <$> inlineWith done env val <*>

45+ inlineWith done ((n, LV (Glob n')) : env) sc

46+ inlineWith done env (LLam args sc)

47+ = do ns' <- mapM (\n -> do n' <- nextN

48+ return (n, n')) args

49+ LLam (map snd ns') <$>

50+ inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) sc

51+ inlineWith done env (LProj exp i) = LProj <$> inlineWith done env exp <*> return i

52+ inlineWith done env (LCon loc i n es)

53+ = LCon loc i n <$> mapM (inlineWith done env) es

54+ inlineWith done env (LCase ty e alts)

55+ = LCase ty <$> inlineWith done env e <*> mapM (inlineWithAlt done env) alts

56+ inlineWith done env (LOp f es) = LOp f <$> mapM (inlineWith done env) es

57+ -- the interesting case!

58+ inlineWith done env (LApp t (LV (Glob n)) es)

59+ | n `notElem` done,

60+ [LFun opts _ args body] <- lookupCtxt n defs,

61+ Inline `elem` opts,

62+ length es == length args

63+ = do es' <- mapM (inlineWith done env) es

64+ inlineWith (n : done) (zip args es' ++ env) body

65+ inlineWith done env (LApp t f es)

66+ = LApp t <$> inlineWith done env f <*> mapM (inlineWith done env) es

67+ inlineWith done env (LForeign l t s args)

68+ = LForeign l t s <$> mapM (\(t, e) -> do e' <- inlineWith done env e

69+ return (t, e')) args

70+ inlineWith done env t = return t

71+

72+ inlineWithAlt done env (LConCase i n es rhs)

73+ = do ns' <- mapM (\n -> do n' <- nextN

74+ return (n, n')) es

75+ LConCase i n (map snd ns') <$>

76+ inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) rhs

77+ inlineWithAlt done env (LConstCase c e) = LConstCase c <$> inlineWith done env e

78+ inlineWithAlt done env (LDefaultCase e) = LDefaultCase <$> inlineWith done env e

79+