e5d1956 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Propagate constructor updates to bytecode

e5d1956Edwin Brady12 years ago

libs/prelude/Prelude/Basics.idr+1−1

compare with master

unifiedsplit

@@ -28,7 +28,7 @@ snd (x, y) = y

28infixl 9 .

30||| Function composition

31−(.) : (b -> c) -> (a -> b) -> a -> c

31+(.) : {a, b, c : Type*} -> (b -> c) -> (a -> b) -> a -> c

32(.) f g x = f (g x)

34||| Takes in the first two arguments in reverse order.

rts/idris_rts.h+5

@@ -214,6 +214,11 @@ void idris_doneAlloc(VM* vm);

214 SETTY(cl, CON); \

215 cl->info.c.tag_arity = ((t) << 8) | (a);

216

217+#define updateCon(cl, old, t, a) \

218+ cl = old; \

219+ SETTY(cl, CON); \

220+ cl->info.c.tag_arity = ((t) << 8) | (a);

221+

217void* vmThread(VM* callvm, func f, VAL arg);

222void* vmThread(VM* callvm, func f, VAL arg);

218

223

219// Copy a structure to another vm's heap

224// Copy a structure to another vm's heap

src/IRTS/Bytecode.hs+5−2

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

28data BC = ASSIGN Reg Reg

29 | ASSIGNCONST Reg Const

30 | UPDATE Reg Reg

31− | MKCON Reg Int [Reg]

31+ | MKCON Reg (Maybe Reg) Int [Reg]

32 | CASE Bool -- definitely a constructor, no need to check, if true

33 Reg [(Int, [BC])] (Maybe [BC])

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

@@ -81,8 +81,11 @@ bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r

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

82 ++ clean r

83-- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it

84+bc reg (SCon atloc i _ vs) r

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

85+ = MKCON reg (getAllocLoc atloc) i (map getL vs) : clean r

85 where getL (Loc x) = L x

86 where getL (Loc x) = L x

87+ getAllocLoc (Just (Loc x)) = Just (L x)

88+ getAllocLoc _ = Nothing

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

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

87bc reg (SConst i) r = ASSIGNCONST reg i : clean r

90bc reg (SConst i) r = ASSIGNCONST reg i : clean r

88bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r

91bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r

src/IRTS/CodegenC.hs+8−3

@@ -153,9 +153,8 @@ bcc i (ASSIGNCONST l c)

153 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"

154 mkConst _ = "MKINT(42424242)"

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

156−bcc i (MKCON l tag args)

156+bcc i (MKCON l loc tag args)

157− = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++

157+ = indent i ++ alloc loc tag ++

158− show (length args) ++ ", 0);\n" ++

159 indent i ++ setArgs 0 args ++ "\n" ++

158 indent i ++ setArgs 0 args ++ "\n" ++

160 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

159 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

161

160

@@ -165,6 +164,12 @@ bcc i (MKCON l tag args)

165 setArgs i [] = ""

164 setArgs i [] = ""

166 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++

165 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++

167 "); " ++ setArgs (i + 1) xs

166 "); " ++ setArgs (i + 1) xs

167+ alloc Nothing tag

168+ = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++

169+ show (length args) ++ ", 0);\n"

170+ alloc (Just old) tag

171+ = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++

172+ show (length args) ++ ");\n"

168

173

169bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++

174bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++

170 ", " ++ show a ++ ");\n"

175 ", " ++ show a ++ ");\n"

src/IRTS/CodegenJava.hs+1−1

@@ -460,7 +460,7 @@ mkExp pp (SUpdate var newExp) =

460 mkExp pp newExp

461

462-- Objects

463−mkExp pp (SCon conId _ args) =

463+mkExp pp (SCon _ conId _ args) =

464 mkIdrisObject conId args >>= ppExp pp

465

466-- Case expressions

src/IRTS/CodegenJavaScript.hs+1−1

@@ -1314,7 +1314,7 @@ translateBC info bc

