c8c5b17 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge pull request #1813 from mattias-lundell/master

c8c5b17Edwin Brady12 years ago

rts/idris_bitstring.c+28

compare with master

unifiedsplit

@@ -820,3 +820,31 @@ VAL idris_b64T32(VM *vm, VAL a) {

820 return cl;

821}

822

823+// SSE vectors

824+VAL idris_IDXB8x16(VM* vm, VAL vec, VAL idx) {

825+ __m128i sse = *vec->info.bits128p;

826+ uint8_t data[16];

827+ _mm_storeu_si128((__m128i*)&data, sse);

828+ return MKB8(vm, data[idx->info.bits32]);

829+}

830+

831+VAL idris_IDXB16x8(VM* vm, VAL vec, VAL idx) {

832+ __m128i sse = *vec->info.bits128p;

833+ uint16_t data[8];

834+ _mm_storeu_si128((__m128i*)&data, sse);

835+ return MKB16(vm, data[idx->info.bits32]);

836+}

837+

838+VAL idris_IDXB32x4(VM* vm, VAL vec, VAL idx) {

839+ __m128i sse = *vec->info.bits128p;

840+ uint32_t data[4];

841+ _mm_storeu_si128((__m128i*)&data, sse);

842+ return MKB32(vm, data[idx->info.bits32]);

843+}

844+

845+VAL idris_IDXB64x2(VM* vm, VAL vec, VAL idx) {

846+ __m128i sse = *vec->info.bits128p;

847+ uint64_t data[2];

848+ _mm_storeu_si128((__m128i*)&data, sse);

849+ return MKB64(vm, data[idx->info.bits32]);

850+}

rts/idris_bitstring.h+5

@@ -126,4 +126,9 @@ VAL idris_b64T8(VM *vm, VAL a);

126VAL idris_b64T16(VM *vm, VAL a);

127VAL idris_b64T32(VM *vm, VAL a);

128

129+VAL idris_IDXB8x16(VM* vm, VAL vec, VAL idx);

130+VAL idris_IDXB16x8(VM* vm, VAL vec, VAL idx);

131+VAL idris_IDXB32x4(VM* vm, VAL vec, VAL idx);

132+VAL idris_IDXB64x2(VM* vm, VAL vec, VAL idx);

133+

129#endif

134#endif

rts/idris_rts.c+162−23

@@ -21,7 +21,7 @@ void free_key(VM *vm) {

21 // nothing to free, we just used the VM pointer which is freed elsewhere

22}

