e5d1956 · Idris-dev · git.iko.soy

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

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

2828infixl 9 .

2929

3030||| Function composition

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

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

3232(.) f g x = f (g x)

3333

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

rts/idris_rts.h+5

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

214214 SETTY(cl, CON); \

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

216216

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

218+ cl = old; \

219+ SETTY(cl, CON); \

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

221+

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

218223

219224// 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

2828data BC = ASSIGN Reg Reg

2929 | ASSIGNCONST Reg Const

3030 | UPDATE Reg Reg

31− | MKCON Reg Int [Reg]

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

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

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

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

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

8282 ++ clean r

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

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

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

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

8586 where getL (Loc x) = L x

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

88+ getAllocLoc _ = Nothing

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

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

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

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

154154 mkConst _ = "MKINT(42424242)"

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

156−bcc i (MKCON l tag args)

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

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

156+bcc i (MKCON l loc tag args)

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

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

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

161160

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

165164 setArgs i [] = ""

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

167166 "); " ++ 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"

168173

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

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

src/IRTS/CodegenJava.hs+1−1

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

460460 mkExp pp newExp

461461

462462-- Objects

463−mkExp pp (SCon conId _ args) =

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

464464 mkIdrisObject conId args >>= ppExp pp

465465

466466-- Case expressions

src/IRTS/CodegenJavaScript.hs+1−1

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

13141314 | SLIDE n <- bc = jsSLIDE info n

13151315 | REBASE <- bc = jsREBASE info

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

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

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

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

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

495495 return val

496496cgExpr (SUpdate x expr) = cgExpr expr

497−cgExpr (SCon tag name args) = do

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

498498 argSlots <- mapM var args

499499 case sequence argSlots of

500500 Nothing -> return Nothing

src/IRTS/Compiler.hs+7−2

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

7575 logLvl 5 $ show defuns

7676 iLOG "Resolving variables for CG"

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

78− let checked = checkDefs defuns (toAlist defuns)

78+ let checked = simplifyDefs defuns (toAlist defuns)

7979 outty <- outputTy

8080 dumpCases <- getDumpCases

8181 dumpDefun <- getDumpDefun

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

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

195195

196196mkLDecl 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

198198 where

199199 (args, sc) = cases_runtime cd

200200

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+

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

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

203208

src/IRTS/Defunctionalise.hs+6−4

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

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

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

2020 | DProj DExp Int

21− | DC Int Name [DExp]

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

2222 | DCase CaseType DExp [DAlt]

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

2424 | DConst Const

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

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

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

102102 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)

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

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

106106 return $ DProj (DUpdate n t') i

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

161161 | otherwise = preEval xs t

162162

163163 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)

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

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

167167 nec (DConstCase _ e) = needsEval x e

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

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

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

265265 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) ++ ":"

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

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

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

src/IRTS/DumpBC.hs+3−1

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

3535 "ASSIGNCONST " ++ serializeReg a ++ " " ++ show b

3636 UPDATE a b ->

3737 "UPDATE " ++ serializeReg a ++ " " ++ serializeReg b

38− MKCON a b xs ->

38+ MKCON a Nothing b xs ->

3939 "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) ++ "]"

4042 CASE safe r cases def ->

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

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

src/IRTS/Lang.hs+12−6

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

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

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

2121 | LProj LExp Int -- projection

22− | LCon Int Name [LExp]

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

23+ Int Name [LExp]

2324 | LCase CaseType LExp [LAlt]

2425 | LConst Const

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

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

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

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

171172 return (LProj t' i)

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

173− return (LCon i n args')

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

174+ return (LCon loc i n args')

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

175176 e' <- lift env e

176177 return (LCase up e' alts')

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

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

193194lift env LNothing = return $ LNothing

194195

196+allocUnique :: LDecl -> LDecl

197+allocUnique x = x

198+

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

196200

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

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

205209usedIn env (LForce e) = usedIn env e

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

207211usedIn 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

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

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

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

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

238242

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

240244

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

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

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

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

247+ where atloc Nothing = ""

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

243249

244250 show' env ind (LCase up e alts)

245251 = "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

22

33import IRTS.Defunctionalise

44import Idris.Core.TT

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

1616 | SApp Bool Name [LVar]

1717 | SLet LVar SExp SExp

1818 | SUpdate LVar SExp

19− | SCon Int Name [LVar]

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

20+ Int Name [LVar]

2021 | SCase CaseType LVar [SAlt]

2122 | SChkCase LVar [SAlt]

2223 | SProj LVar Int

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

4950simplify tl (DV (Glob x))

5051 = do ctxt <- ldefs

5152 case lookupCtxtExact x ctxt of

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

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

5354 _ -> return $ SV (Glob x)

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

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

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

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

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

6465 return (SUpdate (Glob n) e')

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

66− mkapp (SCon i n) args'

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

67+ mkapp (SCon loc i n) args'

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

6869 case v of

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

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

9192sVar (DV (Glob x))

9293 = do ctxt <- ldefs

9394 case lookupCtxtExact x ctxt of

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

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

9596 _ -> return (Glob x, Nothing)

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

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

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

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

120121 return (SDefaultCase e')

121122

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

123−checkDefs ctxt [] = return []

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

125− = do xs' <- checkDefs ctxt xs

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

124+simplifyDefs ctxt [] = return []

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

126+ = do xs' <- simplifyDefs ctxt xs

126127 return xs'

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

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

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

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

130− xs' <- checkDefs ctxt xs

131+ xs' <- simplifyDefs ctxt xs

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

132133

133134lvar v = do i <- get

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

143144 Nothing -> case lookupCtxtExact n ctxt of

144145 Just (DConstructor _ i ar) ->

145146 if True -- ar == 0

146− then return (SCon i n [])

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

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

148149 " has arity " ++ show ar

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

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

153154 case lookupCtxtExact f ctxt of

154155 Just (DConstructor n tag ar) ->

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

156− then return $ SCon tag n args'

157+ then return $ SCon Nothing tag n args'

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

158159 " has arity " ++ show ar

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

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

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

163164 return (t, a')) args

164165 return $ SForeign l ty f args'

165− sc env (SCon tag f args)

166− = do args' <- mapM (scVar env) 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')

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

167172 case lookupCtxtExact f ctxt of

168173 Just (DConstructor n tag ar) ->

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

170− then return $ SCon tag n args'

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

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

172177 " has arity " ++ show ar

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