c02a58c · Idris-dev · git.iko.soy

lib/io.idr+3

compare with master

unifiedsplit

@@ -47,4 +47,7 @@ mkForeign : Foreign x -> x

47mkLazyForeign : Foreign x -> x

48-- mkForeign and mkLazyForeign compiled as primitives

49

50+fork : |(thread:IO ()) -> IO Ptr

51+fork x = io_return prim__vm -- compiled specially

52+

50

53

rts/idris_main.c+1

@@ -5,4 +5,5 @@ int main(int argc, char* argv[]) {

5#ifdef IDRIS_TRACE

6 gcInfo(vm, 1);

7#endif

8+ terminate(vm);

8}

9}

rts/idris_rts.c+155

@@ -3,6 +3,8 @@

3#include <string.h>

4#include <unistd.h>

5#include <stdarg.h>

6+#include <assert.h>

7+#include <pthread.h>

6

8

7#include "idris_rts.h"

9#include "idris_rts.h"

8#include "idris_gc.h"

10#include "idris_gc.h"

@@ -31,9 +33,32 @@ VM* init_vm(int stack_size, size_t heap_size) {

31 vm -> heap_growth = heap_size;

33 vm -> heap_growth = heap_size;

32 vm -> ret = NULL;

34 vm -> ret = NULL;

33 vm -> reg1 = NULL;

35 vm -> reg1 = NULL;

36+

37+ vm -> inbox = malloc(1024*sizeof(VAL));

38+ vm -> inbox_end = vm -> inbox + 1024;

39+ vm -> inbox_ptr = vm -> inbox;

40+ vm -> inbox_write = vm -> inbox;

41+

42+ pthread_mutex_init(&(vm -> inbox_lock), NULL);

43+ pthread_mutex_init(&(vm -> inbox_block), NULL);

44+ pthread_cond_init(&(vm -> inbox_waiting), NULL);

45+

34 return vm;

46 return vm;

35}

47}

36

48

49+void terminate(VM* vm) {

50+ free(vm->inbox);

51+ free(vm->valstack);

52+ free(vm->intstack);

53+ free(vm->floatstack);

54+ free(vm->heap);

55+ if (vm->oldheap != NULL) { free(vm->oldheap); }

56+ pthread_mutex_destroy(&(vm -> inbox_lock));

57+ pthread_mutex_destroy(&(vm -> inbox_block));

58+ pthread_cond_destroy(&(vm -> inbox_waiting));

59+ free(vm);

60+}

61+