24−VM* init_vm(int stack_size, size_t heap_size,

24+VM* init_vm(int stack_size, size_t heap_size,

25 int max_threads // not implemented yet

26 ) {

@@ -113,7 +113,7 @@ void idris_requireAlloc(size_t size) {

113#ifdef HAS_PTHREAD

114 int lock = vm->processes > 0;

115 if (lock) { // We only need to lock if we're in concurrent mode

116− pthread_mutex_lock(&vm->alloc_lock);

116+ pthread_mutex_lock(&vm->alloc_lock);

117 }

118#endif

119}

@@ -123,7 +123,7 @@ void idris_doneAlloc() {

123 VM* vm = pthread_getspecific(vm_key);

124 int lock = vm->processes > 0;

125 if (lock) { // We only need to lock if we're in concurrent mode

126− pthread_mutex_unlock(&vm->alloc_lock);

126+ pthread_mutex_unlock(&vm->alloc_lock);

127 }

128#endif

129}

@@ -153,7 +153,7 @@ void* allocate(size_t size, int outerlock) {

153 int lock = vm->processes > 0 && !outerlock;

154

155 if (lock) { // not message passing

156− pthread_mutex_lock(&vm->alloc_lock);

156+ pthread_mutex_lock(&vm->alloc_lock);

157 }

158#else

159 VM* vm = global_vm;

@@ -176,7 +176,7 @@ void* allocate(size_t size, int outerlock) {

176 memset(ptr, 0, size);

177#ifdef HAS_PTHREAD

178 if (lock) { // not message passing

179− pthread_mutex_unlock(&vm->alloc_lock);

179+ pthread_mutex_unlock(&vm->alloc_lock);

180 }

181#endif

182 return ptr;

@@ -184,7 +184,7 @@ void* allocate(size_t size, int outerlock) {

184 idris_gc(vm);

185#ifdef HAS_PTHREAD

186 if (lock) { // not message passing

187− pthread_mutex_unlock(&vm->alloc_lock);

187+ pthread_mutex_unlock(&vm->alloc_lock);

188 }

189#endif

190 return allocate(size, 0);

@@ -250,7 +250,7 @@ VAL MKMPTR(VM* vm, void* ptr, size_t size) {

250 SETTY(cl, MANAGEDPTR);

251 cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

252 cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

253− memcpy(cl->info.mptr->data, ptr, size);

253+ memcpy(cl->info.mptr->data, ptr, size);

254 cl->info.mptr->size = size;

255 return cl;

256}

@@ -285,7 +285,7 @@ VAL MKMPTRc(VM* vm, void* ptr, size_t size) {

285 SETTY(cl, MANAGEDPTR);

286 cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

287 cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

288− memcpy(cl->info.mptr->data, ptr, size);

288+ memcpy(cl->info.mptr->data, ptr, size);

289 cl->info.mptr->size = size;

290 return cl;

291}

@@ -318,6 +318,107 @@ VAL MKB64(VM* vm, uint64_t bits64) {

318 return cl;

319}

320

321+VAL MKB8x16const(VM* vm,

322+ uint8_t v0, uint8_t v1, uint8_t v2, uint8_t v3,

323+ uint8_t v4, uint8_t v5, uint8_t v6, uint8_t v7,

324+ uint8_t v8, uint8_t v9, uint8_t v10, uint8_t v11,

325+ uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15) {

326+ Closure* cl = allocate(sizeof(Closure) + sizeof(__m128i), 1);

327+ SETTY(cl, BITS8X16);

328+

329+ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);

330+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);

331+

332+ uint8_t data[16];

333+ data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3;

334+ data[4]=v4; data[5]=v5; data[6]=v6; data[7]=v7;

335+ data[8]=v8; data[9]=v9; data[10]=v10; data[11]=v11;

336+ data[12]=v12; data[13]=v13; data[14]=v14; data[15]=v15;

337+

338+ *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);

339+

340+ return cl;

341+}

342+

343+VAL MKB8x16(VM* vm,

344+ VAL v0, VAL v1, VAL v2, VAL v3,

345+ VAL v4, VAL v5, VAL v6, VAL v7,

346+ VAL v8, VAL v9, VAL v10, VAL v11,

347+ VAL v12, VAL v13, VAL v14, VAL v15) {

348+ return MKB8x16const(vm,

349+ v0->info.bits8, v1->info.bits8, v2->info.bits8, v3->info.bits8,

350+ v4->info.bits8, v5->info.bits8, v6->info.bits8, v7->info.bits8,

351+ v8->info.bits8, v9->info.bits8, v10->info.bits8, v11->info.bits8,

352+ v12->info.bits8, v13->info.bits8, v14->info.bits8, v15->info.bits8);

353+}

354+

355+VAL MKB16x8const(VM* vm,

356+ uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3,

357+ uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7) {

358+ Closure* cl = allocate(sizeof(Closure) + sizeof(__m128i), 1);

359+ SETTY(cl, BITS16X8);

360+

361+ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);

362+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);

363+

364+ uint16_t data[8];

365+ data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3;

366+ data[4]=v4; data[5]=v5; data[6]=v6; data[7]=v7;

367+

368+ *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);

369+ return cl;

370+

371+}

372+

373+VAL MKB16x8(VM* vm,

374+ VAL v0, VAL v1, VAL v2, VAL v3,

375+ VAL v4, VAL v5, VAL v6, VAL v7) {

376+ return MKB16x8const(vm,

377+ v0->info.bits16, v1->info.bits16, v2->info.bits16, v3->info.bits16,

378+ v4->info.bits16, v5->info.bits16, v6->info.bits16, v7->info.bits16);

379+}

380+

381+VAL MKB32x4const(VM* vm,

382+ uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3) {

383+ Closure* cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);

384+ SETTY(cl, BITS64X2);

385+

386+ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);

387+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);

388+

389+ uint32_t data[4];

390+ data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3;

391+

392+ *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);

393+ return cl;

394+}

395+

396+VAL MKB32x4(VM* vm,

397+ VAL v0, VAL v1, VAL v2, VAL v3) {

398+ return MKB32x4const(vm,

399+ v0->info.bits32, v1->info.bits32, v2->info.bits32, v3->info.bits32);

400+}

