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