06283b6 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Improve evaluation of projection

By caching result of evaluation, so that it's already evaluated when next projection happens.

commit06283b6ed60f6ad8675274e3d4dfc8741fe8e634 authorEdwin Brady <ecb10@st-andrews.ac.uk> dateSat 1 Dec 2012, 12:59 (14 years ago) parent2f26fb2

8 files changed+81−19

compare with master

unifiedsplit

rts/idris_rts.h+3 src/Core/CaseTree.hs+9−3 src/Core/CoreParser.hs+2−2 src/Core/Evaluate.hs+14−2 src/IRTS/Bytecode.hs+3 src/IRTS/CodegenC.hs+1 src/IRTS/Defunctionalise.hs+41−12 src/IRTS/Simplified.hs+8

rts/idris_rts.h+3

@@ -90,6 +90,9 @@ typedef void(*func)(VM*, VAL*);

9090#define RVAL (vm->ret)

9191#define LOC(x) (*(vm->valstack_base + (x)))

9292#define TOP(x) (*(vm->valstack_top + (x)))

93+// Doesn't work! Ordinary assign seems fine though...

94+#define UPDATE(x,y) if (!ISINT(x) && !ISINT(y)) \

95+ { (x)->ty = (y)->ty; (x)->info = (y)->info; }

9396#define REG1 (vm->reg1)

9497

9598// Retrieving values

src/Core/CaseTree.hs+9−3

@@ -73,8 +73,12 @@ instance TermSize CaseAlt where

7373 termsize n (DefaultCase s) = termsize n s

7474

7575-- simple terms can be inlined trivially - good for primitives in particular

76−small :: Name -> SC -> Bool

77−small n t = termsize n t < 50

76+-- To avoid duplicating work, don't inline something which uses one

77+-- of its arguments in more than one place

78+

79+small :: Name -> [Name] -> SC -> Bool

80+small n args t = let as = findAllUsedArgs t args in

81+ length as == length (nub as) && termsize n t < 50

7882

7983namesUsed :: SC -> [Name]

8084namesUsed sc = nub $ nu' [] sc where

@@ -142,7 +146,9 @@ directUse _ = []

142146-- Find all directly used arguments (i.e. used but not in function calls)

143147

144148findUsedArgs :: SC -> [Name] -> [Name]

145−findUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nub $ nu' sc) where

149+findUsedArgs sc topargs = nub (findAllUsedArgs sc topargs)

150+

151+findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where

146152 nu' (Case n alts) = n : concatMap nua alts

147153 nu' (ProjCase t alts) = directUse t ++ concatMap nua alts

148154 nu' (STerm t) = directUse t

src/Core/CoreParser.hs+2−2

@@ -135,7 +135,7 @@ mkName (n, ns) = NS (UN n) (reverse (parseNS ns))

135135pDocComment :: Char -> CParser a String

136136pDocComment c

137137 = try (do string ("--")

138− skipMany simpleSpace

138+ option ' ' (lchar ' ')

139139 char c

140140 skipMany simpleSpace

141141 i <- getInput

@@ -144,7 +144,7 @@ pDocComment c

144144 whiteSpace

145145 return doc)

146146 <|> try (do string ("{-")

147− skipMany simpleSpace

147+ option ' ' (lchar ' ')

148148 char c

149149 skipMany simpleSpace

150150 i <- getInput

src/Core/Evaluate.hs+14−2

@@ -189,7 +189,7 @@ eval traceon ctxt maxred ntimes genv tm opts = ev ntimes [] True [] tm where

189189 ev ntimes stk top env (V i) | i < length env = return $ env !! i

190190 | otherwise = return $ VV i

191191 ev ntimes stk top env (Bind n (Let t v) sc)

192− | not simpl -- || vinstances 0 sc < 2

192+ | not simpl || vinstances 0 sc < 2

193193 = do v' <- ev ntimes stk top env v --(finalise v)

194194 when (not atRepl) $ step maxred

195195 sc' <- ev ntimes stk top (v' : env) sc

@@ -198,6 +198,8 @@ eval traceon ctxt maxred ntimes genv tm opts = ev ntimes [] True [] tm where

198198 = do t' <- ev ntimes stk top env t

199199 v' <- ev ntimes stk top env v --(finalise v)

200200 when (not atRepl) $ step maxred

201+ -- use Tmp as a placeholder, then make it a variable reference

202+ -- again when evaluation finished

201203 sc' <- ev ntimes stk top (v' : env) sc