401+

402+VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1) {

403+ Closure* cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);

404+ SETTY(cl, BITS64X2);

405+

406+ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);

407+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);

408+

409+ uint64_t data[2];

410+ data[0]=v0; data[1]=v1;

411+

412+ *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);

413+ return cl;

414+}

415+

416+VAL MKB64x2(VM* vm, VAL v0, VAL v1) {

417+ return MKB64x2const(vm,

418+ v0->info.bits64,

419+ v1->info.bits64);

420+}

421+

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

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

322 int i;

423 int i;

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

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

@@ -350,7 +451,7 @@ void dumpStack(VM* vm) {

350void dumpVal(VAL v) {

451void dumpVal(VAL v) {

351 if (v==NULL) return;

452 if (v==NULL) return;

352 int i;

453 int i;

353− if (ISINT(v)) {

454+ if (ISINT(v)) {

354 printf("%d ", (int)(GETINT(v)));

455 printf("%d ", (int)(GETINT(v)));

355 return;

456 return;

356 }

457 }

@@ -400,13 +501,51 @@ VAL idris_castIntStr(VM* vm, VAL i) {

400 return cl;

501 return cl;

401}

502}

402

503

504+VAL idris_castBitsStr(VM* vm, VAL i) {

505+ Closure* cl;

506+ ClosureType ty = i->ty;

507+

508+ switch (ty) {

509+ case BITS8:

510+ // max length 8 bit unsigned int str 3 chars (256)

511+ cl = allocate(sizeof(Closure) + sizeof(char)*4, 0);

512+ cl->info.str = (char*)cl + sizeof(Closure);

513+ sprintf(cl->info.str, "%" PRIu8, (uint8_t)i->info.bits8);

514+ break;

515+ case BITS16:

516+ // max length 16 bit unsigned int str 5 chars (65,535)

517+ cl = allocate(sizeof(Closure) + sizeof(char)*6, 0);

518+ cl->info.str = (char*)cl + sizeof(Closure);

519+ sprintf(cl->info.str, "%" PRIu16, (uint16_t)i->info.bits16);

520+ break;

521+ case BITS32:

522+ // max length 32 bit unsigned int str 10 chars (4,294,967,295)

523+ cl = allocate(sizeof(Closure) + sizeof(char)*11, 0);

524+ cl->info.str = (char*)cl + sizeof(Closure);

525+ sprintf(cl->info.str, "%" PRIu32, (uint32_t)i->info.bits32);

526+ break;

527+ case BITS64:

528+ // max length 64 bit unsigned int str 20 chars (18,446,744,073,709,551,615)

529+ cl = allocate(sizeof(Closure) + sizeof(char)*21, 0);

530+ cl->info.str = (char*)cl + sizeof(Closure);

531+ sprintf(cl->info.str, "%" PRIu64, (uint64_t)i->info.bits64);

532+ break;

533+ default:

534+ fprintf(stderr, "Fatal Error: ClosureType %d, not an integer type", ty);

535+ exit(EXIT_FAILURE);

536+ }

537+

538+ SETTY(cl, STRING);

539+ return cl;

540+}

541+

403VAL idris_castStrInt(VM* vm, VAL i) {

542VAL idris_castStrInt(VM* vm, VAL i) {

404 char *end;

543 char *end;

405 i_int v = strtol(GETSTR(i), &end, 10);

544 i_int v = strtol(GETSTR(i), &end, 10);

406− if (*end == '\0' || *end == '\n' || *end == '\r')

545+ if (*end == '\0' || *end == '\n' || *end == '\r')

407 return MKINT(v);

546 return MKINT(v);

408− else

547+ else

409− return MKINT(0);

548+ return MKINT(0);

410}

549}

411

550

412VAL idris_castFloatStr(VM* vm, VAL i) {

551VAL idris_castFloatStr(VM* vm, VAL i) {

@@ -430,7 +569,7 @@ VAL idris_concat(VM* vm, VAL l, VAL r) {

430 SETTY(cl, STRING);

569 SETTY(cl, STRING);

431 cl -> info.str = (char*)cl + sizeof(Closure);

570 cl -> info.str = (char*)cl + sizeof(Closure);

432 strcpy(cl -> info.str, ls);

571 strcpy(cl -> info.str, ls);

433− strcat(cl -> info.str, rs);

572+ strcat(cl -> info.str, rs);

434 return cl;

573 return cl;

435}

574}

436

575

@@ -840,7 +979,7 @@ void* runThread(void* arg) {

840}

979}

841

980

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

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

843− VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap.size,

982+ VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap.size,

844 callvm->max_threads);

983 callvm->max_threads);

