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