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