6dafd18 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Added bit vectors to the C backend

commit6dafd1880aa6a6cf934bc8812dd336be26f8bb66 authorMattias Lundell <mattias@lundell.com> dateTue 30 Dec 2014, 22:32 (12 years ago) parentd40cd6f

8 files changed+275−42

compare with master

unifiedsplit

rts/idris_bitstring.c+28 rts/idris_bitstring.h+5 rts/idris_rts.c+162−23 rts/idris_rts.h+42−14 src/IRTS/CodegenC.hs+22−5 test/primitives004/expected+4 test/primitives004/primitives004.idr+8 test/primitives004/run+4

rts/idris_bitstring.c+28

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

820820 return cl;

821821}

822822

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

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

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

128128

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+

129134#endif

rts/idris_rts.c+162−23

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

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

2222}

2323

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

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

2525 int max_threads // not implemented yet

2626 ) {

2727

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

113113#ifdef HAS_PTHREAD

114114 int lock = vm->processes > 0;

115115 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);

117117 }

118118#endif

119119}

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

123123 VM* vm = pthread_getspecific(vm_key);

124124 int lock = vm->processes > 0;

125125 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);

127127 }

128128#endif

129129}

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

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

154154

155155 if (lock) { // not message passing

156− pthread_mutex_lock(&vm->alloc_lock);

156+ pthread_mutex_lock(&vm->alloc_lock);

157157 }

158158#else

159159 VM* vm = global_vm;

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

176176 memset(ptr, 0, size);

177177#ifdef HAS_PTHREAD

178178 if (lock) { // not message passing

179− pthread_mutex_unlock(&vm->alloc_lock);

179+ pthread_mutex_unlock(&vm->alloc_lock);

180180 }

181181#endif

182182 return ptr;

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

184184 idris_gc(vm);

185185#ifdef HAS_PTHREAD

186186 if (lock) { // not message passing

187− pthread_mutex_unlock(&vm->alloc_lock);

187+ pthread_mutex_unlock(&vm->alloc_lock);

188188 }

189189#endif

190190 return allocate(size, 0);

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

250250 SETTY(cl, MANAGEDPTR);

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

252252 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);

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

255255 return cl;

256256}

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

285285 SETTY(cl, MANAGEDPTR);

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

287287 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);

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

290290 return cl;

291291}

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

318318 return cl;

319319}

320320

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+

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

322423 int i;

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

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

350451void dumpVal(VAL v) {

351452 if (v==NULL) return;

352453 int i;

353− if (ISINT(v)) {

454+ if (ISINT(v)) {

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

355456 return;

356457 }

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

400501 return cl;

401502}

402503

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+

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

404543 char *end;

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

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

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

407546 return MKINT(v);

408− else

409− return MKINT(0);

547+ else

548+ return MKINT(0);

410549}

411550

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

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

430569 SETTY(cl, STRING);

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

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

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

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

434573 return cl;

435574}

436575

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

840979}

841980

842981void* 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,

844983 callvm->max_threads);

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

846985 pthread_t t;

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

856995 td->callvm = callvm;

857996 td->fn = f;

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

859−

998+

860999 callvm->processes++;

8611000

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

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

8641003 return vm;

8651004}

8661005

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

8681007

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

8701009 int i, ar;

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

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

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

9311070

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

9331072 // destination thread (which is very likely)

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

935−

1074+

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

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

9381077

9391078 int gcs = dest->stats.collections;

940− pthread_mutex_lock(&dest->alloc_lock);

1079+ pthread_mutex_lock(&dest->alloc_lock);

9411080 VAL dmsg = copyTo(dest, msg);

942− pthread_mutex_unlock(&dest->alloc_lock);

1081+ pthread_mutex_unlock(&dest->alloc_lock);

9431082

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

9451084 // a collection will have invalidated the copy

946− pthread_mutex_lock(&dest->alloc_lock);

1085+ pthread_mutex_lock(&dest->alloc_lock);

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

948− pthread_mutex_unlock(&dest->alloc_lock);

1087+ pthread_mutex_unlock(&dest->alloc_lock);

9491088 }

9501089

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

9521091 *(dest->inbox_write) = dmsg;

953−

1092+

9541093 dest->inbox_write++;

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

9561095 dest->inbox_write = dest->inbox;

rts/idris_rts.h+42−14

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

1010#endif

1111#include <stdint.h>

1212

13+#include <emmintrin.h>

14+

1315#include "idris_heap.h"

1416#include "idris_stats.h"

1517

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

2123#endif

2224

2325// Closures

24−

2526typedef enum {

2627 CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

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

28− MANAGEDPTR, BUFFER

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

30+ BITS64X2

2931} ClosureType;

3032

3133typedef struct Closure *VAL;

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

7274 uint16_t bits16;

7375 uint32_t bits32;

7476 uint64_t bits64;

77+ __m128i* bits128p;

7578 Buffer* buf;

7679 ManagedPtr* mptr;

7780 } info;

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

8285 VAL* valstack_top;

8386 VAL* valstack_base;

8487 VAL* stack_max;

85−

88+

8689 Heap heap;

8790#ifdef HAS_PTHREAD

8891 pthread_mutex_t inbox_lock;

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

106109} VM;

107110

108111// 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,

110113 int max_threads);

111114// Initialise thread-local data for this VM

112115void init_threaddata(VM *vm);

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

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

117120void init_threadkeys();

118121

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,

120123// and return nothing.

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

122125

123−// Register access

126+// Register access

124127

125128#define RVAL (vm->ret)

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

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

128131#define REG1 (vm->reg1)

129132

130−// Retrieving values

133+// align pointer

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

131135

136+// Retrieving values

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

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

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

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

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

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

136141

137142#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);

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

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

191196

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+

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

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

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

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

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

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

205234

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

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

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

208237

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

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

257286void dumpStack(VM* vm);

258287

259288// Casts

260−

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

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

263291

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

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

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

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

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

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

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

274303

275304// String primitives

276−

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

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

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

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

324352int idris_numArgs();

325353const char *idris_getArg(int i);

326354

327−// Handle stack overflow.

355+// Handle stack overflow.

328356// Just reports an error and exits.

329357

330358void stackOverflow();

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

338366

339367#include "idris_gmp.h"

340368

341−#endif

369+#endif

src/IRTS/CodegenC.hs+22−5

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

1212import Numeric

1313import Data.Char

1414import Data.List (intercalate)

15+import qualified Data.Vector.Unboxed as V

1516import System.Process

1617import System.Exit

1718import System.IO

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

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

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

151152 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+

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

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

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

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

164170 setArgs i [] = ""

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

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

167− alloc Nothing tag

173+ alloc Nothing tag

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

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

170176 alloc (Just old) tag

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

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

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

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

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

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

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

394401

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

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

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

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

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

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

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

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

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

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

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

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

502509

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+

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

504521doOp 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 ++ ")"

506523

507524flUnOp :: String -> String -> String

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

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