845 vm->processes=1; // since it can send and receive messages

984 vm->processes=1; // since it can send and receive messages

846 pthread_t t;

985 pthread_t t;

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

856 td->callvm = callvm;

995 td->callvm = callvm;

857 td->fn = f;

996 td->fn = f;

858 td->arg = copyTo(vm, arg);

997 td->arg = copyTo(vm, arg);

859−

998+

860 callvm->processes++;

999 callvm->processes++;

861

1000

862 pthread_create(&t, &attr, runThread, td);

1001 pthread_create(&t, &attr, runThread, td);

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

864 return vm;

1003 return vm;

865}

1004}

866

1005

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

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

868

1007

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

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

870 int i, ar;

1009 int i, ar;

@@ -929,28 +1068,28 @@ void idris_sendMessage(VM* sender, VM* dest, VAL msg) {

929 // FIXME: If GC kicks in in the middle of the copy, we're in trouble.

1068 // FIXME: If GC kicks in in the middle of the copy, we're in trouble.

930 // Probably best check there is enough room in advance. (How?)

1069 // Probably best check there is enough room in advance. (How?)

931

1070

932− // Also a problem if we're allocating at the same time as the

1071+ // Also a problem if we're allocating at the same time as the

933 // destination thread (which is very likely)

1072 // destination thread (which is very likely)

934 // Should the inbox be a different memory space?

1073 // Should the inbox be a different memory space?

935−

1074+

936 // So: we try to copy, if a collection happens, we do the copy again

1075 // So: we try to copy, if a collection happens, we do the copy again

937 // under the assumption there's enough space this time.

1076 // under the assumption there's enough space this time.

938

1077

939 int gcs = dest->stats.collections;

1078 int gcs = dest->stats.collections;

940− pthread_mutex_lock(&dest->alloc_lock);

1079+ pthread_mutex_lock(&dest->alloc_lock);

941 VAL dmsg = copyTo(dest, msg);

1080 VAL dmsg = copyTo(dest, msg);

942− pthread_mutex_unlock(&dest->alloc_lock);

1081+ pthread_mutex_unlock(&dest->alloc_lock);

943

1082

944 if (dest->stats.collections > gcs) {

1083 if (dest->stats.collections > gcs) {

945 // a collection will have invalidated the copy

1084 // a collection will have invalidated the copy

946− pthread_mutex_lock(&dest->alloc_lock);

1085+ pthread_mutex_lock(&dest->alloc_lock);

947 dmsg = copyTo(dest, msg); // try again now there's room...

1086 dmsg = copyTo(dest, msg); // try again now there's room...

948− pthread_mutex_unlock(&dest->alloc_lock);

1087+ pthread_mutex_unlock(&dest->alloc_lock);

949 }

1088 }

950

1089

951 pthread_mutex_lock(&(dest->inbox_lock));

1090 pthread_mutex_lock(&(dest->inbox_lock));

952 *(dest->inbox_write) = dmsg;

1091 *(dest->inbox_write) = dmsg;

953−

1092+

954 dest->inbox_write++;

1093 dest->inbox_write++;

955 if (dest->inbox_write >= dest->inbox_end) {

1094 if (dest->inbox_write >= dest->inbox_end) {

956 dest->inbox_write = dest->inbox;

1095 dest->inbox_write = dest->inbox;

rts/idris_rts.h+42−14

@@ -10,6 +10,8 @@

10#endif

11#include <stdint.h>

13+#include <emmintrin.h>

14+

13#include "idris_heap.h"

15#include "idris_heap.h"

14#include "idris_stats.h"

16#include "idris_stats.h"

@@ -21,11 +23,11 @@

21#endif

23#endif

23// Closures

25// Closures

24−

25typedef enum {

26typedef enum {

26 CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

27 CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

27 BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,

28 BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,

28− MANAGEDPTR, BUFFER

29+ MANAGEDPTR, BUFFER, BITS8X16, BITS16X8, BITS32X4,

30+ BITS64X2

29} ClosureType;

31} ClosureType;

31typedef struct Closure *VAL;

33typedef struct Closure *VAL;

@@ -72,6 +74,7 @@ typedef struct Closure {

72 uint16_t bits16;

74 uint16_t bits16;

73 uint32_t bits32;

75 uint32_t bits32;

74 uint64_t bits64;

76 uint64_t bits64;

77+ __m128i* bits128p;

75 Buffer* buf;

78 Buffer* buf;

76 ManagedPtr* mptr;

79 ManagedPtr* mptr;

77 } info;

80 } info;

@@ -82,7 +85,7 @@ typedef struct {

82 VAL* valstack_top;

85 VAL* valstack_top;

83 VAL* valstack_base;

86 VAL* valstack_base;

84 VAL* stack_max;

87 VAL* stack_max;

85−

88+

86 Heap heap;

89 Heap heap;

87#ifdef HAS_PTHREAD

90#ifdef HAS_PTHREAD

88 pthread_mutex_t inbox_lock;

91 pthread_mutex_t inbox_lock;

@@ -106,7 +109,7 @@ typedef struct {

106} VM;

109} VM;

107

110

108// Create a new VM

111// Create a new VM

109−VM* init_vm(int stack_size, size_t heap_size,

112+VM* init_vm(int stack_size, size_t heap_size,

110 int max_threads);

113 int max_threads);

111// Initialise thread-local data for this VM

114// Initialise thread-local data for this VM

112void init_threaddata(VM *vm);

115void init_threaddata(VM *vm);

@@ -116,22 +119,24 @@ Stats terminate(VM* vm);

116// Set up key for thread-local data - called once from idris_main

119// Set up key for thread-local data - called once from idris_main

117void init_threadkeys();

120void init_threadkeys();

118

121

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

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

120// and return nothing.

123// and return nothing.

121typedef void(*func)(VM*, VAL*);

124typedef void(*func)(VM*, VAL*);

122

125

123−// Register access

126+// Register access

124

127

125#define RVAL (vm->ret)

128#define RVAL (vm->ret)

126#define LOC(x) (*(vm->valstack_base + (x)))

129#define LOC(x) (*(vm->valstack_base + (x)))

127#define TOP(x) (*(vm->valstack_top + (x)))

130#define TOP(x) (*(vm->valstack_top + (x)))

128#define REG1 (vm->reg1)

131#define REG1 (vm->reg1)

129

132

130−// Retrieving values

133+// align pointer

134+#define ALIGN(__p, __alignment) ((__p + __alignment - 1) & ~(__alignment - 1))

131

135

136+// Retrieving values

132#define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x))

137#define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x))

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

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

134−#define GETMPTR(x) (((VAL)(x))->info.mptr->data)

139+#define GETMPTR(x) (((VAL)(x))->info.mptr->data)

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

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

136

141

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

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

@@ -189,6 +194,30 @@ VAL MKB16(VM* vm, uint16_t b);

189VAL MKB32(VM* vm, uint32_t b);

194VAL MKB32(VM* vm, uint32_t b);

190VAL MKB64(VM* vm, uint64_t b);

195VAL MKB64(VM* vm, uint64_t b);

191

196

197+// SSE Vectors

198+VAL MKB8x16(VM* vm,

199+ VAL v0, VAL v1, VAL v2, VAL v3,

200+ VAL v4, VAL v5, VAL v6, VAL v7,

201+ VAL v8, VAL v9, VAL v10, VAL v11,

202+ VAL v12, VAL v13, VAL v14, VAL v15);

203+VAL MKB8x16const(VM* vm,

204+ uint8_t v0, uint8_t v1, uint8_t v2, uint8_t v3,

205+ uint8_t v4, uint8_t v5, uint8_t v6, uint8_t v7,

206+ uint8_t v8, uint8_t v9, uint8_t v10, uint8_t v11,

207+ uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15);

208+VAL MKB16x8(VM* vm,

209+ VAL v0, VAL v1, VAL v2, VAL v3,

210+ VAL v4, VAL v5, VAL v6, VAL v7);

211+VAL MKB16x8const(VM* vm,

212+ uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3,

213+ uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7);

214+VAL MKB32x4(VM* vm,

215+ VAL v0, VAL v1, VAL v2, VAL v3);

216+VAL MKB32x4const(VM* vm,

217+ uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3);

218+VAL MKB64x2(VM* vm, VAL v0, VAL v1);

219+VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1);

220+

192// following versions don't take a lock when allocating

221// following versions don't take a lock when allocating

193VAL MKFLOATc(VM* vm, double val);

222VAL MKFLOATc(VM* vm, double val);

194VAL MKSTROFFc(VM* vm, StrOffset* off);

223VAL MKSTROFFc(VM* vm, StrOffset* off);

@@ -203,7 +232,7 @@ char* GETSTROFF(VAL stroff);

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

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

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

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

205

234

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

235+void PROJECT(VM* vm, VAL r, int loc, int arity);

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

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

208

237

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

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

@@ -257,11 +286,11 @@ void dumpVal(VAL r);

257void dumpStack(VM* vm);

286void dumpStack(VM* vm);

258

287

259// Casts

288// Casts

260−

261#define idris_castIntFloat(x) MKFLOAT(vm, (double)(GETINT(x)))

289#define idris_castIntFloat(x) MKFLOAT(vm, (double)(GETINT(x)))

262#define idris_castFloatInt(x) MKINT((i_int)(GETFLOAT(x)))

290#define idris_castFloatInt(x) MKINT((i_int)(GETFLOAT(x)))

263

291

264VAL idris_castIntStr(VM* vm, VAL i);

292VAL idris_castIntStr(VM* vm, VAL i);

293+VAL idris_castBitsStr(VM* vm, VAL i);

265VAL idris_castStrInt(VM* vm, VAL i);

294VAL idris_castStrInt(VM* vm, VAL i);

266VAL idris_castFloatStr(VM* vm, VAL i);

295VAL idris_castFloatStr(VM* vm, VAL i);

267VAL idris_castStrFloat(VM* vm, VAL i);

296VAL idris_castStrFloat(VM* vm, VAL i);

@@ -273,7 +302,6 @@ void idris_poke(void* ptr, i_int offset, uint8_t data);

273void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);