1314 | SLIDE n <- bc = jsSLIDE info n

1315 | REBASE <- bc = jsREBASE info

1316 | RESERVE n <- bc = jsRESERVE info n

1317− | MKCON r t rs <- bc = jsMKCON info r t rs

1317+ | MKCON r _ t rs <- bc = jsMKCON info r t rs

1318 | CASE s r c d <- bc = jsCASE info s r c d

1319 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d

1320 | PROJECT r l a <- bc = jsPROJECT info r l a

src/IRTS/CodegenLLVM.hs+1−1

@@ -494,7 +494,7 @@ cgExpr (SUpdate (Loc level) expr) = do

494 modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }

495 return val

496cgExpr (SUpdate x expr) = cgExpr expr

497−cgExpr (SCon tag name args) = do

497+cgExpr (SCon _ tag name args) = do

498 argSlots <- mapM var args

499 case sequence argSlots of

500 Nothing -> return Nothing

src/IRTS/Compiler.hs+7−2

@@ -75,7 +75,7 @@ compile codegen f tm

75 logLvl 5 $ show defuns

76 iLOG "Resolving variables for CG"

77 -- iputStrLn $ showSep "\n" (map show (toAlist defuns))

78− let checked = checkDefs defuns (toAlist defuns)

78+ let checked = simplifyDefs defuns (toAlist defuns)

79 outty <- outputTy

80 dumpCases <- getDumpCases

81 dumpDefun <- getDumpDefun

@@ -194,10 +194,15 @@ mkLDecl n (Function tm _)

194 = declArgs [] True n <$> irTerm M.empty [] tm

195

196mkLDecl n (CaseOp ci _ _ _ pats cd)

197− = declArgs [] (case_inlinable ci) n <$> irTree args sc

197+ = declArgs [] (case_inlinable ci || caseName n) n <$> irTree args sc

198 where

199 (args, sc) = cases_runtime cd

200

201+ -- Always attempt to inline functions arising from 'case' expressions

202+ caseName (SN (CaseN _)) = True

203+ caseName (NS n _) = caseName n

204+ caseName _ = False

205+

201mkLDecl n (TyDecl (DCon tag arity _) _) =

206mkLDecl n (TyDecl (DCon tag arity _) _) =

202 LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)

207 LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)

203

208

src/IRTS/Defunctionalise.hs+6−4

@@ -18,7 +18,7 @@ data DExp = DV LVar

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

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

20 | DProj DExp Int

21− | DC Int Name [DExp]

21+ | DC (Maybe LVar) Int Name [DExp]

22 | DCase CaseType DExp [DAlt]

23 | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY)

24 | DConst Const

@@ -100,7 +100,7 @@ addApps defs (n, LFun _ _ args e)

100 aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV (Glob n)) args)

101 aa env (LForce e) = liftM eEVAL (aa env e)

102 aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)

103− aa env (LCon i n args) = liftM (DC i n) (mapM (aa env) args)

103+ aa env (LCon loc i n args) = liftM (DC loc i n) (mapM (aa env) args)

104 aa env (LProj t@(LV (Glob n)) i)

105 | n `elem` env = do t' <- aa env t

106 return $ DProj (DUpdate n t') i

@@ -161,7 +161,7 @@ addApps defs (n, LFun _ _ args e)

161 | otherwise = preEval xs t

162

163 needsEval x (DApp _ _ args) = or (map (needsEval x) args)

164− needsEval x (DC _ _ args) = or (map (needsEval x) args)

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

165 needsEval x (DCase up e alts) = needsEval x e || or (map nec alts)

166 where nec (DConCase _ _ _ e) = needsEval x e

167 nec (DConstCase _ e) = needsEval x e

@@ -263,7 +263,9 @@ 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 i n args) = 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) ++ ":"

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

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

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

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

269 showSep "\n\t| " (map (showAlt env) alts)