202204 return $ VBind n (Let t' v') (\x -> return sc')

203205 ev ntimes stk top env (Bind n (NLet t v) sc)

@@ -347,6 +349,16 @@ eval traceon ctxt maxred ntimes genv tm opts = ev ntimes [] True [] tm where

347349 getValArgs' (VApp f a) as = getValArgs' f (a:as)

348350 getValArgs' f as = (f, as)

349351

352+tmpToV i (VTmp 0) = return $ VV i

353+tmpToV i (VP nt n v) = liftM (VP nt n) (tmpToV i v)

354+

355+tmpToV i (VBind n b sc) = do b' <- fmapMB (tmpToV i) b

356+ let sc' = \x -> do x' <- sc x

357+ tmpToV (i + 1) x'

358+ return (VBind n b' sc')

359+tmpToV i (VApp f a) = liftM2 VApp (tmpToV i f) (tmpToV i a)

360+tmpToV i x = return x

361+

350362class Quote a where

351363 quote :: Int -> a -> Eval (TT Name)

352364

@@ -725,7 +737,7 @@ addCasedef n alwaysInline tcase covering ps_in ps psrt ty uctxt

725737 simpleCase tcase covering RunTime (FC "" 0) psrt) of

726738 (OK (CaseDef args sc _), OK (CaseDef args' sc' _)) ->

727739 let inl = alwaysInline in

728− addDef n (CaseOp inl (inl || small n sc')

740+ addDef n (CaseOp inl (inl || small n args sc')

729741 ty ps_in ps args sc args' sc',

730742 access, Unchecked) ctxt in

731743 uctxt { definitions = ctxt' }

src/IRTS/Bytecode.hs+3

@@ -27,6 +27,7 @@ data Reg = RVal | L Int | T Int | Tmp

2727

2828data BC = ASSIGN Reg Reg

2929 | ASSIGNCONST Reg Const

30+ | UPDATE Reg Reg

3031 | MKCON Reg Int [Reg]

3132 | CASE Reg [(Int, [BC])] (Maybe [BC])

3233 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards

@@ -72,6 +73,8 @@ bc reg (SForeign l t fname args) r

7273 = FOREIGNCALL reg l t fname (map farg args) : clean r

7374 where farg (ty, Loc i) = (ty, L i)

7475bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r

76+bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]

77+ ++ clean r

7578bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r

7679 where getL (Loc x) = L x

7780bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r

src/IRTS/CodegenC.hs+1

@@ -104,6 +104,7 @@ bcc i (ASSIGNCONST l c)

104104 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

105105 mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"

106106 mkConst _ = "MKINT(42424242)"

107+bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

107108bcc i (MKCON l tag args)

108109 = indent i ++ creg Tmp ++ " = allocCon(vm, " ++ show (length args) ++

109110 ", 0); " ++ "SETTAG(" ++ creg Tmp ++ ", " ++ show tag ++ ");\n" ++

src/IRTS/Defunctionalise.hs+41−12

@@ -11,6 +11,7 @@ import Data.List

1111data DExp = DV LVar

1212 | DApp Bool Name [DExp] -- True = tail call

1313 | DLet Name DExp DExp -- name just for pretty printing

14+ | DUpdate Name DExp -- eval expression, then update var with it

1415 | DProj DExp Int

1516 | DC Int Name [DExp]

1617 | DCase DExp [DAlt]

@@ -87,6 +88,8 @@ addApps defs (n, LFun _ args e) = (n, DFun n args (aa args e))

8788 aa env (LForce e) = eEVAL (aa env e)

8889 aa env (LLet n v sc) = DLet n (aa env v) (aa (n : env) sc)

8990 aa env (LCon i n args) = DC i n (map (aa env) args)

91+ aa env (LProj t@(LV (Glob n)) i)

92+ = DProj (DUpdate n (eEVAL (aa env t))) i

9093 aa env (LProj t i) = DProj (eEVAL (aa env t)) i

9194 aa env (LCase e alts) = DCase (eEVAL (aa env e)) (map (aaAlt env) alts)

9295 aa env (LConst c) = DConst c

@@ -115,11 +118,33 @@ addApps defs (n, LFun _ args e) = (n, DFun n args (aa args e))

115118 chainAPPLY f [] = f

116119 chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as

117120

121+ -- if anything in the DExp is projected from, we'll need to evaluate it,

122+ -- but we only want to do it once, rather than every time we project.

123+

124+ preEval [] t = t

125+ preEval (x : xs) t

126+ | needsEval x t = DLet x (eEVAL (DV (Glob x))) (preEval xs t)

127+ | otherwise = preEval xs t

128+

129+ needsEval x (DApp _ _ args) = or (map (needsEval x) args)

130+ needsEval x (DC _ _ args) = or (map (needsEval x) args)

131+ needsEval x (DCase e alts) = needsEval x e || or (map nec alts)

132+ where nec (DConCase _ _ _ e) = needsEval x e

133+ nec (DConstCase _ e) = needsEval x e

134+ nec (DDefaultCase e) = needsEval x e

135+ needsEval x (DLet n v e)

136+ | x == n = needsEval x v

137+ | otherwise = needsEval x v || needsEval x e

138+ needsEval x (DForeign _ _ _ args) = or (map (needsEval x) (map snd args))

139+ needsEval x (DOp op args) = or (map (needsEval x) args)

140+ needsEval x (DProj (DV (Glob x')) _) = x == x'

141+ needsEval x _ = False

142+

118143eEVAL x = DApp False (MN 0 "EVAL") [x]

119144

120−data EvalApply a = EvalCase a

145+data EvalApply a = EvalCase (Name -> a)

121146 | ApplyCase a

122− deriving Show

147+-- deriving Show

123148

124149-- For a function name, generate a list of

125150-- data constuctors, and whether to handle them in EVAL or APPLY

@@ -127,26 +152,29 @@ data EvalApply a = EvalCase a

127152toCons :: (Name, Int) -> [(Name, Int, EvalApply DAlt)]

128153toCons (n, i)

129154 = (mkFnCon n, i,

130− EvalCase (DConCase (-1) (mkFnCon n) (take i (genArgs 0))

131− (eEVAL (DApp False n (map (DV . Glob) (take i (genArgs 0)))))))

132− : mkApplyCase n 0 i

155+ EvalCase (\tlarg ->

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

157+ (dupdate tlarg

158+ (eEVAL (DApp False n (map (DV . Glob) (take i (genArgs 0)))))))))

159+ : mkApplyCase n 0 i

160+ where dupdate tlarg x = x

133161

134162mkApplyCase fname n ar | n == ar = []

135163mkApplyCase fname n ar

136164 = let nm = mkUnderCon fname (ar - n) in

137165 (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))

138− (DApp False (mkUnderCon fname (ar - (n + 1)))

139− (map (DV . Glob) (take n (genArgs 0) ++

140− [MN 0 "arg"])))))

166+ (DApp False (mkUnderCon fname (ar - (n + 1)))

167+ (map (DV . Glob) (take n (genArgs 0) ++

168+ [MN 0 "arg"])))))

