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 #if 0
 317       arg1 = // FOO remove
 318         alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
 319                              ((arg2 & 0x07) << 5) | (bytecode >> 3),
 320                              ((bytecode & 0x07) << 5) | ((arg3 & 0x1f00) >> 8),
 321                              arg3 & 0xff);
 322 #endif
 323
 324       push_arg1();
 325
 326       arg2 = OBJ_FALSE;
 327       arg3 = OBJ_FALSE;
 328
 329       break;
 330
 331 #if 1
 332     case 5: // call-toplevel-rel8
 333       FETCH_NEXT_BYTECODE(); // TODO the short version have a lot in common with the long ones, abstract ?
 334
 335       IF_TRACE(printf("  (call-toplevel-rel8 0x%04x)\n", pc + bytecode - 128));
 336
 337       entry = pc + bytecode - 128;
 338       arg1 = OBJ_NULL;
 339
 340       build_env (rom_get (entry++));
 341       save_cont ();
 342
 343       env = arg1;
 344       pc = entry;
 345
 346       arg1 = OBJ_FALSE;
 347
 348       break;
 349
 350     case 6: // jump-toplevel-rel8
 351       FETCH_NEXT_BYTECODE();
 352
 353       IF_TRACE(printf("  (jump-toplevel-rel8 0x%04x)\n", pc + bytecode - 128));
 354
 355       entry = pc + bytecode - 128;
 356       arg1 = OBJ_NULL;
 357
 358       build_env (rom_get (entry++));
 359
 360       env = arg1;
 361       pc = entry;
 362
 363       arg1 = OBJ_FALSE;
 364
 365       break;
 366
 367     case 7: // goto-rel8
 368       FETCH_NEXT_BYTECODE();
 369
 370       IF_TRACE(printf("  (goto-rel8 0x%04x)\n", pc + bytecode - 128));
 371
 372       pc = pc + bytecode - 128;
 373
 374       break;
 375
 376     case 8: // goto-if-false-rel8
 377       FETCH_NEXT_BYTECODE();
 378
 379       IF_TRACE(printf("  (goto-if-false-rel8 0x%04x)\n", pc + bytecode - 128));
 380
 381       if (pop() == OBJ_FALSE)
 382         pc = pc + bytecode - 128;
 383
 384       break;
 385
 386       /* #if 0 */ // FOO
 387
 388     // FOO why does this not work?  don't worry about it now.
 389
 390     case 9: // closure-rel8
 391       FETCH_NEXT_BYTECODE();
 392
 393       entry = pc + bytecode - 128;
 394
 395       IF_TRACE(printf("  (closure-rel8 0x%04x)\n", entry));
 396
 397       arg3 = pop(); // env
 398
 399       arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (entry >> 11),
 400                                   entry >> 3,
 401                                   ((entry & 0x07) << 5) | ((arg3 >> 8) & 0x1f),
 402                                   arg3 & 0xff);
 403
 404       push_arg1();
 405
 406       arg3 = OBJ_FALSE;
 407
 408       break;
 409       /* #endif */ // FOO
 410
 411 #endif
 412
 413 #if 0
 414     case 10:
 415       break;
 416     case 11:
 417       break;
 418     case 12:
 419       break;
 420     case 13:
 421       break;
 422 #endif
 423     case 14: // push_global [long]
 424       FETCH_NEXT_BYTECODE();
 425
 426       IF_TRACE(printf("  (push-global [long] %d)\n", bytecode));
 427
 428       arg1 = get_global (bytecode);
 429
 430       push_arg1();
 431
 432       break;
 433
 434     case 15: // set_global [long]
 435       FETCH_NEXT_BYTECODE();
 436
 437       IF_TRACE(printf("  (set-global [long] %d)\n", bytecode));
 438
 439       set_global (bytecode, pop());
 440
 441       break;
 442     }
 443
 444     goto dispatch;
 445
 446     /*************************************************************************/
 447   case PUSH_CONSTANT_LONG :
 448
 449     /* push-constant [long] */
 450
 451     FETCH_NEXT_BYTECODE();
 452
 453     IF_TRACE(printf("  (push [long] 0x%04x)\n", (bytecode_lo4 << 8) + bytecode));
 454
 455     // necessary since SIXPIC would have kept the result of the shift at 8 bits
 456     arg1 = bytecode_lo4;
 457     arg1 = (arg1 << 8) | bytecode;
 458     push_arg1();
 459
 460     goto dispatch;
 461
 462     /*************************************************************************/
 463
 464   case JUMP_TOPLEVEL_REL4 :
 465
 466     IF_TRACE(printf("  (jump-toplevel-rel4 0x%04x)\n", pc + (bytecode & 0x0f)));
 467
 468     entry = pc + (bytecode & 0x0f);
 469     arg1 = OBJ_NULL;
 470
 471     build_env (rom_get (entry++));
 472
 473     env = arg1;
 474     pc = entry;
 475
 476     arg1 = OBJ_FALSE;
 477
 478     goto dispatch;
 479
 480     /*************************************************************************/
 481
 482   case GOTO_IF_FALSE_REL4 :
 483
 484     IF_TRACE(printf("  (goto-if-false-rel4 0x%04x)\n", pc + (bytecode & 0x0f)));
 485
 486     if (pop() == OBJ_FALSE)
 487       pc = pc + (bytecode & 0x0f);
 488
 489     goto dispatch;
 490
 491     /*************************************************************************/
 492   case PRIM1 :
 493
 494     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
 495
 496     switch (bytecode_lo4) {
 497     case 0:
 498       arg1 = pop();  prim_numberp ();  push_arg1();  break;
 499     case 1:
 500       arg2 = pop();  arg1 = pop();  prim_add ();      push_arg1();  break;
 501     case 2:
 502       arg2 = pop();  arg1 = pop();  prim_sub ();      push_arg1();  break;
 503     case 3:
 504       arg2 = pop();  arg1 = pop();  prim_mul ();      push_arg1();  break;
 505     case 4:
 506       arg2 = pop();  arg1 = pop();  prim_div ();      push_arg1();  break;
 507     case 5:
 508       arg2 = pop();  arg1 = pop();  prim_rem ();      push_arg1();  break;
 509     case 6:
 510       arg1 = pop();  prim_neg ();      push_arg1();  break;
 511     case 7:
 512       arg2 = pop();  arg1 = pop();  prim_eq ();       push_arg1();  break;
 513     case 8:
 514       arg2 = pop();  arg1 = pop();  prim_lt ();       push_arg1();  break;
 515     case 9:
 516       arg2 = pop();  arg1 = pop();  prim_leq ();      push_arg1();  break;
 517     case 10:
 518       arg2 = pop();  arg1 = pop();  prim_gt ();       push_arg1();  break;
 519     case 11:
 520       arg2 = pop();  arg1 = pop();  prim_geq ();      push_arg1();  break;
 521     case 12:
 522       arg1 = pop();  prim_pairp ();    push_arg1();  break;
 523     case 13:
 524       arg2 = pop();  arg1 = pop();  prim_cons ();     push_arg1();  break;
 525     case 14:
 526       arg1 = pop();  prim_car ();      push_arg1();  break;
 527     case 15:
 528       arg1 = pop();  prim_cdr ();      push_arg1();  break;
 529     }
 530
 531     goto dispatch;
 532
 533     /*************************************************************************/
 534   case PRIM2 :
 535
 536     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+16]));
 537
 538     switch (bytecode_lo4) {
 539     case 0:
 540       arg2 = pop();  arg1 = pop();  prim_set_car ();  break;
 541     case 1:
 542       arg2 = pop();  arg1 = pop();  prim_set_cdr ();  break;
 543     case 2:
 544       arg1 = pop();  prim_nullp ();    push_arg1();  break;
 545     case 3:
 546       arg2 = pop();  arg1 = pop();  prim_eqp ();      push_arg1();  break;
 547     case 4:
 548       arg1 = pop();  prim_not ();      push_arg1();  break;
 549     case 5:
 550       /* prim #%get-cont */
 551       arg1 = cont;
 552       push_arg1();
 553       break;
 554     case 6:
 555       /* prim #%graft-to-cont */
 556
 557       arg1 = pop(); /* thunk to call */
 558       cont = pop(); /* continuation */
 559
 560       push_arg1();
 561
 562       pop_procedure ();
 563       build_env (handle_arity_and_rest_param (0));
 564
 565       env = arg1;
 566       pc = entry;
 567
 568       arg1 = OBJ_FALSE;
 569
 570       break;
 571     case 7:
 572       /* prim #%return-to-cont */
 573
 574       arg1 = pop(); /* value to return */
 575       cont = pop(); /* continuation */
 576
 577       arg2 = ram_get_cdr (cont);
 578
 579       pc = ram_get_entry (arg2);
 580
 581       env = ram_get_cdr (arg2);
 582       cont = ram_get_car (cont);
 583
 584       push_arg1();
 585       arg2 = OBJ_FALSE;
 586
 587       break;
 588     case 8:
 589       /* prim #%halt */
 590       return;
 591     case 9:
 592       /* prim #%symbol? */
 593       arg1 = pop();  prim_symbolp ();  push_arg1();  break;
 594     case 10:
 595       /* prim #%string? */
 596       arg1 = pop();  prim_stringp ();  push_arg1();  break;
 597     case 11:
 598       /* prim #%string->list */
 599       arg1 = pop();  prim_string2list ();  push_arg1();  break;
 600     case 12:
 601       /* prim #%list->string */
 602       arg1 = pop();  prim_list2string ();  push_arg1();  break;
 603     case 13:
 604       /* prim #%make-u8vector */
 605       arg2 = pop(); arg1 = pop(); prim_make_u8vector (); push_arg1(); break;
 606     case 14:
 607       /* prim #%u8vector-ref */
 608       arg2 = pop(); arg1 = pop(); prim_u8vector_ref (); push_arg1(); break;
 609     case 15:
 610       /* prim #%u8vector-set! */
 611       arg3 = pop(); arg2 = pop(); arg1 = pop(); prim_u8vector_set (); break;
 612     }
 613
 614     goto dispatch;
 615
 616     /*************************************************************************/
 617   case PRIM3 :
 618
 619     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
 620
 621     switch (bytecode_lo4) {
 622     case 0:
 623       /* prim #%print */
 624       arg1 = pop();
 625       prim_print ();
 626       break;
 627     case 1:
 628       /* prim #%clock */
 629       prim_clock ();  push_arg1();  break;
 630     case 2:
 631       /* prim #%motor */
 632       arg2 = pop();  arg1 = pop();  prim_motor ();  break;
 633     case 3:
 634       /* prim #%led */
 635       arg3 = pop();  arg2 = pop();  arg1 = pop();  prim_led ();  ;break;
 636     case 4:
 637       /* prim #%led2-color */
 638       arg1 = pop();  prim_led2_color ();  break;
 639     case 5:
 640       /* prim #%getchar-wait */
 641       arg2 = pop();  arg1 = pop();  prim_getchar_wait ();  push_arg1();  break;
 642     case 6:
 643       /* prim #%putchar */
 644       arg2 = pop();  arg1 = pop();  prim_putchar ();  break;
 645     case 7:
 646       /* prim #%beep */
 647       arg2 = pop();  arg1 = pop();  prim_beep ();  break;
 648     case 8:
 649       /* prim #%adc */
 650       arg1 = pop();  prim_adc ();  push_arg1();  break;
 651     case 9:
 652       /* prim #%u8vector? */
 653       arg1 = pop(); prim_u8vectorp (); push_arg1(); break;
 654     case 10:
 655       /* prim #%sernum */
 656       prim_sernum ();  push_arg1();  break;
 657     case 11:
 658       /* prim #%u8vector-length */
 659       arg1 = pop(); prim_u8vector_length (); push_arg1(); break;
 660     case 12:
 661       /* prim #%u8vector-copy! */
 662       arg5 = pop(); arg4 = pop(); arg3 = pop(); arg2 = pop(); arg1 = pop();
 663       prim_u8vector_copy (); break;
 664       break;
 665     case 13:
 666       /* shift */
 667       arg1 = pop();
 668       pop();
 669       push_arg1();
 670       break;
 671     case 14:
 672       /* pop */
 673       pop();
 674       break;
 675     case 15:
 676       /* return */
 677       arg1 = pop();
 678       arg2 = ram_get_cdr (cont);
 679       pc = ram_get_entry (arg2);
 680       env = ram_get_cdr (arg2);
 681       cont = ram_get_car (cont);
 682       push_arg1();
 683       arg2 = OBJ_FALSE;
 684       break;
 685     }
 686
 687     goto dispatch;
 688
 689     /*************************************************************************/
 690
 691   case PRIM4 :
 692
 693     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
 694
 695     switch (bytecode_lo4) {
 696     case 0:
 697       /* prim #%boolean? */
 698       arg1 = pop(); prim_booleanp (); push_arg1(); break;
 699     case 1:
 700       /* prim #%network-init */
 701       prim_network_init (); break;
 702     case 2:
 703       /* prim #%network-cleanup */
 704       prim_network_cleanup (); break;
 705     case 3:
 706       /* prim #%receive-packet-to-u8vector */
 707       arg1 = pop(); prim_receive_packet_to_u8vector (); push_arg1(); break;
 708     case 4:
 709       /* prim #%send-packet-from-u8vector */
 710       arg2 = pop(); arg1 = pop(); prim_send_packet_from_u8vector ();
 711       push_arg1(); break;
 712     case 5:
 713       arg2 = pop(); arg1 = pop(); prim_ior (); push_arg1(); break;
 714       break;
 715     case 6:
 716       arg2 = pop(); arg1 = pop(); prim_xor (); push_arg1(); break;
 717       break;
 718 #if 0
 719     case 7:
 720       break;
 721     case 8:
 722       break;
 723     case 9:
 724       break;
 725     case 10:
 726       break;
 727     case 11:
 728       break;
 729     case 12:
 730       break;
 731     case 13:
 732       break;
 733     case 14:
 734       break;
 735     case 15:
 736       break;
 737 #endif
 738     }
 739
 740     goto dispatch;
 741
 742     /*************************************************************************/
 743
 744   }
 745 }