302void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);

274

303

275// String primitives

304// String primitives

276−

277VAL idris_concat(VM* vm, VAL l, VAL r);

305VAL idris_concat(VM* vm, VAL l, VAL r);

278VAL idris_strlt(VM* vm, VAL l, VAL r);

306VAL idris_strlt(VM* vm, VAL l, VAL r);

279VAL idris_streq(VM* vm, VAL l, VAL r);

307VAL idris_streq(VM* vm, VAL l, VAL r);

@@ -324,7 +352,7 @@ extern char **__idris_argv;

324int idris_numArgs();

352int idris_numArgs();

325const char *idris_getArg(int i);

353const char *idris_getArg(int i);

326

354

327−// Handle stack overflow.

355+// Handle stack overflow.

328// Just reports an error and exits.

356// Just reports an error and exits.

329

357

330void stackOverflow();

358void stackOverflow();

@@ -338,4 +366,4 @@ void stackOverflow();

338

366

339#include "idris_gmp.h"

367#include "idris_gmp.h"

340

368

341−#endif

369+#endif

src/IRTS/CodegenC.hs+22−5

@@ -12,6 +12,7 @@ import Util.System

12import Numeric

13import Data.Char

14import Data.List (intercalate)

15+import qualified Data.Vector.Unboxed as V