141169 : mkApplyCase fname (n + 1) ar

142170

143171mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

144172mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"]

145− (mkBigCase (MN 0 "EVAL") 256 (DV (Glob (MN 0 "arg")))

146− (mapMaybe evalCase xs ++

147− [DDefaultCase (DV (Glob (MN 0 "arg")))])))

173+ (mkBigCase (MN 0 "EVAL") 256 (DV (Glob (MN 0 "arg")))

174+ (mapMaybe evalCase xs ++

175+ [DDefaultCase (DV (Glob (MN 0 "arg")))])))

148176 where

149− evalCase (n, t, EvalCase x) = Just x

177+ evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg"))

150178 evalCase _ = Nothing

151179

152180mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

@@ -180,6 +208,7 @@ instance Show DExp where

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

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

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

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

183212 show' env (DC i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"

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

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

src/IRTS/Simplified.hs+8

@@ -13,6 +13,7 @@ import Debug.Trace

1313data SExp = SV LVar

1414 | SApp Bool Name [LVar]

1515 | SLet LVar SExp SExp

16+ | SUpdate LVar SExp

1617 | SCon Int Name [LVar]

1718 | SCase LVar [SAlt]

1819 | SProj LVar Int

@@ -56,6 +57,8 @@ simplify tl (DForeign lang ty fn args)

5657simplify tl (DLet n v e) = do v' <- simplify False v

5758 e' <- simplify tl e

5859 return (SLet (Glob n) v' e')

60+simplify tl (DUpdate n e) = do e' <- simplify False e

61+ return (SUpdate (Glob n) e')

5962simplify tl (DC i n args) = do args' <- mapM sVar args

6063 mkapp (SCon i n) args'

6164simplify tl (DProj t i) = do v <- sVar t

@@ -169,6 +172,11 @@ scopecheck ctxt envTop tm = sc envTop tm where

169172 n' <- scVar env' (Glob n)

170173 e' <- sc env' e

171174 return (SLet n' v' e')

175+ sc env (SUpdate (Glob n) e)

176+ = do -- n already in env

177+ e' <- sc env e

178+ n' <- scVar env (Glob n)

179+ return (SUpdate n' e')

172180 sc env (SOp prim args)

173181 = do args' <- mapM (scVar env) args

174182 return (SOp prim args')