271 showSep "\n\t| " (map (showAlt env) alts)

src/IRTS/DumpBC.hs+3−1

@@ -35,8 +35,10 @@ serializeBC n bc = indent n ++

35 "ASSIGNCONST " ++ serializeReg a ++ " " ++ show b

36 UPDATE a b ->

37 "UPDATE " ++ serializeReg a ++ " " ++ serializeReg b

38− MKCON a b xs ->

38+ MKCON a Nothing b xs ->

39 "MKCON " ++ serializeReg a ++ " " ++ show b ++ " [" ++ (interMap xs ", " serializeReg) ++ "]"

40+ MKCON a (Just r) b xs ->

41+ "MKCON@" ++ serializeReg r ++ " " ++ serializeReg a ++ " " ++ show b ++ " [" ++ (interMap xs ", " serializeReg) ++ "]"

40 CASE safe r cases def ->

42 CASE safe r cases def ->

41 "CASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) ++

43 "CASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) ++

42 maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def

44 maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def

src/IRTS/Lang.hs+12−6

@@ -19,7 +19,8 @@ data LExp = LV LVar

19 | LLet Name LExp LExp -- name just for pretty printing

20 | LLam [Name] LExp -- lambda, lifted out before compiling

21 | LProj LExp Int -- projection

22+ | LCon (Maybe LVar) -- Location to reallocate, if available

22− | LCon Int Name [LExp]

23+ Int Name [LExp]

23 | LCase CaseType LExp [LAlt]

24 | LCase CaseType LExp [LAlt]

24 | LConst Const

25 | LConst Const

25 | LForeign FLang FType String [(FType, LExp)]

26 | LForeign FLang FType String [(FType, LExp)]

@@ -169,8 +170,8 @@ lift env (LLam args e) = do e' <- lift (env ++ args) e

169 return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))

170 return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))

170lift env (LProj t i) = do t' <- lift env t

171lift env (LProj t i) = do t' <- lift env t