15import System.Process

16import System.Process

16import System.Exit

17import System.Exit

17import System.IO

18import System.IO

@@ -149,7 +150,12 @@ bcc i (ASSIGNCONST l c)

149 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"

150 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"

150 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"

151 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"

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

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

152− mkConst _ = "MKINT(42424242)"

153+ mkConst (B8V x) = let x' = V.toList x in "MKB8x16const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"

154+ mkConst (B16V x) = let x' = V.toList x in "MKB16x8const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"

155+ mkConst (B32V x) = let x' = V.toList x in "MKB32x4const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "UL") x') ++ ")"

156+ mkConst (B64V x) = let x' = V.toList x in "MKB64x2const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "ULL") x') ++ ")"

157+ mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"

158+

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

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

154bcc i (MKCON l loc tag []) | tag < 256

160bcc i (MKCON l loc tag []) | tag < 256

155 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"

161 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"

@@ -164,7 +170,7 @@ bcc i (MKCON l loc tag args)

164 setArgs i [] = ""

170 setArgs i [] = ""

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

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

166 "); " ++ setArgs (i + 1) xs

172 "); " ++ setArgs (i + 1) xs

167− alloc Nothing tag

173+ alloc Nothing tag

168 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++

174 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++

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

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

170 alloc (Just old) tag