37void* allocate(VM* vm, size_t size) {

62void* allocate(VM* vm, size_t size) {

38// return malloc(size);

63// return malloc(size);

39 if ((size & 7)!=0) {

64 if ((size & 7)!=0) {

@@ -305,6 +330,136 @@ VAL idris_strRev(VM* vm, VAL str) {

305 return cl;

330 return cl;

306}

331}

307

332

333+typedef struct {

334+ VM* vm;

335+ func fn;

336+ VAL arg;

337+} ThreadData;

338+

339+void* runThread(void* arg) {

340+ ThreadData* td = (ThreadData*)arg;

341+ VM* vm = td->vm;

342+

343+ printf("We're off\n");

344+

345+ TOP(0) = td->arg;

346+ BASETOP(0);

347+ ADDTOP(1);

348+ td->fn(vm, NULL);

349+

350+ printf("We're done\n");

351+ free(td);

352+}

353+

354+void* vmThread(VM* callvm, func f, VAL arg) {

355+ VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap_size);

356+ pthread_t t;

357+ pthread_attr_t attr;

358+ size_t stacksize;

359+

360+ pthread_attr_init(&attr);

361+ pthread_attr_getstacksize (&attr, &stacksize);

362+ pthread_attr_setstacksize (&attr, stacksize*64);

363+ printf("Default stack size = %li\n", stacksize);

364+

365+ ThreadData *td = malloc(sizeof(ThreadData));

366+ td->vm = vm;

367+ td->fn = f;

368+ td->arg = copyTo(vm, arg);

369+

370+ dumpVal(arg);

371+ dumpVal(td->arg);

372+

373+ printf("Threading\n");

374+ pthread_create(&t, &attr, runThread, td);

375+ return vm;

376+}

377+

378+// VM is assumed to be a different vm from the one x lives on (so we don't need

379+// to worry about gc moving things, as the VM x is on will not be allocating)

380+

381+VAL copyTo(VM* vm, VAL x) {

382+ int i;

383+ VAL* argptr;

384+ Closure* cl;

385+ if (x==NULL || ISINT(x)) {

386+ return x;

387+ }

388+ switch(x->ty) {

389+ case CON:

390+ cl = allocCon(vm, x->info.c.arity);

391+ cl->info.c.tag = x->info.c.tag;

392+ cl->info.c.arity = x->info.c.arity;

393+

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

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

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

397+ argptr++;

398+ }

399+ break;

400+ case FLOAT:

401+ cl = MKFLOAT(vm, x->info.f);

402+ break;

403+ case STRING:

404+ cl = MKSTR(vm, x->info.str);

405+ break;

406+ case BIGINT:

407+ cl = MKBIGM(vm, x->info.ptr);

408+ break;

409+ case PTR:

410+ cl = MKPTR(vm, x->info.ptr);

411+ break;

412+ case FWD:

413+ assert(0); // We're in trouble if this happens...

414+ return x->info.ptr;

415+ }

416+ return cl;

417+}

418+

419+// Add a message to another VM's message queue

420+void sendMessage(VM* sender, VM* dest, VAL msg) {

421+ VAL dmsg = copyTo(dest, msg);

422+ pthread_mutex_lock(&(dest->inbox_lock));

423+

424+ *(dest->inbox_write) = dmsg;

425+

426+ dest->inbox_write++;

427+ if (dest->inbox_write >= dest->inbox_end) {

428+ dest->inbox_write = dest->inbox;

429+ }

430+

431+ if (dest->inbox_write == dest->inbox_ptr) {

432+ fprintf(stderr, "Inbox full"); // Maybe grow it instead...

433+ exit(-1);

434+ }

435+

436+ // Wake up the other thread

437+ pthread_cond_signal(&(dest->inbox_waiting));

438+

439+ pthread_mutex_unlock(&(dest->inbox_lock));

440+}

441+

442+// block until there is a message in the queue

443+VAL recvMessage(VM* vm) {

444+ pthread_mutex_lock(&vm->inbox_block);

445+ pthread_cond_wait(&vm->inbox_waiting, &vm->inbox_block);

446+

447+ VAL msg = *(vm->inbox_ptr);

448+ if (msg != NULL) {

449+ pthread_mutex_lock(&(vm->inbox_lock));

450+ *(vm->inbox_ptr) = NULL;

451+ vm->inbox_ptr++;

452+ if (vm->inbox_ptr >= vm->inbox_end) {

453+ vm->inbox_ptr = vm->inbox;

454+ }

455+ pthread_mutex_unlock(&(vm->inbox_lock));

456+ } else {

457+ fprintf(stderr, "No messages waiting");

458+ exit(-1);

459+ }

460+

461+ pthread_mutex_unlock(&vm->inbox_block);

462+}

308

463

309void stackOverflow() {

464void stackOverflow() {

310 fprintf(stderr, "Stack overflow");

465 fprintf(stderr, "Stack overflow");

rts/idris_rts.h+26−1

@@ -6,11 +6,12 @@

6#include <string.h>

7#include <unistd.h>

8#include <stdarg.h>

9+#include <pthread.h>

9

10

10// Closures

11// Closures

11

12

12typedef enum {

13typedef enum {

13− CON, INT, BIGINT, FLOAT, STRING, UNIT, PTR, FWD

14+ CON, INT, BIGINT, FLOAT, STRING, UNIT, PTR, MSG, FWD

14} ClosureType;

15} ClosureType;

15

16

16typedef struct {

17typedef struct {

@@ -45,6 +46,17 @@ typedef struct {

45 char* heap_next;

46 char* heap_next;

46 char* heap_end;

47 char* heap_end;

47 VAL* stack_max;

48 VAL* stack_max;

49+

50+ pthread_mutex_t inbox_lock;

51+ pthread_mutex_t inbox_block;

52+ pthread_cond_t inbox_waiting;

53+

54+ VAL* inbox; // Block of memory for storing messages

55+ VAL* inbox_end; // End of block of memory

56+

57+ VAL* inbox_ptr; // Next message to read

58+ VAL* inbox_write; // Location of next message to write

59+

48 size_t heap_size;

60 size_t heap_size;

49 size_t heap_growth;

61 size_t heap_growth;

50 int allocations;

62 int allocations;

@@ -53,7 +65,10 @@ typedef struct {

53 VAL reg1;

65 VAL reg1;

54} VM;

66} VM;

55

67

68+// Create a new VM

56VM* init_vm(int stack_size, size_t heap_size);

69VM* init_vm(int stack_size, size_t heap_size);

70+// Clean up a VM once it's no longer needed

71+void terminate(VM* vm);

57

72

58// Functions all take a pointer to their VM, and previous stack base,

73// Functions all take a pointer to their VM, and previous stack base,

59// and return nothing.

74// and return nothing.

@@ -118,6 +133,16 @@ void SLIDE(VM* vm, int args);

118void* allocate(VM* vm, size_t size);

133void* allocate(VM* vm, size_t size);

119void* allocCon(VM* vm, int arity);

134void* allocCon(VM* vm, int arity);

120

135

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

137+

138+// Copy a structure to another vm's heap

139+VAL copyTo(VM* newVM, VAL x);

140+

141+// Add a message to another VM's message queue

142+void sendMessage(VM* sender, VM* dest, VAL msg);

143+// block until there is a message in the queue

144+VAL recvMessage(VM* vm);

145+

121void dumpVal(VAL r);

146void dumpVal(VAL r);

122void dumpStack(VM* vm);

147void dumpStack(VM* vm);

123

148

src/IRTS/CodegenC.hs+3−1

@@ -44,7 +44,7 @@ codegenC defs out exec incs objs libs dbg

44 gccDbg dbg ++

45 " " ++ tmpn ++

46 " `idris --link` `idris --include` " ++ libs ++

47− " -lidris_rts -lgmp -o " ++ out

47+ " -o " ++ out

48 -- putStrLn cout

49 exit <- system gcc

50 when (exit /= ExitSuccess) $

@@ -237,5 +237,7 @@ doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"

237doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"

238doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"

239

240+doOp v LFork [x] = v ++ "vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ ")"

241+doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

240doOp v LNoOp [x] = ""

242doOp v LNoOp [x] = ""

241doOp _ _ _ = "FAIL"

243doOp _ _ _ = "FAIL"

src/IRTS/Compiler.hs+3

@@ -114,6 +114,9 @@ instance ToIR (TT Name) where

114 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm

115 = do arg' <- ir' env arg

116 return $ LLazyExp arg'

117+ | (P _ (UN "fork") _, [arg]) <- unApply tm

118+ = do arg' <- ir' env arg

119+ return $ LOp LFork [LLazyExp arg']

117 | (P _ (UN "prim__IO") _, [v]) <- unApply tm

120 | (P _ (UN "prim__IO") _, [v]) <- unApply tm

118 = do v' <- ir' env v

121 = do v' <- ir' env v

119 return v'

122 return v'

src/IRTS/Defunctionalise.hs+1

@@ -63,6 +63,7 @@ addApps defs (n, LFun _ args e) = (n, LFun n args (aa args e))

63 aa env (LCase e alts) = LCase (eEVAL (aa env e)) (map (aaAlt env) alts)

64 aa env (LConst c) = LConst c

65 aa env (LForeign l t n args) = LForeign l t n (map (aaF env) args)

66+ aa env (LOp LFork args) = LOp LFork (map (aa env) args)

66 aa env (LOp f args) = LOp f (map (eEVAL . (aa env)) args)

67 aa env (LOp f args) = LOp f (map (eEVAL . (aa env)) args)

67 aa env (LError e) = LError e

68 aa env (LError e) = LError e

68

69

src/IRTS/Lang.hs+1−1

@@ -36,7 +36,7 @@ data PrimFn = LPlus | LMinus | LTimes | LDiv | LEq | LLt | LLe | LGt | LGe

36

38 | LStdIn | LStdOut | LStdErr

39− | LNoOp

39+ | LFork | LVMPtr | LNoOp

40 deriving (Show, Eq)

41

42-- Supported target languages for foreign calls

src/Idris/Primitives.hs+2

@@ -163,6 +163,8 @@ primitives =

163 (1, LStrRev) total,

164 Prim (UN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)

165 (1, LReadStr) partial,

166+ Prim (UN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

167+ (0, LVMPtr) total,

166 -- Streams

168 -- Streams

167 Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

169 Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

168 (0, LStdIn) partial,

170 (0, LStdIn) partial,

src/Main.hs+1−1

@@ -130,7 +130,7 @@ showver = do putStrLn $ "Idris version " ++ ver

130 exitWith ExitSuccess

131

132showLibs = do dir <- getDataDir

133− putStrLn $ "-L" ++ dir ++ "/rts -lidris_rts"

133+ putStrLn $ "-L" ++ dir ++ "/rts -lidris_rts -lgmp -lpthread"

134 exitWith ExitSuccess

135

136showIncs = do dir <- getDataDir

src/Util/System.hs+1−1

@@ -21,7 +21,7 @@ tempfile = do env <- environment "TMPDIR"

21 let dir = case env of

22 Nothing -> "/tmp"

23 (Just d) -> d

24− openTempFile dir "esc"

24+ openTempFile dir "idris"

25

26environment :: String -> IO (Maybe String)

27environment x = catchIO (do e <- getEnv x