171 return (LProj t' i)

172 return (LProj t' i)

172−lift env (LCon i n args) = do args' <- mapM (lift env) args

173+lift env (LCon loc i n args) = do args' <- mapM (lift env) args

173− return (LCon i n args')

174+ return (LCon loc i n args')

174lift env (LCase up e alts) = do alts' <- mapM liftA alts

175lift env (LCase up e alts) = do alts' <- mapM liftA alts

175 e' <- lift env e

176 e' <- lift env e

176 return (LCase up e' alts')

177 return (LCase up e' alts')

@@ -192,6 +193,9 @@ lift env (LOp f args) = do args' <- mapM (lift env) args

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

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

193lift env LNothing = return $ LNothing

194lift env LNothing = return $ LNothing

194

195

196+allocUnique :: LDecl -> LDecl

197+allocUnique x = x

198+

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

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

196

200

197usedArg env n | n `elem` env = [n]

201usedArg env n | n `elem` env = [n]

@@ -205,7 +209,7 @@ usedIn env (LLazyExp e) = usedIn env e

205usedIn env (LForce e) = usedIn env e

209usedIn env (LForce e) = usedIn env e

206usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e

210usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e

207usedIn env (LLam ns e) = usedIn (env \\ ns) e

211usedIn env (LLam ns e) = usedIn (env \\ ns) e

208−usedIn env (LCon i n args) = concatMap (usedIn env) args

212+usedIn env (LCon loc i n args) = concatMap (usedIn env) args

209usedIn env (LProj t i) = usedIn env t

213usedIn env (LProj t i) = usedIn env t

210usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

214usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

211 where usedInA env (LConCase i n ns e) = usedIn env e

215 where usedInA env (LConCase i n ns e) = usedIn env e

@@ -238,8 +242,10 @@ instance Show LExp where

238

242

239 show' env ind (LProj t i) = show t ++ "!" ++ show i

243 show' env ind (LProj t i) = show t ++ "!" ++ show i

240

244

241− show' env ind (LCon i n args)

245+ show' env ind (LCon loc i n args)

242− = show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

246+ = atloc loc ++ show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

247+ where atloc Nothing = ""

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

243

249

244 show' env ind (LCase up e alts)

250 show' env ind (LCase up e alts)

245 = "case" ++ update ++ show' env ind e ++ " of \n" ++ fmt alts

251 = "case" ++ update ++ show' env ind e ++ " of \n" ++ fmt alts

src/IRTS/Simplified.hs+22−17

@@ -1,4 +1,4 @@

1−module IRTS.Simplified where

1+module IRTS.Simplified(simplifyDefs, SDecl(..), SExp(..), SAlt(..)) where

3import IRTS.Defunctionalise

4import Idris.Core.TT

@@ -16,7 +16,8 @@ data SExp = SV LVar

16 | SApp Bool Name [LVar]

17 | SLet LVar SExp SExp

18 | SUpdate LVar SExp

19+ | SCon (Maybe LVar) -- location to reallocate, if available

19− | SCon Int Name [LVar]

20+ Int Name [LVar]

20 | SCase CaseType LVar [SAlt]

21 | SCase CaseType LVar [SAlt]

21 | SChkCase LVar [SAlt]

22 | SChkCase LVar [SAlt]

22 | SProj LVar Int

23 | SProj LVar Int

@@ -49,7 +50,7 @@ simplify tl (DV (Loc i)) = return (SV (Loc i))

49simplify tl (DV (Glob x))

50simplify tl (DV (Glob x))

50 = do ctxt <- ldefs

51 = do ctxt <- ldefs

51 case lookupCtxtExact x ctxt of

52 case lookupCtxtExact x ctxt of

52− Just (DConstructor _ t 0) -> return $ SCon t x []

53+ Just (DConstructor _ t 0) -> return $ SCon Nothing t x []

53 _ -> return $ SV (Glob x)

54 _ -> return $ SV (Glob x)

54simplify tl (DApp tc n args) = do args' <- mapM sVar args

55simplify tl (DApp tc n args) = do args' <- mapM sVar args

55 mkapp (SApp (tl || tc) n) args'

56 mkapp (SApp (tl || tc) n) args'

@@ -62,8 +63,8 @@ simplify tl (DLet n v e) = do v' <- simplify False v

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

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

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

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

64 return (SUpdate (Glob n) e')

65 return (SUpdate (Glob n) e')

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

66+simplify tl (DC loc i n args) = do args' <- mapM sVar args

66− mkapp (SCon i n) args'

67+ mkapp (SCon loc i n) args'

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

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

68 case v of

69 case v of

69 (x, Nothing) -> return (SProj x i)

70 (x, Nothing) -> return (SProj x i)

@@ -91,7 +92,7 @@ simplify tl (DError str) = return $ SError str

91sVar (DV (Glob x))

92sVar (DV (Glob x))

92 = do ctxt <- ldefs

93 = do ctxt <- ldefs

93 case lookupCtxtExact x ctxt of

94 case lookupCtxtExact x ctxt of

94− Just (DConstructor _ t 0) -> sVar (DC t x [])

95+ Just (DConstructor _ t 0) -> sVar (DC Nothing t x [])

95 _ -> return (Glob x, Nothing)

96 _ -> return (Glob x, Nothing)

96sVar (DV x) = return (x, Nothing)

97sVar (DV x) = return (x, Nothing)

97sVar e = do e' <- simplify False e

98sVar e = do e' <- simplify False e

@@ -119,15 +120,15 @@ sAlt tl (DConstCase c e) = do e' <- simplify tl e

119sAlt tl (DDefaultCase e) = do e' <- simplify tl e

120sAlt tl (DDefaultCase e) = do e' <- simplify tl e

120 return (SDefaultCase e')

121 return (SDefaultCase e')

121

122

122−checkDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]

123+simplifyDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]

123−checkDefs ctxt [] = return []

124+simplifyDefs ctxt [] = return []

124−checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)

125+simplifyDefs ctxt (con@(n, DConstructor _ _ _) : xs)

125− = do xs' <- checkDefs ctxt xs

126+ = do xs' <- simplifyDefs ctxt xs

126 return xs'

127 return xs'

127−checkDefs ctxt ((n, DFun n' args exp) : xs)

128+simplifyDefs ctxt ((n, DFun n' args exp) : xs)

128 = do let sexp = evalState (simplify True exp) (ctxt, 0)

129 = do let sexp = evalState (simplify True exp) (ctxt, 0)

129 (exp', locs) <- runStateT (scopecheck n ctxt (zip args [0..]) sexp) (length args)

130 (exp', locs) <- runStateT (scopecheck n ctxt (zip args [0..]) sexp) (length args)

130− xs' <- checkDefs ctxt xs

131+ xs' <- simplifyDefs ctxt xs

131 return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')

132 return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')

132

133

133lvar v = do i <- get

134lvar v = do i <- get

@@ -143,7 +144,7 @@ scopecheck fn ctxt envTop tm = sc envTop tm where

143 Nothing -> case lookupCtxtExact n ctxt of

144 Nothing -> case lookupCtxtExact n ctxt of

144 Just (DConstructor _ i ar) ->

145 Just (DConstructor _ i ar) ->

145 if True -- ar == 0

146 if True -- ar == 0

146− then return (SCon i n [])

147+ then return (SCon Nothing i n [])

147 else failsc $ "Constructor " ++ show n ++

148 else failsc $ "Constructor " ++ show n ++

148 " has arity " ++ show ar

149 " has arity " ++ show ar

149 Just _ -> return (SV (Glob n))

150 Just _ -> return (SV (Glob n))

@@ -153,7 +154,7 @@ scopecheck fn ctxt envTop tm = sc envTop tm where

153 case lookupCtxtExact f ctxt of

154 case lookupCtxtExact f ctxt of

154 Just (DConstructor n tag ar) ->

155 Just (DConstructor n tag ar) ->

155 if True -- (ar == length args)

156 if True -- (ar == length args)

156− then return $ SCon tag n args'

157+ then return $ SCon Nothing tag n args'

157 else failsc $ "Constructor " ++ show f ++

158 else failsc $ "Constructor " ++ show f ++

158 " has arity " ++ show ar

159 " has arity " ++ show ar

159 Just _ -> return $ SApp tc f args'

160 Just _ -> return $ SApp tc f args'

@@ -162,12 +163,16 @@ scopecheck fn ctxt envTop tm = sc envTop tm where

162 = do args' <- mapM (\ (t, a) -> do a' <- scVar env a

163 = do args' <- mapM (\ (t, a) -> do a' <- scVar env a

163 return (t, a')) args

164 return (t, a')) args

164 return $ SForeign l ty f args'

165 return $ SForeign l ty f args'

165− sc env (SCon tag f args)

166+ sc env (SCon loc tag f args)

167+ = do loc' <- case loc of

168+ Nothing -> return Nothing

169+ Just l -> do l' <- scVar env l

170+ return (Just l')

166− = do args' <- mapM (scVar env) args

171+ args' <- mapM (scVar env) args

167 case lookupCtxtExact f ctxt of

172 case lookupCtxtExact f ctxt of

168 Just (DConstructor n tag ar) ->

173 Just (DConstructor n tag ar) ->

169 if True -- (ar == length args)

174 if True -- (ar == length args)

170− then return $ SCon tag n args'

175+ then return $ SCon loc' tag n args'

171 else failsc $ "Constructor " ++ show f ++

176 else failsc $ "Constructor " ++ show f ++

172 " has arity " ++ show ar

177 " has arity " ++ show ar

173 _ -> failsc $ "No such constructor " ++ show f

178 _ -> failsc $ "No such constructor " ++ show f