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

git.iko.soy/Idris-dev

on master help sign in

Improve evaluation of projection

06283b6Edwin Brady14 years ago

rts/idris_rts.h+3

compare with master

unifiedsplit

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

90#define RVAL (vm->ret)

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

92#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; }

93#define REG1 (vm->reg1)

96#define REG1 (vm->reg1)

95// Retrieving values

98// Retrieving values

src/Core/CaseTree.hs+9−3

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

73 termsize n (DefaultCase s) = termsize n s

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

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

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

78+

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

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

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

77−small n t = termsize n t < 50

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

79namesUsed :: SC -> [Name]

83namesUsed :: SC -> [Name]

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

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

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

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

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

143

147

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

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

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

150+

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

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

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

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

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

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

148 nu' (STerm t) = directUse t

154 nu' (STerm t) = directUse t

src/Core/CoreParser.hs+2−2

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

135pDocComment :: Char -> CParser a String

136pDocComment c

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

138− skipMany simpleSpace

138+ option ' ' (lchar ' ')

139 char c

140 skipMany simpleSpace

141 i <- getInput

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

144 whiteSpace

145 return doc)

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

147− skipMany simpleSpace

147+ option ' ' (lchar ' ')

148 char c

149 skipMany simpleSpace

150 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

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

190 | otherwise = return $ VV i

191 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

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

194 when (not atRepl) $ step maxred

195 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

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

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

200 when (not atRepl) $ step maxred

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

202+ -- again when evaluation finished

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

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

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

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

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

205 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

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

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

348 getValArgs' f as = (f, as)

350 getValArgs' f as = (f, as)

349

351

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+

350class Quote a where

362class Quote a where

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

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

352

364

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

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

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

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

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

727 let inl = alwaysInline in

739 let inl = alwaysInline in

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

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

729 ty ps_in ps args sc args' sc',

741 ty ps_in ps args sc args' sc',

730 access, Unchecked) ctxt in

742 access, Unchecked) ctxt in

731 uctxt { definitions = ctxt' }

743 uctxt { definitions = ctxt' }

src/IRTS/Bytecode.hs+3

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

28data BC = ASSIGN Reg Reg

29 | ASSIGNCONST Reg Const

30+ | UPDATE Reg Reg

30 | MKCON Reg Int [Reg]

31 | MKCON Reg Int [Reg]

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

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

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

33 | 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

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

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

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

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

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

75bc 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

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

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

76 where getL (Loc x) = L x

79 where getL (Loc x) = L x

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

80bc 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)

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

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

106 mkConst _ = "MKINT(42424242)"

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

107bcc i (MKCON l tag args)

108bcc i (MKCON l tag args)

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

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

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

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

src/IRTS/Defunctionalise.hs+41−12

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

11data DExp = DV LVar

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

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

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

14 | DProj DExp Int

15 | DProj DExp Int

15 | DC Int Name [DExp]

16 | DC Int Name [DExp]

16 | DCase DExp [DAlt]

17 | DCase DExp [DAlt]

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

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

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

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

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

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

90 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

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

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

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

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

92 aa env (LConst c) = DConst c

95 aa env (LConst c) = DConst c

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

115 chainAPPLY f [] = f

118 chainAPPLY f [] = f

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

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

117

120

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+

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

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

119

144

120−data EvalApply a = EvalCase a

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

121 | ApplyCase a

146 | ApplyCase a

122− deriving Show

147+-- deriving Show

123

148

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

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

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

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

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

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

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

128toCons (n, i)

153toCons (n, i)

129 = (mkFnCon n, i,

154 = (mkFnCon n, i,

155+ EvalCase (\tlarg ->

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

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

157+ (dupdate tlarg

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

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

132− : mkApplyCase n 0 i

159+ : mkApplyCase n 0 i

160+ where dupdate tlarg x = x

133

161

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

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

135mkApplyCase fname n ar

163mkApplyCase fname n ar

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

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

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

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

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

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

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

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

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

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

141 : mkApplyCase fname (n + 1) ar

169 : mkApplyCase fname (n + 1) ar

142

170

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

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

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

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

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

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

146− (mapMaybe evalCase xs ++

174+ (mapMaybe evalCase xs ++

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

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

148 where

176 where

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

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

150 evalCase _ = Nothing

178 evalCase _ = Nothing

151

179

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

src/IRTS/Simplified.hs+8

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

13data SExp = SV LVar

14 | SApp Bool Name [LVar]

15 | SLet LVar SExp SExp

16+ | SUpdate LVar SExp

16 | SCon Int Name [LVar]

17 | SCon Int Name [LVar]

17 | SCase LVar [SAlt]

18 | SCase LVar [SAlt]

18 | SProj LVar Int

19 | SProj LVar Int

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

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

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

57 e' <- simplify tl e

58 e' <- simplify tl e

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

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

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

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

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

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

60 mkapp (SCon i n) args'

63 mkapp (SCon i n) args'

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

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

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

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

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

170 e' <- sc env' e

173 e' <- sc env' e

171 return (SLet n' v' e')

174 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')

172 sc env (SOp prim args)

180 sc env (SOp prim args)

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

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

174 return (SOp prim args')

182 return (SOp prim args')