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       IF_TRACE(printf("  (closure 0x%04x)\n", (arg2 << 8) | bytecode));
 306
 307       arg3 = pop(); // env
 308
 309       entry = (arg2 << 8) | bytecode;
 310
 311       arg1 =
 312         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 #if 0
 325     case 5: // call-toplevel-short
 326       FETCH_NEXT_BYTECODE(); // TODO the short version have a lot in common with the long ones, abstract ?
 327       // TODO short instructions don't work at the moment
 328       IF_TRACE(printf("  (call-toplevel-short 0x%04x)\n",
 329                       pc + bytecode + CODE_START));
 330
 331       entry = pc + bytecode + CODE_START;
 332       arg1 = OBJ_NULL;
 333
 334       build_env (rom_get (entry++));
 335       save_cont ();
 336
 337       env = arg1;
 338       pc = entry;
 339
 340       arg1 = OBJ_FALSE;
 341
 342       break;
 343
 344     case 6: // jump-toplevel-short
 345       FETCH_NEXT_BYTECODE();
 346
 347       IF_TRACE(printf("  (jump-toplevel-short 0x%04x)\n",
 348                       pc + bytecode + CODE_START));
 349
 350       entry = pc + bytecode + CODE_START;
 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-short
 363       FETCH_NEXT_BYTECODE();
 364
 365       IF_TRACE(printf("  (goto-short 0x%04x)\n", pc + bytecode + CODE_START));
 366
 367       pc = pc + bytecode + CODE_START;
 368
 369       break;
 370
 371     case 8: // goto-if-false-short
 372       FETCH_NEXT_BYTECODE();
 373
 374       IF_TRACE(printf("  (goto-if-false-short 0x%04x)\n",
 375                       pc + bytecode + CODE_START));
 376
 377       if (pop() == OBJ_FALSE)
 378         pc = pc + bytecode + CODE_START;
 379
 380       break;
 381
 382     case 9: // closure-short
 383       FETCH_NEXT_BYTECODE();
 384
 385       IF_TRACE(printf("  (closure-short 0x%04x)\n", pc + bytecode));
 386
 387       arg3 = pop(); // env
 388
 389       entry = pc + bytecode;
 390
 391       arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
 392                                   ((arg2 & 0x07) << 5) | (bytecode >> 3),
 393                                   ((bytecode &0x07) <<5) |((arg3 &0x1f00) >>8),
 394                                   arg3 & 0xff);
 395
 396       push_arg1();
 397
 398       arg3 = OBJ_FALSE;
 399
 400       break;
 401 #endif
 402
 403 #if 0
 404     case 10:
 405       break;
 406     case 11:
 407       break;
 408     case 12:
 409       break;
 410     case 13:
 411       break;
 412 #endif
 413     case 14: // push_global [long]
 414       FETCH_NEXT_BYTECODE();
 415
 416       IF_TRACE(printf("  (push-global [long] %d)\n", bytecode));
 417
 418       arg1 = get_global (bytecode);
 419
 420       push_arg1();
 421
 422       break;
 423
 424     case 15: // set_global [long]
 425       FETCH_NEXT_BYTECODE();
 426
 427       IF_TRACE(printf("  (set-global [long] %d)\n", bytecode));
 428
 429       set_global (bytecode, pop());
 430
 431       break;
 432     }
 433
 434     goto dispatch;
 435
 436     /*************************************************************************/
 437   case PUSH_CONSTANT_LONG :
 438
 439     /* push-constant [long] */
 440
 441     FETCH_NEXT_BYTECODE();
 442
 443     IF_TRACE(printf("  (push [long] 0x%04x)\n", (bytecode_lo4 << 8) + bytecode));
 444
 445     // necessary since SIXPIC would have kept the result of the shift at 8 bits
 446     arg1 = bytecode_lo4;
 447     arg1 = (arg1 << 8) | bytecode;
 448     push_arg1();
 449
 450     goto dispatch;
 451
 452     /*************************************************************************/
 453   case FREE1 : // FREE
 454
 455     goto dispatch;
 456
 457     /*************************************************************************/
 458   case FREE2 : // FREE
 459
 460     goto 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_leq ();      push_arg1();  break;
 488     case 10:
 489       arg2 = pop();  arg1 = pop();  prim_gt ();       push_arg1();  break;
 490     case 11:
 491       arg2 = pop();  arg1 = pop();  prim_geq ();      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     goto 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       pop_procedure ();
 534       build_env (handle_arity_and_rest_param (0));
 535
 536       env = arg1;
 537       pc = entry;
 538
 539       arg1 = OBJ_FALSE;
 540
 541       break;
 542     case 7:
 543       /* prim #%return-to-cont */
 544
 545       arg1 = pop(); /* value to return */
 546       cont = pop(); /* continuation */
 547
 548       arg2 = ram_get_cdr (cont);
 549
 550       pc = ram_get_entry (arg2);
 551
 552       env = ram_get_cdr (arg2);
 553       cont = ram_get_car (cont);
 554
 555       push_arg1();
 556       arg2 = OBJ_FALSE;
 557
 558       break;
 559     case 8:
 560       /* prim #%halt */
 561       return;
 562     case 9:
 563       /* prim #%symbol? */
 564       arg1 = pop();  prim_symbolp ();  push_arg1();  break;
 565     case 10:
 566       /* prim #%string? */
 567       arg1 = pop();  prim_stringp ();  push_arg1();  break;
 568     case 11:
 569       /* prim #%string->list */
 570       arg1 = pop();  prim_string2list ();  push_arg1();  break;
 571     case 12:
 572       /* prim #%list->string */
 573       arg1 = pop();  prim_list2string ();  push_arg1();  break;
 574     case 13:
 575       /* prim #%make-u8vector */
 576       arg2 = pop(); arg1 = pop(); prim_make_u8vector (); push_arg1(); break;
 577     case 14:
 578       /* prim #%u8vector-ref */
 579       arg2 = pop(); arg1 = pop(); prim_u8vector_ref (); push_arg1(); break;
 580     case 15:
 581       /* prim #%u8vector-set! */
 582       arg3 = pop(); arg2 = pop(); arg1 = pop(); prim_u8vector_set (); break;
 583     }
 584
 585     goto dispatch;
 586
 587     /*************************************************************************/
 588   case PRIM3 :
 589
 590     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
 591
 592     switch (bytecode_lo4) {
 593     case 0:
 594       /* prim #%print */
 595       arg1 = pop();
 596       prim_print ();
 597       break;
 598     case 1:
 599       /* prim #%clock */
 600       prim_clock ();  push_arg1();  break;
 601     case 2:
 602       /* prim #%motor */
 603       arg2 = pop();  arg1 = pop();  prim_motor ();  break;
 604     case 3:
 605       /* prim #%led */
 606       arg3 = pop();  arg2 = pop();  arg1 = pop();  prim_led ();  ;break;
 607     case 4:
 608       /* prim #%led2-color */
 609       arg1 = pop();  prim_led2_color ();  break;
 610     case 5:
 611       /* prim #%getchar-wait */
 612       arg2 = pop();  arg1 = pop();  prim_getchar_wait ();  push_arg1();  break;
 613     case 6:
 614       /* prim #%putchar */
 615       arg2 = pop();  arg1 = pop();  prim_putchar ();  break;
 616     case 7:
 617       /* prim #%beep */
 618       arg2 = pop();  arg1 = pop();  prim_beep ();  break;
 619     case 8:
 620       /* prim #%adc */
 621       arg1 = pop();  prim_adc ();  push_arg1();  break;
 622     case 9:
 623       /* prim #%u8vector? */
 624       arg1 = pop(); prim_u8vectorp (); push_arg1(); break;
 625     case 10:
 626       /* prim #%sernum */
 627       prim_sernum ();  push_arg1();  break;
 628     case 11:
 629       /* prim #%u8vector-length */
 630       arg1 = pop(); prim_u8vector_length (); push_arg1(); break;
 631     case 12:
 632       /* prim #%u8vector-copy! */
 633       arg5 = pop(); arg4 = pop(); arg3 = pop(); arg2 = pop(); arg1 = pop();
 634       prim_u8vector_copy (); break;
 635       break;
 636     case 13:
 637       /* shift */
 638       arg1 = pop();
 639       pop();
 640       push_arg1();
 641       break;
 642     case 14:
 643       /* pop */
 644       pop();
 645       break;
 646     case 15:
 647       /* return */
 648       arg1 = pop();
 649       arg2 = ram_get_cdr (cont);
 650       pc = ram_get_entry (arg2);
 651       env = ram_get_cdr (arg2);
 652       cont = ram_get_car (cont);
 653       push_arg1();
 654       arg2 = OBJ_FALSE;
 655       break;
 656     }
 657
 658     goto dispatch;
 659
 660     /*************************************************************************/
 661
 662   case PRIM4 :
 663
 664     IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
 665
 666     switch (bytecode_lo4) {
 667     case 0:
 668       /* prim #%boolean? */
 669       arg1 = pop(); prim_booleanp (); push_arg1(); break;
 670     case 1:
 671       /* prim #%network-init */
 672       prim_network_init (); break;
 673     case 2:
 674       /* prim #%network-cleanup */
 675       prim_network_cleanup (); break;
 676     case 3:
 677       /* prim #%receive-packet-to-u8vector */
 678       arg1 = pop(); prim_receive_packet_to_u8vector (); push_arg1(); break;
 679     case 4:
 680       /* prim #%send-packet-from-u8vector */
 681       arg2 = pop(); arg1 = pop(); prim_send_packet_from_u8vector ();
 682       push_arg1(); break;
 683     case 5:
 684       arg2 = pop(); arg1 = pop(); prim_ior (); push_arg1(); break;
 685       break;
 686     case 6:
 687       arg2 = pop(); arg1 = pop(); prim_xor (); push_arg1(); break;
 688       break;
 689 #if 0
 690     case 7:
 691       break;
 692     case 8:
 693       break;
 694     case 9:
 695       break;
 696     case 10:
 697       break;
 698     case 11:
 699       break;
 700     case 12:
 701       break;
 702     case 13:
 703       break;
 704     case 14:
 705       break;
 706     case 15:
 707       break;
 708 #endif
 709     }
 710
 711     goto dispatch;
 712
 713     /*************************************************************************/
 714
 715   }
 716 }