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