176 alloc (Just old) tag

@@ -389,6 +395,7 @@ doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"

389doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"

395doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"

390doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"

396doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"

391doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"

397doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"

398+doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")"

392doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"

399doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"

393doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"

400doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"

394

401

@@ -493,16 +500,26 @@ doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ",

493doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

500doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

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

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

495doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"

502doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"

496−doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++

503+doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++

497− "), GETINT(" ++ creg i ++ "))"

504+ "), GETINT(" ++ creg i ++ "))"

498doOp v (LChInt ITNative) args = v ++ creg (last args)

505doOp v (LChInt ITNative) args = v ++ creg (last args)

499doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args

506doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args

500doOp v (LIntCh ITNative) args = v ++ creg (last args)

507doOp v (LIntCh ITNative) args = v ++ creg (last args)

501doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args

508doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args

502

509

510+doOp v c@(LMkVec IT8 _) args = v ++ "MKB8x16(vm, " ++ (intercalate ", " (map creg args)) ++ ")"

511+doOp v c@(LMkVec IT16 _) args = v ++ "MKB16x8(vm, " ++ (intercalate ", " (map creg args)) ++ ")"

512+doOp v c@(LMkVec IT32 _) args = v ++ "MKB32x4(vm, " ++ (intercalate ", " (map creg args)) ++ ")"

513+doOp v c@(LMkVec IT64 _) args = v ++ "MKB64x2(vm, " ++ (intercalate ", " (map creg args)) ++ ")"

514+

515+doOp v c@(LIdxVec IT8 _) [p, i] = v ++ "idris_IDXB8x16(vm, " ++ creg p ++ ", " ++ creg i ++ ")"

516+doOp v c@(LIdxVec IT16 _) [p, i] = v ++ "idris_IDXB16x8(vm, " ++ creg p ++ ", " ++ creg i ++ ")"

517+doOp v c@(LIdxVec IT32 _) [p, i] = v ++ "idris_IDXB32x4(vm, " ++ creg p ++ ", " ++ creg i ++ ")"

518+doOp v c@(LIdxVec IT64 _) [p, i] = v ++ "idris_IDXB64x2(vm, " ++ creg p ++ ", " ++ creg i ++ ")"

519+

503doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"

520doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"

504doOp v LNoOp args = v ++ creg (last args)

521doOp v LNoOp args = v ++ creg (last args)

505−doOp _ op _ = "FAIL /* " ++ show op ++ " */"

522+doOp _ op args = error "doOp of (" ++ show op ++ ") not implemented, arguments (" ++ show args ++ ")"

506

523

507flUnOp :: String -> String -> String

524flUnOp :: String -> String -> String

508flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

525flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

test/Makefile+3−4

@@ -8,13 +8,13 @@ test: $(TESTS)

8 @perl ./runtest.pl $(patsubst %.test,%,$@)

10test_java:

11− @perl ./runtest.pl without --codegen Java

11+ @perl ./runtest.pl without primitives004 --codegen Java

13test_js:

14− @perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 buffer001 basic011 --codegen node

14+ @perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 buffer001 basic011 primitives004 --codegen node

16test_llvm:

17− @perl ./runtest.pl without primitives003 sugar004 io003 buffer001 --codegen llvm

17+ @perl ./runtest.pl without primitives003 primitives004 sugar004 io003 buffer001 --codegen llvm

19update:

20 /usr/bin/env perl ./runtest.pl all -u

@@ -25,4 +25,3 @@ diff:

25distclean:

26 rm -f *~

27 rm -f */output

28−

test/primitives004/expectednew file+4

@@ -0,0 +1,4 @@

1+<3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3>

2+<3, 3, 3, 3, 3, 3, 3, 3>

3+<3, 3, 3, 3>

4+<3, 3>

test/primitives004/primitives004.idrnew file+8

@@ -0,0 +1,8 @@

1+module Main

3+main : IO ()

4+main = do

5+ putStrLn . show $ uniformB8x16 3

6+ putStrLn . show $ uniformB16x8 3

7+ putStrLn . show $ uniformB32x4 3

8+ putStrLn . show $ uniformB64x2 3

test/primitives004/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+idris $@ -o primitives004 primitives004.idr --nocolour

3+./primitives004

4+rm -f primitives004 *.ibc