7245290 · Idris-dev · git.iko.soy

rts/Makefile+1−1

compare with master

unifiedsplit

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

2

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

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

5−CFLAGS = -O2 -Wall -Werror

5+CFLAGS = -O2 -Wall

6ifneq ($(GMP_INCLUDE_DIR),)

7 CFLAGS += -isystem $(GMP_INCLUDE_DIR)

8endif

rts/idris_gc.c+7−7

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

3#include <assert.h>

4

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

6− int i;

6+ int i, ar;

7 Closure* cl = NULL;

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

9 return x;

10 }

11 switch(GETTY(x)) {

12 case CON:

13+ ar = CARITY(x);

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

14+ allocCon(cl, vm, CTAG(x), ar, 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) {

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

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

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

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

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

20 }

18 }

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

43

41

44void cheney(VM *vm) {

42void cheney(VM *vm) {

45 int i;

43 int i;

44+ int ar;

46 char* scan = vm->heap;

45 char* scan = vm->heap;

47

46

48 while(scan < vm->heap_next) {

47 while(scan < vm->heap_next) {

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

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

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

52 switch(GETTY(heap_item)) {

51 switch(GETTY(heap_item)) {

53 case CON:

52 case CON:

53+ ar = ARITY(heap_item);

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

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

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

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

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

rts/idris_main.c+1−1

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

1int 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);

3 _idris__123_runMain0_125_(vm, NULL);

4 //_idris_main(vm, NULL);

5#ifdef IDRIS_TRACE

rts/idris_rts.c+8−26

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

107

108}

109

110+/* Now a macro

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

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

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

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

112 outer);

113 outer);

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

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

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

118 return (void*)cl;

119 return (void*)cl;

119}

120}

121+*/

120

122

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

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

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

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

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

166 return cl;

168 return cl;

167}

169}

168

170

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−

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

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

189 int i;

172 int i;

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

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

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

223 }

206 }

224 switch(GETTY(v)) {

207 switch(GETTY(v)) {

225 case CON:

208 case CON:

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

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

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

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

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

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

229 }

212 }

230 printf("] ");

213 printf("] ");

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

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

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

433

416

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

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

435− int i;

418+ int i, ar;

436 VAL* argptr;

419 VAL* argptr;

437 Closure* cl;

420 Closure* cl;

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

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

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

440 }

423 }

441 switch(GETTY(x)) {

424 switch(GETTY(x)) {

442 case CON:

425 case CON:

426+ ar = CARITY(x);

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

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

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

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

446

428

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

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

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

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

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

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

450 argptr++;

432 argptr++;

451 }

433 }

rts/idris_rts.h+14−8

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

17typedef struct Closure *VAL;

18

19typedef struct {

20− int tag;

20+ int tag_arity;

21− int arity;

22 VAL args[];

21 VAL args[];

23} con;

22} con;

24

23

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

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

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

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

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

103

102

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)

105

109

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

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

107// Bottom 16 bits for closure type

111// Bottom 16 bits for closure type

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

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

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

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

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

138#define STOREOLD myoldbase = vm->valstack_base

142#define STOREOLD myoldbase = vm->valstack_base

139−

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

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

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

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

142

145

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

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

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

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

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

152

155

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)

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

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

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

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

158

159

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

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

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

161

162

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

163void* 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);

164

170

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

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

166

172

src/Core/Evaluate.hs+3−3

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

196 wknV (-1) sc'

197− | otherwise

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

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

203 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') -}

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

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

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

src/IRTS/Bytecode.hs+7−4

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

29 | ASSIGNCONST Reg Const

30 | UPDATE Reg Reg

31 | MKCON Reg Int [Reg]

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

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

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

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

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

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

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

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

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

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

85bc reg SNothing r = NULL reg : clean r

86bc reg SNothing r = NULL reg : clean r

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

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

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

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

89

92

90isConst [] = False

93isConst [] = False

91isConst (SConstCase _ _ : xs) = True

94isConst (SConstCase _ _ : xs) = True

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

98assign r1 r2 | r1 == r2 = []

101assign r1 r2 | r1 == r2 = []

99 | otherwise = [ASSIGN r1 r2]

102 | otherwise = [ASSIGN r1 r2]

100

103

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

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

102− (defaultAlt reg xs r)]

105+ (defaultAlt reg xs r)]

103

106

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

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

105 (defaultAlt reg xs r)]

