7245290 · Idris-dev · git.iko.soy

rts/Makefile+1−1

@@ -2,7 +2,7 @@ include ../config.mk

22

33OBJS = idris_rts.o idris_gc.o idris_gmp.o idris_stdfgn.o

44HDRS = idris_rts.h idris_gc.h idris_gmp.h idris_stdfgn.h

5−CFLAGS = -O2 -Wall -Werror

5+CFLAGS = -O2 -Wall

66ifneq ($(GMP_INCLUDE_DIR),)

77 CFLAGS += -isystem $(GMP_INCLUDE_DIR)

88endif

rts/idris_gc.c+7−7

@@ -3,18 +3,16 @@

33#include <assert.h>

44

55VAL copy(VM* vm, VAL x) {

6− int i;

6+ int i, ar;

77 Closure* cl = NULL;

88 if (x==NULL || ISINT(x)) {

99 return x;

1010 }

1111 switch(GETTY(x)) {

1212 case CON:

13− cl = allocCon(vm, x->info.c.arity, 1);

14− cl->info.c.tag = x->info.c.tag;

15− cl->info.c.arity = x->info.c.arity;

16−

17− for(i = 0; i < x->info.c.arity; ++i) {

13+ ar = CARITY(x);

14+ allocCon(cl, vm, CTAG(x), ar, 1);

15+ for(i = 0; i < ar; ++i) {

1816// *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version

1917 cl->info.c.args[i] = x->info.c.args[i];

2018 }

@@ -43,6 +41,7 @@ VAL copy(VM* vm, VAL x) {

4341

4442void cheney(VM *vm) {

4543 int i;

44+ int ar;

4645 char* scan = vm->heap;

4746

4847 while(scan < vm->heap_next) {

@@ -51,7 +50,8 @@ void cheney(VM *vm) {

5150 // If it's a CON, copy its arguments

5251 switch(GETTY(heap_item)) {

5352 case CON:

54− for(i = 0; i < heap_item->info.c.arity; ++i) {

53+ ar = ARITY(heap_item);

54+ for(i = 0; i < ar; ++i) {

5555 // printf("Copying %d %p\n", heap_item->info.c.tag, *argptr);

5656 VAL newptr = copy(vm, heap_item->info.c.args[i]);

5757 // printf("Got %p\t\t%p %p\n", newptr, scan, vm->heap_next);

rts/idris_main.c+1−1

@@ -1,5 +1,5 @@

11int main(int argc, char* argv[]) {

2− VM* vm = init_vm(4096000, 2048000, 1, argc, argv); // 1024000);

2+ VM* vm = init_vm(4096000, 4096000, 1, argc, argv); // 1024000);

33 _idris__123_runMain0_125_(vm, NULL);

44 //_idris_main(vm, NULL);

55#ifdef IDRIS_TRACE

rts/idris_rts.c+8−26

@@ -107,6 +107,7 @@ void* allocate(VM* vm, size_t size, int outerlock) {

107107

108108}

109109

110+/* Now a macro

110111void* allocCon(VM* vm, int arity, int outer) {

111112 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*arity,

112113 outer);

@@ -117,6 +118,7 @@ void* allocCon(VM* vm, int arity, int outer) {

117118// printf("%p\n", cl);

118119 return (void*)cl;

119120}

121+*/

120122

121123VAL MKFLOAT(VM* vm, double val) {

122124 Closure* cl = allocate(vm, sizeof(Closure), 0);

@@ -166,25 +168,6 @@ VAL MKPTRc(VM* vm, void* ptr) {

166168 return cl;

167169}

168170

169−VAL MKCON(VM* vm, VAL cl, int tag, int arity, ...) {

170− int i;

171− va_list args;

172−

173− va_start(args, arity);

174−

175−// Closure* cl = allocCon(vm, arity);

176− cl -> info.c.tag = tag;

177− cl -> info.c.arity = arity;

178− // printf("... %p %p\n", cl, argptr);

179−

180− for (i = 0; i < arity; ++i) {

181− VAL v = va_arg(args, VAL);

182− cl->info.c.args[i] = v;

183− }

184− va_end(args);

185− return cl;

186−}

187−

188171void PROJECT(VM* vm, VAL r, int loc, int arity) {

189172 int i;

190173 for(i = 0; i < arity; ++i) {

@@ -223,8 +206,8 @@ void dumpVal(VAL v) {

223206 }

224207 switch(GETTY(v)) {

225208 case CON:

226− printf("%d[", v->info.c.tag);

227− for(i = 0; i < v->info.c.arity; ++i) {

209+ printf("%d[", TAG(v));

210+ for(i = 0; i < ARITY(v); ++i) {

228211 dumpVal(v->info.c.args[i]);

229212 }

230213 printf("] ");

@@ -432,7 +415,7 @@ void* vmThread(VM* callvm, func f, VAL arg) {

432415// VM is assumed to be a different vm from the one x lives on

433416

434417VAL copyTo(VM* vm, VAL x) {

435− int i;

418+ int i, ar;

436419 VAL* argptr;

437420 Closure* cl;

438421 if (x==NULL || ISINT(x)) {

@@ -440,12 +423,11 @@ VAL copyTo(VM* vm, VAL x) {

440423 }

441424 switch(GETTY(x)) {

442425 case CON:

443− cl = allocCon(vm, x->info.c.arity, 1);

444− cl->info.c.tag = x->info.c.tag;

445− cl->info.c.arity = x->info.c.arity;

426+ ar = CARITY(x);

427+ allocCon(cl, vm, CTAG(x), ar, 1);

446428

447429 argptr = (VAL*)(cl->info.c.args);

448− for(i = 0; i < x->info.c.arity; ++i) {

430+ for(i = 0; i < ar; ++i) {

449431 *argptr = copyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version

450432 argptr++;

451433 }

rts/idris_rts.h+14−8

@@ -17,8 +17,7 @@ typedef enum {

1717typedef struct Closure *VAL;

1818

1919typedef struct {

20− int tag;

21− int arity;

20+ int tag_arity;

2221 VAL args[];

2322} con;

2423

@@ -101,7 +100,12 @@ typedef void(*func)(VM*, VAL*);

101100#define GETPTR(x) (((VAL)(x))->info.ptr)

102101#define GETFLOAT(x) (((VAL)(x))->info.f)

103102

104−#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag : (-1)) )

103+#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )

104+#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) )

105+

106+// Already checked it's a CON

107+#define CTAG(x) (((x)->info.c.tag_arity) >> 8)

108+#define CARITY(x) ((x)->info.c.tag_arity & 0x000000ff)

105109

106110// Use top 16 bits for saying which heap value is in

107111// Bottom 16 bits for closure type

@@ -136,7 +140,6 @@ typedef intptr_t i_int;

136140#define TOPBASE(x) vm->valstack_top = vm->valstack_base + (x)

137141#define BASETOP(x) vm->valstack_base = vm->valstack_top + (x)

138142#define STOREOLD myoldbase = vm->valstack_base

139−

140143#define CALL(f) f(vm, myoldbase);

141144#define TAILCALL(f) f(vm, oldbase);

142145

@@ -150,9 +153,7 @@ VAL MKFLOATc(VM* vm, double val);

150153VAL MKSTRc(VM* vm, char* str);

151154VAL MKPTRc(VM* vm, void* ptr);

152155

153−VAL MKCON(VM* vm, VAL cl, int tag, int arity, ...);

154−

155−#define SETTAG(x, a) (x)->info.c.tag = (a)

156+// #define SETTAG(x, a) (x)->info.c.tag = (a)

156157#define SETARG(x, i, a) ((x)->info.c.args)[i] = ((VAL)(a))

157158#define GETARG(x, i) ((x)->info.c.args)[i]

158159

@@ -160,7 +161,12 @@ void PROJECT(VM* vm, VAL r, int loc, int arity);

160161void SLIDE(VM* vm, int args);

161162

162163void* allocate(VM* vm, size_t size, int outerlock);

163−void* allocCon(VM* vm, int arity, int outerlock);

164+// void* allocCon(VM* vm, int arity, int outerlock);

165+

166+#define allocCon(cl, vm, t, a, o) \

167+ cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*a, o); \

168+ SETTY(cl, CON); \

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

164170

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

166172

src/Core/Evaluate.hs+3−3

@@ -189,19 +189,19 @@ 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

196196 wknV (-1) sc'

197− | otherwise

197+{- | otherwise -- put this back when the Bind works properly

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

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

202202 -- again when evaluation finished

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

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

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

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

206206 = do t' <- ev ntimes stk top env (finalise t)

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

src/IRTS/Bytecode.hs+7−4

@@ -29,7 +29,8 @@ data BC = ASSIGN Reg Reg

2929 | ASSIGNCONST Reg Const

3030 | UPDATE Reg Reg

3131 | MKCON Reg Int [Reg]

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

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

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

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

3435 | PROJECTINTO Reg Reg Int -- project argument from one reg into another

3536 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])

@@ -85,7 +86,9 @@ bc reg (SError str) r = [ERROR str]

8586bc reg SNothing r = NULL reg : clean r

8687bc reg (SCase (Loc l) alts) r

8788 | isConst alts = constCase reg (L l) alts r

88− | otherwise = conCase reg (L l) alts r

89+ | otherwise = conCase True reg (L l) alts r

90+bc reg (SChkCase (Loc l) alts) r

91+ = conCase False reg (L l) alts r

8992

9093isConst [] = False

9194isConst (SConstCase _ _ : xs) = True

@@ -98,8 +101,8 @@ moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs

98101assign r1 r2 | r1 == r2 = []

99102 | otherwise = [ASSIGN r1 r2]

100103

101−conCase reg l xs r = [CASE l (mapMaybe (caseAlt l reg r) xs)

102− (defaultAlt reg xs r)]

104+conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)

105+ (defaultAlt reg xs r)]

103106

104107constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)

105108 (defaultAlt reg xs r)]

src/IRTS/CodegenC.hs+10−4

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

108108 mkConst _ = "MKINT(42424242)"

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

110110bcc i (MKCON l tag args)

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

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

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

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

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

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

115115

@@ -124,12 +124,15 @@ bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show l

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

125125bcc i (PROJECTINTO r t idx)

126126 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"

127−bcc i (CASE r code def)

128− = indent i ++ "switch(TAG(" ++ creg r ++ ")) {\n" ++

127+bcc i (CASE safe r code def)

128+ = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

129129 concatMap (showCase i) code ++

130130 showDef i def ++

131131 indent i ++ "}\n"

132132 where

133+ ctag True = "CTAG"

134+ ctag False = "TAG"

135+

133136 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"

134137 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"

135138 showDef i Nothing = ""

@@ -180,7 +183,9 @@ bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"

180183bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"

181184bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"

182185bcc i REBASE = indent i ++ "REBASE;\n"

186+bcc i (RESERVE 0) = ""

183187bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"

188+bcc i (ADDTOP 0) = ""

184189bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"

185190bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"

186191bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

@@ -240,6 +245,7 @@ doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

240245

241246doOp v LBPlus [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

242247doOp v LBMinus [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

248+doOp v LBDec [l] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", MKINT(1))"

243249doOp v LBTimes [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

244250doOp v LBDiv [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

245251doOp v LBMod [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

src/IRTS/Compiler.hs+25−8

@@ -129,6 +129,14 @@ build (n, d)

129129 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

130130 return (n, def)

131131

132+getPrim :: IState -> Name -> [LExp] -> Maybe LExp

133+getPrim i n args = case lookup n (idris_scprims i) of

134+ Just (ar, op) ->

135+ if (ar == length args)

136+ then return (LOp op args)

137+ else Nothing

138+ _ -> Nothing

139+

132140declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x

133141declArgs args inl n x = LFun (if inl then [Inline] else []) n args x

134142

@@ -180,15 +188,24 @@ instance ToIR (TT Name) where

180188 = irCon env t a n args

181189 | (P _ n _, args) <- unApply tm

182190 = do i <- get

183− let collapse = case lookupCtxt Nothing n (idris_optimisation i) of

184− [oi] -> collapsible oi

185− _ -> False

186− let unused = case lookupCtxt Nothing n (idris_callgraph i) of

187− [CGInfo _ _ _ _ unusedpos] -> unusedpos

188− _ -> []

189191 args' <- mapM (ir' env) args

190− if collapse then return LNothing

191− else return (LApp False (LV (Glob n))

192+ case getPrim i n args' of

193+ Just tm -> return tm

194+ _ -> do

195+ let collapse

196+ = case lookupCtxt Nothing n

197+ (idris_optimisation i) of

198+ [oi] -> collapsible oi

199+ _ -> False

200+ let unused

201+ = case lookupCtxt Nothing n

202+ (idris_callgraph i) of

203+ [CGInfo _ _ _ _ unusedpos] ->

204+ unusedpos

205+ _ -> []

206+ if collapse

207+ then return LNothing

208+ else return (LApp False (LV (Glob n))

192209 (mkUnused unused 0 args'))

193210 | (f, args) <- unApply tm

194211 = do f' <- ir' env f

src/IRTS/Defunctionalise.hs+11−4

@@ -15,6 +15,7 @@ data DExp = DV LVar

1515 | DProj DExp Int

1616 | DC Int Name [DExp]

1717 | DCase DExp [DAlt]

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

1819 | DConst Const

1920 | DForeign FLang FType String [(FType, DExp)]

2021 | DOp PrimFn [DExp]

@@ -132,6 +133,10 @@ addApps defs (n, LFun _ _ args e) = (n, DFun n args (aa args e))

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

133134 nec (DConstCase _ e) = needsEval x e

134135 nec (DDefaultCase e) = needsEval x e

136+ needsEval x (DChkCase e alts) = needsEval x e || or (map nec alts)

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

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

139+ nec (DDefaultCase e) = needsEval x e

135140 needsEval x (DLet n v e)

136141 | x == n = needsEval x v

137142 | otherwise = needsEval x v || needsEval x e

@@ -213,6 +218,8 @@ instance Show DExp where

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

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

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

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

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

216223 show' env (DConst c) = show c

217224 show' env (DForeign lang ty n args)

218225 = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"

@@ -230,8 +237,8 @@ instance Show DExp where

230237-- 'max' branches

231238

232239mkBigCase cn max arg branches

233− | length branches <= max = DCase arg branches

234− | otherwise = -- DCase arg branches -- until I think of something...

240+ | length branches <= max = DChkCase arg branches

241+ | otherwise = -- DChkCase arg branches -- until I think of something...

235242 -- divide the branches into groups of at most max (by tag),

236243 -- generate a new case and shrink, recursively

237244 let bs = sortBy tagOrd branches

@@ -240,9 +247,9 @@ mkBigCase cn max arg branches

240247 _ -> (all, Nothing)

241248 bss = groupsOf max all

242249 cs = map mkCase bss in

243− DCase arg branches

250+ DChkCase arg branches

244251

245− where mkCase bs = DCase arg bs

252+ where mkCase bs = DChkCase arg bs

246253

247254 tagOrd (DConCase t _ _ _) (DConCase t' _ _ _) = compare t t'

248255 tagOrd (DConstCase c _) (DConstCase c' _) = compare c c'

src/IRTS/DumpBC.hs+1−1

@@ -37,7 +37,7 @@ serializeBC n bc = indent n ++

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

3838 MKCON a b xs ->

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

40− CASE r cases def ->

40+ CASE safe r cases def ->

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

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

4343 PROJECT a b c ->

src/IRTS/Lang.hs+1−1

@@ -33,7 +33,7 @@ data PrimFn = LPlus | LMinus | LTimes | LDiv | LMod

3333 | LEq | LLt | LLe | LGt | LGe

3434 | LFPlus | LFMinus | LFTimes | LFDiv

3838 | LStrConcat | LStrLt | LStrEq | LStrLen

src/IRTS/Simplified.hs+12

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

1616 | SUpdate LVar SExp

1717 | SCon Int Name [LVar]

1818 | SCase LVar [SAlt]

19+ | SChkCase LVar [SAlt]

1920 | SProj LVar Int

2021 | SConst Const

2122 | SForeign FLang FType String [(FType, LVar)]

@@ -72,6 +73,13 @@ simplify tl (DCase e alts) = do v <- sVar e

7273 (x, Nothing) -> return (SCase x alts')

7374 (Glob x, Just e) ->

7475 return (SLet (Glob x) e (SCase (Glob x) alts'))

76+simplify tl (DChkCase e alts)

77+ = do v <- sVar e

78+ alts' <- mapM (sAlt tl) alts

79+ case v of

80+ (x, Nothing) -> return (SChkCase x alts')

81+ (Glob x, Just e) ->

82+ return (SLet (Glob x) e (SChkCase (Glob x) alts'))

7583simplify tl (DConst c) = return (SConst c)

7684simplify tl (DOp p args) = do args' <- mapM sVar args

7785 mkapp (SOp p) args'

@@ -166,6 +174,10 @@ scopecheck ctxt envTop tm = sc envTop tm where

166174 = do e' <- scVar env e

167175 alts' <- mapM (scalt env) alts

168176 return (SCase e' alts')

177+ sc env (SChkCase e alts)

178+ = do e' <- scVar env e

179+ alts' <- mapM (scalt env) alts

180+ return (SChkCase e' alts')

169181 sc env (SLet (Glob n) v e)

170182 = do let env' = env ++ [(n, length env)]

171183 v' <- sc env v