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