108 (defaultAlt reg xs r)]

src/IRTS/CodegenC.hs+10−4

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

108 mkConst _ = "MKINT(42424242)"

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

110bcc i (MKCON l tag args)

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

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

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

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

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

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

115

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

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

125bcc i (PROJECTINTO r t idx)

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

127−bcc i (CASE r code def)

127+bcc i (CASE safe r code def)

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

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

129 concatMap (showCase i) code ++

130 showDef i def ++

131 indent i ++ "}\n"

132 where

133+ ctag True = "CTAG"

134+ ctag False = "TAG"

135+

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

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

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

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

135 showDef i Nothing = ""

138 showDef i Nothing = ""

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

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

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

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

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

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

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

186+bcc i (RESERVE 0) = ""

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

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

188+bcc i (ADDTOP 0) = ""

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

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

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

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

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

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

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

240

245

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

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

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

247doOp 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))"

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

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

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

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

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

251doOp 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)

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

130 return (n, def)

131

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+

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

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

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

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

134

142

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

180 = irCon env t a n args

188 = irCon env t a n args

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

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

182 = do i <- get

190 = 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− _ -> []

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

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

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

190− if collapse then return LNothing

207+ then return LNothing

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

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

192 (mkUnused unused 0 args'))

209 (mkUnused unused 0 args'))

193 | (f, args) <- unApply tm

210 | (f, args) <- unApply tm

194 = do f' <- ir' env f

211 = do f' <- ir' env f

src/IRTS/Defunctionalise.hs+11−4

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

15 | DProj DExp Int

16 | DC Int Name [DExp]

17 | DCase DExp [DAlt]

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

18 | DConst Const

19 | DConst Const

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

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

20 | DOp PrimFn [DExp]

21 | DOp PrimFn [DExp]

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

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

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

133 nec (DConstCase _ e) = needsEval x e

134 nec (DConstCase _ e) = needsEval x e

134 nec (DDefaultCase e) = needsEval x e

135 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

135 needsEval x (DLet n v e)

140 needsEval x (DLet n v e)

136 | x == n = needsEval x v

141 | x == n = needsEval x v

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

142 | otherwise = needsEval x v || needsEval x e

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

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

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

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

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

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

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

216 show' env (DConst c) = show c

223 show' env (DConst c) = show c

217 show' env (DForeign lang ty n args)

224 show' env (DForeign lang ty n args)

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

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

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

230-- 'max' branches

237-- 'max' branches

231

238

232mkBigCase cn max arg branches

239mkBigCase cn max arg branches

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

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

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

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

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

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

236 -- generate a new case and shrink, recursively

243 -- generate a new case and shrink, recursively

237 let bs = sortBy tagOrd branches

244 let bs = sortBy tagOrd branches

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

240 _ -> (all, Nothing)

247 _ -> (all, Nothing)

241 bss = groupsOf max all

248 bss = groupsOf max all

242 cs = map mkCase bss in

249 cs = map mkCase bss in

243− DCase arg branches

250+ DChkCase arg branches

244

251

245− where mkCase bs = DCase arg bs

252+ where mkCase bs = DChkCase arg bs

246

253

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

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

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

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

src/IRTS/DumpBC.hs+1−1

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

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

38 MKCON a b xs ->

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

40− CASE r cases def ->

40+ CASE safe r cases def ->

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

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

43 PROJECT a b c ->

src/IRTS/Lang.hs+1−1

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

33 | LEq | LLt | LLe | LGt | LGe

34 | LFPlus | LFMinus | LFTimes | LFDiv

38 | LStrConcat | LStrLt | LStrEq | LStrLen

src/IRTS/Simplified.hs+12

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

16 | SUpdate LVar SExp

17 | SCon Int Name [LVar]

18 | SCase LVar [SAlt]

19+ | SChkCase LVar [SAlt]

19 | SProj LVar Int

20 | SProj LVar Int

20 | SConst Const

21 | SConst Const

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

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

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

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

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

73 (Glob x, Just e) ->

74 (Glob x, Just e) ->

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

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

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

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

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

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

77 mkapp (SOp p) args'

85 mkapp (SOp p) args'

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

166 = do e' <- scVar env e

174 = do e' <- scVar env e

167 alts' <- mapM (scalt env) alts

175 alts' <- mapM (scalt env) alts

168 return (SCase e' alts')

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

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

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

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

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

171 v' <- sc env v

183 v' <- sc env v