dispatch.c

   1 /* file: "dispatch.c" */
   2
   3 /*
   4  * Copyright 2004-2009 by Marc Feeley and Vincent St-Amour, All Rights Reserved.
   5  */
   6
   7 #include "picobit-vm.h"
   8
   9 void push_arg1 () {
  10   env = cons (arg1, env);
  11   arg1 = OBJ_FALSE;
  12 }
  13
  14 obj pop () {
  15   obj o = ram_get_car (env);
  16   env = ram_get_cdr (env);
  17   return o;
  18 }
  19
  20 void pop_procedure () {
  21   arg1 = pop();
  22
  23   if (IN_RAM(arg1)) {
  24     if (!RAM_CLOSURE(arg1))
  25       TYPE_ERROR("pop_procedure.0", "procedure");
  26
  27     entry = ram_get_entry (arg1) + CODE_START;
  28   }
  29   else if (IN_ROM(arg1)) {
  30     if (!ROM_CLOSURE(arg1))
  31       TYPE_ERROR("pop_procedure.1", "procedure");
  32
  33     entry = rom_get_entry (arg1) + CODE_START;
  34   }
  35   else
  36     TYPE_ERROR("pop_procedure.2", "procedure");
  37 }
  38
  39 void handle_arity_and_rest_param () {
  40   uint8 np;
  41
  42   np = rom_get (entry++);
  43
  44   if ((np & 0x80) == 0) {
  45     if (na != np)
  46       ERROR("handle_arity_and_rest_param.0", "wrong number of arguments");
  47   }
  48   else {
  49     np = ~np;
  50
  51     if (na < np)
  52       ERROR("handle_arity_and_rest_param.1", "wrong number of arguments");
  53
  54     arg3 = OBJ_NULL;
  55
  56     while (na > np) {
  57       arg4 = pop();
  58
  59       arg3 = cons (arg4, arg3);
  60       arg4 = OBJ_FALSE;
  61
  62       na--;
  63     }
  64
  65     arg1 = cons (arg3, arg1);
  66     arg3 = OBJ_FALSE;
  67   }
  68 }
  69
  70 void build_env () {
  71   while (na != 0) {
  72     arg3 = pop();
  73
  74     arg1 = cons (arg3, arg1);
  75
  76     na--;
  77   }
  78
  79   arg3 = OBJ_FALSE;
  80 }
  81
  82 void save_cont () {
  83   // the second half is a closure
  84   arg3 = alloc_ram_cell_init (CLOSURE_FIELD0 | (pc >> 11),
  85                               (pc >> 3) & 0xff,
  86                               ((pc & 0x0007) << 5) | (env >> 8),
  87                               env & 0xff);
  88   cont = alloc_ram_cell_init (COMPOSITE_FIELD0 | (cont >> 8),
  89                               cont & 0xff,
  90                               CONTINUATION_FIELD2 | (arg3 >> 8),
  91                               arg3 & 0xff);
  92   arg3 = OBJ_FALSE;
  93 }
  94
  95 void interpreter () {
  96   pc = rom_get (CODE_START+2);
  97   pc = (CODE_START + 4) + (pc << 2);
  98
  99   glovars = rom_get (CODE_START+3); // number of global variables
 100
 101   init_ram_heap ();
 102
 103  dispatch:
 104   IF_TRACE(show_state (pc));
 105   FETCH_NEXT_BYTECODE();
 106   bytecode_hi4 = bytecode & 0xf0;
 107   bytecode_lo4 = bytecode & 0x0f;
 108
 109   switch (bytecode_hi4 >> 4) {
 110
 111     /*************************************************************************/
 112   case PUSH_CONSTANT1 :
 113
 114     IF_TRACE(printf("  (push-constant "); show (bytecode_lo4); printf (")\n"));
 115
 116     arg1 = bytecode_lo4;
 117
 118     push_arg1();
 119
 120     goto dispatch;
 121
 122     /*************************************************************************/
 123   case PUSH_CONSTANT2 :
 124
 125     IF_TRACE(printf("  (push-constant "); show (bytecode_lo4+16); printf (")\n"));
 126     arg1 = bytecode_lo4+16;
 127
 128     push_arg1();
 129
 130     goto dispatch;
 131
 132     /*************************************************************************/
 133   case PUSH_STACK1 :
 134
 135     IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4));
 136
 137     arg1 = env;
 138
 139     while (bytecode_lo4 != 0) {
 140       arg1 = ram_get_cdr (arg1);
 141       bytecode_lo4--;
 142     }
 143
 144     arg1 = ram_get_car (arg1);
 145
 146     push_arg1();
 147
 148     goto dispatch;
 149
 150     /*************************************************************************/
 151   case PUSH_STACK2 :
 152
 153     IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4+16));
 154
 155     bytecode_lo4 += 16;
 156
 157     arg1 = env;
 158
 159     while (bytecode_lo4 != 0) {
 160       arg1 = ram_get_cdr (arg1);
 161       bytecode_lo4--;
 162     }
 163
 164     arg1 = ram_get_car (arg1);
 165
 166     push_arg1();
 167
 168     goto dispatch;
 169
 170     /*************************************************************************/
 171   case PUSH_GLOBAL :
 172
 173     IF_TRACE(printf("  (push-global %d)\n", bytecode_lo4));
 174
 175     arg1 = get_global (bytecode_lo4);
 176
 177     push_arg1();
 178
 179     goto dispatch;
 180
 181     /*************************************************************************/
 182   case SET_GLOBAL :
 183
 184     IF_TRACE(printf("  (set-global %d)\n", bytecode_lo4));
 185
 186     set_global (bytecode_lo4, pop());
 187
 188     goto dispatch;
 189
 190     /*************************************************************************/
 191   case CALL :
 192
 193     IF_TRACE(printf("  (call %d)\n", bytecode_lo4));
 194
 195     na = bytecode_lo4;
 196
 197     pop_procedure ();
 198     handle_arity_and_rest_param ();
 199     build_env ();
 200     save_cont ();
 201
 202     env = arg1;
 203     pc = entry;
 204
 205     arg1 = OBJ_FALSE;
 206
 207     goto dispatch;
 208
 209     /*************************************************************************/
 210   case JUMP :
 211
 212     IF_TRACE(printf("  (jump %d)\n", bytecode_lo4));
 213
 214     na = bytecode_lo4;
 215
 216     pop_procedure ();
 217     handle_arity_and_rest_param ();
 218     build_env ();
 219
 220     env = arg1;
 221     pc = entry;
 222
 223     arg1 = OBJ_FALSE;
 224
 225     goto dispatch;
 226
 227     /*************************************************************************/
 228   case LABEL_INSTR :
 229
 230     switch (bytecode_lo4) {
 231     case 0: // call-toplevel
 232       FETCH_NEXT_BYTECODE();
 233       arg2 = bytecode;
 234
 235       FETCH_NEXT_BYTECODE();
 236
 237       IF_TRACE(printf("  (call-toplevel 0x%04x)\n",
 238                       ((arg2 << 8) | bytecode) + CODE_START));
 239
 240       entry = (arg2 << 8) + bytecode + CODE_START;
 241       arg1 = OBJ_NULL;
 242
 243       na = rom_get (entry++);
 244
 245       build_env ();
 246       save_cont ();
 247
 248       env = arg1;
 249       pc = entry;
 250
 251       arg1 = OBJ_FALSE;
 252       arg2 = OBJ_FALSE;
 253
 254       break;
 255
 256     case 1: // jump-toplevel
 257       FETCH_NEXT_BYTECODE();
 258       arg2 = bytecode;
 259
 260       FETCH_NEXT_BYTECODE();
 261
 262       IF_TRACE(printf("  (jump-toplevel 0x%04x)\n",
 263                       ((arg2 << 8) | bytecode) + CODE_START));
 264
 265       entry = (arg2 << 8) + bytecode + CODE_START;
 266       arg1 = OBJ_NULL;
 267
 268       na = rom_get (entry++);
 269
 270       build_env ();
 271
 272       env = arg1;
 273       pc = entry;
 274
 275       arg1 = OBJ_FALSE;
 276       arg2 = OBJ_FALSE;
 277
 278       break;
 279
 280     case 2: // goto
 281       FETCH_NEXT_BYTECODE();
 282       arg2 = bytecode;
 283
 284       FETCH_NEXT_BYTECODE();
 285
 286       IF_TRACE(printf("  (goto 0x%04x)\n",
 287                       (arg2 << 8) + bytecode + CODE_START));
 288
 289       pc = (arg2 << 8) + bytecode + CODE_START;
 290
 291       break;
 292
 293     case 3: // goto-if-false
 294       FETCH_NEXT_BYTECODE();
 295       arg2 = bytecode;
 296
 297       FETCH_NEXT_BYTECODE();
 298
 299       IF_TRACE(printf("  (goto-if-false 0x%04x)\n",
 300                       (arg2 << 8) + bytecode + CODE_START));
 301
 302       if (pop() == OBJ_FALSE)
 303         pc = (arg2 << 8) + bytecode + CODE_START;
 304
 305       break;
 306
 307     case 4: // closure
 308       FETCH_NEXT_BYTECODE();
 309       arg2 = bytecode;
 310
 311       FETCH_NEXT_BYTECODE();
 312
 313       IF_TRACE(printf("  (closure 0x%04x)\n", (arg2 << 8) | bytecode));
 314
 315       arg3 = pop(); // env
 316
 317       entry = (arg2 << 8) | bytecode;
 318
 319       arg1 =
 320         alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
 321                              ((arg2 & 0x07) << 5) | (bytecode >> 3),
 322                              ((bytecode & 0x07) << 5) | ((arg3 & 0x1f00) >> 8),
 323                              arg3 & 0xff);
 324
 325       push_arg1();
 326
 327       arg2 = OBJ_FALSE;
 328       arg3 = OBJ_FALSE;
 329
 330       break;
 331
 332 #if 0
 333     case 5: // call-toplevel-short
 334       FETCH_NEXT_BYTECODE(); // TODO the short version have a lot in common with the long ones, abstract ?
 335       // TODO short instructions don't work at the moment
 336       IF_TRACE(printf("  (call-toplevel-short 0x%04x)\n",
 337                       pc + bytecode + CODE_START));
 338
 339       entry = pc + bytecode + CODE_START;
 340       arg1 = OBJ_NULL;
 341
 342       na = rom_get (entry++);
 343
 344       build_env ();
 345       save_cont ();
 346
 347       env = arg1;
 348       pc = entry;
 349
 350       arg1 = OBJ_FALSE;
 351
 352       break;
 353
 354     case 6: // jump-toplevel-short
 355       FETCH_NEXT_BYTECODE();
 356
 357       IF_TRACE(printf("  (jump-toplevel-short 0x%04x)\n",
 358                       pc + bytecode + CODE_START));
 359
 360       entry = pc + bytecode + CODE_START;
 361       arg1 = OBJ_NULL;
 362
 363       na = rom_get (entry++);
 364
 365       build_env ();
 366
 367       env = arg1;
 368       pc = entry;
 369
 370       arg1 = OBJ_FALSE;
 371
 372       break;
 373
 374     case 7: // goto-short
 375       FETCH_NEXT_BYTECODE();
 376
 377       IF_TRACE(printf("  (goto-short 0x%04x)\n", pc + bytecode + CODE_START));
 378
 379       pc = pc + bytecode + CODE_START;
 380
 381       break;
 382
 383     case 8: // goto-if-false-short
 384       FETCH_NEXT_BYTECODE();
 385
 386       IF_TRACE(printf("  (goto-if-false-short 0x%04x)\n",
 387                       pc + bytecode + CODE_START));
 388
 389       if (pop() == OBJ_FALSE)
 390         pc = pc + bytecode + CODE_START;
 391
 392       break;
 393
 394     case 9: // closure-short
 395       FETCH_NEXT_BYTECODE();
 396
 397       IF_TRACE(printf("  (closure-short 0x%04x)\n", pc + bytecode));
 398
 399       arg3 = pop(); // env
 400
 401       entry = pc + bytecode;
 402
 403       arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
 404                                   ((arg2 & 0x07) << 5) | (bytecode >> 3),
 405                                   ((bytecode &0x07) <<5) |((arg3 &0x1f00) >>8),
 406                                   arg3 & 0xff);
 407
 408       push_arg1();
 409
 410       arg3 = OBJ_FALSE;
 411
 412       break;
 413 #endif
 414
 415 #if 0
 416     case 10:
 417       break;
 418     case 11:
 419       break;
 420     case 12:
 421       break;
 422     case 13:
 423       break;
 424 #endif
 425     case 14: // push_global [long]
 426       FETCH_NEXT_BYTECODE();
 427
 428       IF_TRACE(printf("  (push-global [long] %d)\n", bytecode));
 429
 430       arg1 = get_global (bytecode);
 431
 432       push_arg1();
 433
 434       break;
 435
 436     case 15: // set_global [long]
 437       FETCH_NEXT_BYTECODE();
 438
 439       IF_TRACE(printf("  (set-global [long] %d)\n", bytecode));
 440
 441       set_global (bytecode, pop());
 442
 443       break;
 444     }
 445
 446     goto dispatch;
 447
 448     /*************************************************************************/
 449   case PUSH_CONSTANT_LONG :
 450
 451     /* push-constant [long] */
 452
 453     FETCH_NEXT_BYTECODE();
 454
 455     IF_TRACE(printf("  (push [long] 0x%04x)\n", (bytecode_lo4 << 8) + bytecode));
 456
 457     // necessary since SIXPIC would have kept the result of the shift at 8 bits
 458     arg1 = bytecode_lo4;
 459     arg1 = (arg1 << 8) | bytecode;
 460     push_arg1();
 461
 462     goto dispatch;
 463
 464     /*************************************************************************/
 465   case FREE1 : // FREE
 466
 467     goto dispatch;
 468
 469     /*************************************************************************/
 470   case FREE2 : // FREE
 471
 472     goto dispatch;
 473
 474     /*************************************************************************/
 475   case PRIM1 :
 476
 477     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
 478
 479     switch (bytecode_lo4) {
 480     case 0:
 481       arg1 = pop();  prim_numberp ();  push_arg1();  break;
 482     case 1:
 483       arg2 = pop();  arg1 = pop();  prim_add ();      push_arg1();  break;
 484     case 2:
 485       arg2 = pop();  arg1 = pop();  prim_sub ();      push_arg1();  break;
 486     case 3:
 487       arg2 = pop();  arg1 = pop();  prim_mul ();      push_arg1();  break;
 488     case 4:
 489       arg2 = pop();  arg1 = pop();  prim_div ();      push_arg1();  break;
 490     case 5:
 491       arg2 = pop();  arg1 = pop();  prim_rem ();      push_arg1();  break;
 492     case 6:
 493       arg1 = pop();  prim_neg ();      push_arg1();  break;
 494     case 7:
 495       arg2 = pop();  arg1 = pop();  prim_eq ();       push_arg1();  break;
 496     case 8:
 497       arg2 = pop();  arg1 = pop();  prim_lt ();       push_arg1();  break;
 498     case 9:
 499       arg2 = pop();  arg1 = pop();  prim_leq ();      push_arg1();  break;
 500     case 10:
 501       arg2 = pop();  arg1 = pop();  prim_gt ();       push_arg1();  break;
 502     case 11:
 503       arg2 = pop();  arg1 = pop();  prim_geq ();      push_arg1();  break;
 504     case 12:
 505       arg1 = pop();  prim_pairp ();    push_arg1();  break;
 506     case 13:
 507       arg2 = pop();  arg1 = pop();  prim_cons ();     push_arg1();  break;
 508     case 14:
 509       arg1 = pop();  prim_car ();      push_arg1();  break;
 510     case 15:
 511       arg1 = pop();  prim_cdr ();      push_arg1();  break;
 512     }
 513
 514     goto dispatch;
 515
 516     /*************************************************************************/
 517   case PRIM2 :
 518
 519     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+16]));
 520
 521     switch (bytecode_lo4) {
 522     case 0:
 523       arg2 = pop();  arg1 = pop();  prim_set_car ();  break;
 524     case 1:
 525       arg2 = pop();  arg1 = pop();  prim_set_cdr ();  break;
 526     case 2:
 527       arg1 = pop();  prim_nullp ();    push_arg1();  break;
 528     case 3:
 529       arg2 = pop();  arg1 = pop();  prim_eqp ();      push_arg1();  break;
 530     case 4:
 531       arg1 = pop();  prim_not ();      push_arg1();  break;
 532     case 5:
 533       /* prim #%get-cont */
 534       arg1 = cont;
 535       push_arg1();
 536       break;
 537     case 6:
 538       /* prim #%graft-to-cont */
 539
 540       arg1 = pop(); /* thunk to call */
 541       cont = pop(); /* continuation */
 542
 543       push_arg1();
 544
 545       na = 0;
 546
 547       pop_procedure ();
 548       handle_arity_and_rest_param ();
 549       build_env ();
 550
 551       env = arg1;
 552       pc = entry;
 553
 554       arg1 = OBJ_FALSE;
 555
 556       break;
 557     case 7:
 558       /* prim #%return-to-cont */
 559
 560       arg1 = pop(); /* value to return */
 561       cont = pop(); /* continuation */
 562
 563       arg2 = ram_get_cdr (cont);
 564
 565       pc = ram_get_entry (arg2);
 566
 567       env = ram_get_cdr (arg2);
 568       cont = ram_get_car (cont);
 569
 570       push_arg1();
 571       arg2 = OBJ_FALSE;
 572
 573       break;
 574     case 8:
 575       /* prim #%halt */
 576       return;
 577     case 9:
 578       /* prim #%symbol? */
 579       arg1 = pop();  prim_symbolp ();  push_arg1();  break;
 580     case 10:
 581       /* prim #%string? */
 582       arg1 = pop();  prim_stringp ();  push_arg1();  break;
 583     case 11:
 584       /* prim #%string->list */
 585       arg1 = pop();  prim_string2list ();  push_arg1();  break;
 586     case 12:
 587       /* prim #%list->string */
 588       arg1 = pop();  prim_list2string ();  push_arg1();  break;
 589     case 13:
 590       /* prim #%make-u8vector */
 591       arg2 = pop(); arg1 = pop(); prim_make_u8vector (); push_arg1(); break;
 592     case 14:
 593       /* prim #%u8vector-ref */
 594       arg2 = pop(); arg1 = pop(); prim_u8vector_ref (); push_arg1(); break;
 595     case 15:
 596       /* prim #%u8vector-set! */
 597       arg3 = pop(); arg2 = pop(); arg1 = pop(); prim_u8vector_set (); break;
 598     }
 599
 600     goto dispatch;
 601
 602     /*************************************************************************/
 603   case PRIM3 :
 604
 605     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
 606
 607     switch (bytecode_lo4) {
 608     case 0:
 609       /* prim #%print */
 610       arg1 = pop();
 611       prim_print ();
 612       break;
 613     case 1:
 614       /* prim #%clock */
 615       prim_clock ();  push_arg1();  break;
 616     case 2:
 617       /* prim #%motor */
 618       arg2 = pop();  arg1 = pop();  prim_motor ();  break;
 619     case 3:
 620       /* prim #%led */
 621       arg3 = pop();  arg2 = pop();  arg1 = pop();  prim_led ();  ;break;
 622     case 4:
 623       /* prim #%led2-color */
 624       arg1 = pop();  prim_led2_color ();  break;
 625     case 5:
 626       /* prim #%getchar-wait */
 627       arg2 = pop();  arg1 = pop();  prim_getchar_wait ();  push_arg1();  break;
 628     case 6:
 629       /* prim #%putchar */
 630       arg2 = pop();  arg1 = pop();  prim_putchar ();  break;
 631     case 7:
 632       /* prim #%beep */
 633       arg2 = pop();  arg1 = pop();  prim_beep ();  break;
 634     case 8:
 635       /* prim #%adc */
 636       arg1 = pop();  prim_adc ();  push_arg1();  break;
 637     case 9:
 638       /* prim #%u8vector? */
 639       arg1 = pop(); prim_u8vectorp (); push_arg1(); break;
 640     case 10:
 641       /* prim #%sernum */
 642       prim_sernum ();  push_arg1();  break;
 643     case 11:
 644       /* prim #%u8vector-length */
 645       arg1 = pop(); prim_u8vector_length (); push_arg1(); break;
 646     case 12:
 647       /* prim #%u8vector-copy! */
 648       arg5 = pop(); arg4 = pop(); arg3 = pop(); arg2 = pop(); arg1 = pop();
 649       prim_u8vector_copy (); break;
 650       break;
 651     case 13:
 652       /* shift */
 653       arg1 = pop();
 654       pop();
 655       push_arg1();
 656       break;
 657     case 14:
 658       /* pop */
 659       pop();
 660       break;
 661     case 15:
 662       /* return */
 663       arg1 = pop();
 664       arg2 = ram_get_cdr (cont);
 665       pc = ram_get_entry (arg2);
 666       env = ram_get_cdr (arg2);
 667       cont = ram_get_car (cont);
 668       push_arg1();
 669       arg2 = OBJ_FALSE;
 670       break;
 671     }
 672
 673     goto dispatch;
 674
 675     /*************************************************************************/
 676
 677   case PRIM4 :
 678
 679     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
 680
 681     switch (bytecode_lo4) {
 682     case 0:
 683       /* prim #%boolean? */
 684       arg1 = pop(); prim_booleanp (); push_arg1(); break;
 685     case 1:
 686       /* prim #%network-init */
 687       prim_network_init (); break;
 688     case 2:
 689       /* prim #%network-cleanup */
 690       prim_network_cleanup (); break;
 691     case 3:
 692       /* prim #%receive-packet-to-u8vector */
 693       arg1 = pop(); prim_receive_packet_to_u8vector (); push_arg1(); break;
 694     case 4:
 695       /* prim #%send-packet-from-u8vector */
 696       arg2 = pop(); arg1 = pop(); prim_send_packet_from_u8vector ();
 697       push_arg1(); break;
 698     case 5:
 699       arg2 = pop(); arg1 = pop(); prim_ior (); push_arg1(); break;
 700       break;
 701     case 6:
 702       arg2 = pop(); arg1 = pop(); prim_xor (); push_arg1(); break;
 703       break;
 704 #if 0
 705     case 7:
 706       break;
 707     case 8:
 708       break;
 709     case 9:
 710       break;
 711     case 10:
 712       break;
 713     case 11:
 714       break;
 715     case 12:
 716       break;
 717     case 13:
 718       break;
 719     case 14:
 720       break;
 721     case 15:
 722       break;
 723 #endif
 724     }
 725
 726     goto dispatch;
 727
 728     /*************************************************************************/
 729
 730   }
 731 }