9540f1a · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

RTS tweaks

Changed GC parameters, and changed implementations of PROJECT and SLIDE to move memory in one go. This makes things a lot quicker, at least for relatively small programs, but we really need a better GC (perhaps generational?) to get the big wins.

commit9540f1a36c284af14d3f8ee74fbf2b7cc61d9b7d authorEdwin Brady <ecb10@st-andrews.ac.uk> dateThu 5 May 2016, 20:34 (10 years ago) parent57c0a61

6 files changed+41−24

compare with master

unifiedsplit

rts/idris_gc.c+2−4 rts/idris_main.c+1−1 rts/idris_rts.c−14 rts/idris_rts.h+4−2 src/IRTS/Defunctionalise.hs+33−2 src/Idris/Parser.hs+1−1

rts/idris_gc.c+2−4

@@ -4,7 +4,7 @@

44#include <assert.h>

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

7− int i, ar;

7+ int ar;

88 Closure* cl = NULL;

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

1010 return x;

@@ -16,9 +16,7 @@ VAL copy(VM* vm, VAL x) {

1616 return x;

1717 } else {

1818 allocCon(cl, vm, CTAG(x), ar, 1);

19− for(i = 0; i < ar; ++i) {

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

21− }

19+ memcpy(&(cl->info.c.args), &(x->info.c.args), sizeof(VAL)*ar);

2220 }

2321 break;

2422 case CT_FLOAT:

rts/idris_main.c+1−1

@@ -4,7 +4,7 @@

44#include "idris_gmp.h"

55// The default options should give satisfactory results under many circumstances.

66RTSOpts opts = {

7− .init_heap_size = 4096000,

7+ .init_heap_size = 16384000,

88 .max_stack_size = 4096000,

99 .show_summary = 0

1010};

rts/idris_rts.c−14

@@ -391,20 +391,6 @@ VAL MKB64(VM* vm, uint64_t bits64) {

391391 return cl;

392392}

393393

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

395− int i;

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

397− LOC(i+loc) = r->info.c.args[i];

398− }

399−}

400−

401−void SLIDE(VM* vm, int args) {

402− int i;

403− for(i = 0; i < args; ++i) {

404− LOC(i) = TOP(i);

405− }

406−}

407−

408394void dumpStack(VM* vm) {

409395 int i = 0;

410396 VAL* root;

rts/idris_rts.h+4−2

@@ -259,8 +259,10 @@ char* GETSTROFF(VAL stroff);

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

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

261261

262−void PROJECT(VM* vm, VAL r, int loc, int arity);

263−void SLIDE(VM* vm, int args);

262+#define PROJECT(vm,r,loc,num) \

263+ memcpy(&(LOC(loc)), &((r)->info.c.args), sizeof(VAL)*num)

264+#define SLIDE(vm, args) \

265+ memcpy(&(LOC(0)), &(TOP(0)), sizeof(VAL)*args)

264266

265267void* allocate(size_t size, int outerlock);

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

src/IRTS/Defunctionalise.hs+33−2

@@ -51,8 +51,9 @@ defunctionalise nexttag defs

5151 newacons = sortBy conord $ concatMap (toConsA anames') (getFn all)

5252 eval = mkEval newecons

5353 app = mkApply newacons

54+ app2 = mkApply2 newacons

5455 condecls = declare nexttag (newecons ++ newacons) in

55− addAlist (eval : app : condecls ++ allD) emptyContext

56+ addAlist (eval : app : app2 : condecls ++ allD) emptyContext

5657 where conord (n, _, _) (n', _, _) = compare n n'

5758

5859getFn :: [(Name, LDecl)] -> [(Name, Int)]

@@ -152,6 +153,8 @@ addApps defs (n, LFun _ _ args e)

152153 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)

153154

154155 chainAPPLY f [] = f

156+-- chainAPPLY f (a : b : as)

157+-- = chainAPPLY (DApp False (sMN 0 "APPLY2") [f, a, b]) as

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

156159

157160 -- if anything in the DExp is projected from, we'll need to evaluate it,

@@ -184,6 +187,7 @@ eEVAL x = DApp False (sMN 0 "EVAL") [x]

184187

185188data EvalApply a = EvalCase (Name -> a)

186189 | ApplyCase a

190+ | Apply2Case a

187191

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

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

@@ -219,7 +223,15 @@ mkApplyCase fname n ar

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

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

221225 [sMN 0 "arg"])))))

222− : mkApplyCase fname (n + 1) ar

226+ :

227+ if (ar - (n + 2) >=0 )

228+ then (nm, n, Apply2Case (DConCase (-1) nm (take n (genArgs 0))

229+ (DApp False (mkUnderCon fname (ar - (n + 2)))

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

231+ [sMN 0 "arg0", sMN 0 "arg1"])))))

232+ :

233+ mkApplyCase fname (n + 1) ar

234+ else mkApplyCase fname (n + 1) ar

223235

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

225237mkEval xs = (sMN 0 "EVAL", DFun (sMN 0 "EVAL") [sMN 0 "arg"]

@@ -243,6 +255,25 @@ mkApply xs = (sMN 0 "APPLY", DFun (sMN 0 "APPLY") [sMN 0 "fn", sMN 0 "arg"]

243255 applyCase (n, t, ApplyCase x) = Just x

244256 applyCase _ = Nothing

245257

258+mkApply2 :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

259+mkApply2 xs = (sMN 0 "APPLY2", DFun (sMN 0 "APPLY2") [sMN 0 "fn", sMN 0 "arg0", sMN 0 "arg1"]

260+ (case mapMaybe applyCase xs of

261+ [] -> DNothing

262+ cases ->

263+ mkBigCase (sMN 0 "APPLY") 256

264+ (DV (Glob (sMN 0 "fn")))

265+ (cases ++

266+ [DDefaultCase

267+ (DApp False (sMN 0 "APPLY")

268+ [DApp False (sMN 0 "APPLY")

269+ [DV (Glob (sMN 0 "fn")),

270+ DV (Glob (sMN 0 "arg0"))],

271+ DV (Glob (sMN 0 "arg1"))])

272+ ])))

273+ where

274+ applyCase (n, t, Apply2Case x) = Just x

275+ applyCase _ = Nothing

276+

246277

247278declare :: Int -> [(Name, Int, EvalApply DAlt)] -> [(Name, DDecl)]

248279declare t xs = dec' t xs [] where

src/Idris/Parser.hs+1−1

@@ -1013,7 +1013,7 @@ usingDecl syn = try (do x <- fst <$> fnName

10131013 t <- typeExpr (disallowImp syn)

10141014 return (UImplicit x t))

10151015 <|> do c <- fst <$> fnName

1016− xs <- some (fst <$> fnName)

1016+ xs <- many (fst <$> fnName)

10171017 return (UConstraint c xs)

10181018 <?> "using declaration"

10191019