src/bin/embryo_cc_sc4.c

   1 /*  Small compiler - code generation (unoptimized "assembler" code)
   2  *
   3  *  Copyright (c) ITB CompuPhase, 1997-2003
   4  *
   5  *  This software is provided "as-is", without any express or implied warranty.
   6  *  In no event will the authors be held liable for any damages arising from
   7  *  the use of this software.
   8  *
   9  *  Permission is granted to anyone to use this software for any purpose,
  10  *  including commercial applications, and to alter it and redistribute it
  11  *  freely, subject to the following restrictions:
  12  *
  13  *  1.  The origin of this software must not be misrepresented; you must not
  14  *      claim that you wrote the original software. If you use this software in
  15  *      a product, an acknowledgment in the product documentation would be
  16  *      appreciated but is not required.
  17  *  2.  Altered source versions must be plainly marked as such, and must not be
  18  *      misrepresented as being the original software.
  19  *  3.  This notice may not be removed or altered from any source distribution.
  20  *
  21  *  Version: $Id$
  22  */
  23
  24
  25 #ifdef HAVE_CONFIG_H
  26 # include <config.h>
  27 #endif
  28
  29 #include <assert.h>
  30 #include <ctype.h>
  31 #include <stdio.h>
  32 #include <limits.h>             /* for PATH_MAX */
  33 #include <string.h>
  34
  35 #include "embryo_cc_sc.h"
  36
  37 /* When a subroutine returns to address 0, the AMX must halt. In earlier
  38  * releases, the RET and RETN opcodes checked for the special case 0 address.
  39  * Today, the compiler simply generates a HALT instruction at address 0. So
  40  * a subroutine can savely return to 0, and then encounter a HALT.
  41  */
  42 void
  43 writeleader(void)
  44 {
  45    assert(code_idx == 0);
  46    stgwrite(";program exit point\n");
  47    stgwrite("\thalt 0\n");
  48    /* calculate code length */
  49    code_idx += opcodes(1) + opargs(1);
  50 }
  51
  52 /*  writetrailer
  53  *  Not much left of this once important function.
  54  *
  55  *  Global references: sc_stksize       (referred to only)
  56  *                     sc_dataalign     (referred to only)
  57  *                     code_idx         (altered)
  58  *                     glb_declared     (altered)
  59  */
  60 void
  61 writetrailer(void)
  62 {
  63    assert(sc_dataalign % opcodes(1) == 0);      /* alignment must be a multiple of
  64                                                  * the opcode size */
  65    assert(sc_dataalign != 0);
  66
  67    /* pad code to align data segment */
  68    if ((code_idx % sc_dataalign) != 0)
  69      {
  70         begcseg();
  71         while ((code_idx % sc_dataalign) != 0)
  72            nooperation();
  73      }                          /* if */
  74
  75    /* pad data segment to align the stack and the heap */
  76    assert(litidx == 0);         /* literal queue should have been emptied */
  77    assert(sc_dataalign % sizeof(cell) == 0);
  78    if (((glb_declared * sizeof(cell)) % sc_dataalign) != 0)
  79      {
  80         begdseg();
  81         defstorage();
  82         while (((glb_declared * sizeof(cell)) % sc_dataalign) != 0)
  83           {
  84              stgwrite("0 ");
  85              glb_declared++;
  86           }                     /* while */
  87      }                          /* if */
  88
  89    stgwrite("\nSTKSIZE ");      /* write stack size (align stack top) */
  90    outval(sc_stksize - (sc_stksize % sc_dataalign), TRUE);
  91 }
  92
  93 /*
  94  *  Start (or restart) the CODE segment.
  95  *
  96  *  In fact, the code and data segment specifiers are purely informational;
  97  *  the "DUMP" instruction itself already specifies that the following values
  98  *  should go to the data segment. All otherinstructions go to the code
  99  *  segment.
 100  *
 101  *  Global references: curseg
 102  */
 103 void
 104 begcseg(void)
 105 {
 106    if (curseg != sIN_CSEG)
 107      {
 108         stgwrite("\n");
 109         stgwrite("CODE\t; ");
 110         outval(code_idx, TRUE);
 111         curseg = sIN_CSEG;
 112      }                          /* endif */
 113 }
 114
 115 /*
 116  *  Start (or restart) the DATA segment.
 117  *
 118  *  Global references: curseg
 119  */
 120 void
 121 begdseg(void)
 122 {
 123    if (curseg != sIN_DSEG)
 124      {
 125         stgwrite("\n");
 126         stgwrite("DATA\t; ");
 127         outval(glb_declared - litidx, TRUE);
 128         curseg = sIN_DSEG;
 129      }                          /* if */
 130 }
 131
 132 void
 133 setactivefile(int fnumber)
 134 {
 135    stgwrite("curfile ");
 136    outval(fnumber, TRUE);
 137 }
 138
 139 cell
 140 nameincells(char *name)
 141 {
 142    cell                clen =
 143       (strlen(name) + sizeof(cell)) & ~(sizeof(cell) - 1);
 144    return clen;
 145 }
 146
 147 void
 148 setfile(char *name, int fileno)
 149 {
 150    if ((sc_debug & sSYMBOLIC) != 0)
 151      {
 152         begcseg();
 153         stgwrite("file ");
 154         outval(fileno, FALSE);
 155         stgwrite(" ");
 156         stgwrite(name);
 157         stgwrite("\n");
 158         /* calculate code length */
 159         code_idx += opcodes(1) + opargs(2) + nameincells(name);
 160      }                          /* if */
 161 }
 162
 163 void
 164 setline(int line, int fileno)
 165 {
 166    if ((sc_debug & (sSYMBOLIC | sCHKBOUNDS)) != 0)
 167      {
 168         stgwrite("line ");
 169         outval(line, FALSE);
 170         stgwrite(" ");
 171         outval(fileno, FALSE);
 172         stgwrite("\t; ");
 173         outval(code_idx, TRUE);
 174         code_idx += opcodes(1) + opargs(2);
 175      }                          /* if */
 176 }
 177
 178 /*  setlabel
 179  *
 180  *  Post a code label (specified as a number), on a new line.
 181  */
 182 void
 183 setlabel(int number)
 184 {
 185    assert(number >= 0);
 186    stgwrite("l.");
 187    stgwrite((char *)itoh(number));
 188    /* To assist verification of the assembled code, put the address of the
 189     * label as a comment. However, labels that occur inside an expression
 190     * may move (through optimization or through re-ordering). So write the
 191     * address only if it is known to accurate.
 192     */
 193    if (!staging)
 194      {
 195         stgwrite("\t\t; ");
 196         outval(code_idx, FALSE);
 197      }                          /* if */
 198    stgwrite("\n");
 199 }
 200
 201 /* Write a token that signifies the end of an expression, or the end of a
 202  * function parameter. This allows several simple optimizations by the peephole
 203  * optimizer.
 204  */
 205 void
 206 endexpr(int fullexpr)
 207 {
 208    if (fullexpr)
 209       stgwrite("\t;$exp\n");
 210    else
 211       stgwrite("\t;$par\n");
 212 }
 213
 214 /*  startfunc   - declare a CODE entry point (function start)
 215  *
 216  *  Global references: funcstatus  (referred to only)
 217  */
 218 void
 219 startfunc(char *fname __UNUSED__)
 220 {
 221    stgwrite("\tproc");
 222    stgwrite("\n");
 223    code_idx += opcodes(1);
 224 }
 225
 226 /*  endfunc
 227  *
 228  *  Declare a CODE ending point (function end)
 229  */
 230 void
 231 endfunc(void)
 232 {
 233    stgwrite("\n");              /* skip a line */
 234 }
 235
 236 /*  alignframe
 237  *
 238  *  Aligns the frame (and the stack) of the current function to a multiple
 239  *  of the specified byte count. Two caveats: the alignment ("numbytes") should
 240  *  be a power of 2, and this alignment must be done right after the frame
 241  *  is set up (before the first variable is declared)
 242  */
 243 void
 244 alignframe(int numbytes)
 245 {
 246 #if !defined NDEBUG
 247    /* "numbytes" should be a power of 2 for this code to work */
 248    int                 i, count = 0;
 249
 250    for (i = 0; i < (int)(sizeof(numbytes) * 8); i++)
 251       if (numbytes & (1 << i))
 252          count++;
 253    assert(count == 1);
 254 #endif
 255
 256    stgwrite("\tlctrl 4\n");     /* get STK in PRI */
 257    stgwrite("\tconst.alt ");    /* get ~(numbytes-1) in ALT */
 258    outval(~(numbytes - 1), TRUE);
 259    stgwrite("\tand\n");         /* PRI = STK "and" ~(numbytes-1) */
 260    stgwrite("\tsctrl 4\n");     /* set the new value of STK ... */
 261    stgwrite("\tsctrl 5\n");     /* ... and FRM */
 262    code_idx += opcodes(5) + opargs(4);
 263 }
 264
 265 /*  Define a variable or function
 266  */
 267 void
 268 defsymbol(char *name, int ident, int vclass, cell offset, int tag)
 269 {
 270    if ((sc_debug & sSYMBOLIC) != 0)
 271      {
 272         begcseg();              /* symbol definition in code segment */
 273         stgwrite("symbol ");
 274
 275         stgwrite(name);
 276         stgwrite(" ");
 277
 278         outval(offset, FALSE);
 279         stgwrite(" ");
 280
 281         outval(vclass, FALSE);
 282         stgwrite(" ");
 283
 284         outval(ident, TRUE);
 285
 286         code_idx += opcodes(1) + opargs(3) + nameincells(name); /* class and ident encoded in "flags" */
 287
 288         /* also write the optional tag */
 289         if (tag != 0)
 290           {
 291              assert((tag & TAGMASK) != 0);
 292              stgwrite("symtag ");
 293              outval(tag & TAGMASK, TRUE);
 294              code_idx += opcodes(1) + opargs(1);
 295           }                     /* if */
 296      }                          /* if */
 297 }
 298
 299 void
 300 symbolrange(int level, cell size)
 301 {
 302    if ((sc_debug & sSYMBOLIC) != 0)
 303      {
 304         begcseg();              /* symbol definition in code segment */
 305         stgwrite("srange ");
 306         outval(level, FALSE);
 307         stgwrite(" ");
 308         outval(size, TRUE);
 309         code_idx += opcodes(1) + opargs(2);
 310      }                          /* if */
 311 }
 312
 313 /*  rvalue
 314  *
 315  *  Generate code to get the value of a symbol into "primary".
 316  */
 317 void
 318 rvalue(value * lval)
 319 {
 320    symbol             *sym;
 321
 322    sym = lval->sym;
 323    if (lval->ident == iARRAYCELL)
 324      {
 325         /* indirect fetch, address already in PRI */
 326         stgwrite("\tload.i\n");
 327         code_idx += opcodes(1);
 328      }
 329    else if (lval->ident == iARRAYCHAR)
 330      {
 331         /* indirect fetch of a character from a pack, address already in PRI */
 332         stgwrite("\tlodb.i ");
 333         outval(charbits / 8, TRUE);     /* read one or two bytes */
 334         code_idx += opcodes(1) + opargs(1);
 335      }
 336    else if (lval->ident == iREFERENCE)
 337      {
 338         /* indirect fetch, but address not yet in PRI */
 339         assert(sym != NULL);
 340         assert(sym->vclass == sLOCAL);  /* global references don't exist in Small */
 341         if (sym->vclass == sLOCAL)
 342            stgwrite("\tlref.s.pri ");
 343         else
 344            stgwrite("\tlref.pri ");
 345         outval(sym->addr, TRUE);
 346         markusage(sym, uREAD);
 347         code_idx += opcodes(1) + opargs(1);
 348      }
 349    else
 350      {
 351         /* direct or stack relative fetch */
 352         assert(sym != NULL);
 353         if (sym->vclass == sLOCAL)
 354            stgwrite("\tload.s.pri ");
 355         else
 356            stgwrite("\tload.pri ");
 357         outval(sym->addr, TRUE);
 358         markusage(sym, uREAD);
 359         code_idx += opcodes(1) + opargs(1);
 360      }                          /* if */
 361 }
 362
 363 /*
 364  *  Get the address of a symbol into the primary register (used for arrays,
 365  *  and for passing arguments by reference).
 366  */
 367 void
 368 address(symbol * sym)
 369 {
 370    assert(sym != NULL);
 371    /* the symbol can be a local array, a global array, or an array
 372     * that is passed by reference.
 373     */
 374    if (sym->ident == iREFARRAY || sym->ident == iREFERENCE)
 375      {
 376         /* reference to a variable or to an array; currently this is
 377          * always a local variable */
 378         stgwrite("\tload.s.pri ");
 379      }
 380    else
 381      {
 382         /* a local array or local variable */
 383         if (sym->vclass == sLOCAL)
 384            stgwrite("\taddr.pri ");
 385         else
 386            stgwrite("\tconst.pri ");
 387      }                          /* if */
 388    outval(sym->addr, TRUE);
 389    markusage(sym, uREAD);
 390    code_idx += opcodes(1) + opargs(1);
 391 }
 392
 393 /*  store
 394  *
 395  *  Saves the contents of "primary" into a memory cell, either directly
 396  *  or indirectly (at the address given in the alternate register).
 397  */
 398 void
 399 store(value * lval)
 400 {
 401    symbol             *sym;
 402
 403    sym = lval->sym;
 404    if (lval->ident == iARRAYCELL)
 405      {
 406         /* store at address in ALT */
 407         stgwrite("\tstor.i\n");
 408         code_idx += opcodes(1);
 409      }
 410    else if (lval->ident == iARRAYCHAR)
 411      {
 412         /* store at address in ALT */
 413         stgwrite("\tstrb.i ");
 414         outval(charbits / 8, TRUE);     /* write one or two bytes */
 415         code_idx += opcodes(1) + opargs(1);
 416      }
 417    else if (lval->ident == iREFERENCE)
 418      {
 419         assert(sym != NULL);
 420         if (sym->vclass == sLOCAL)
 421            stgwrite("\tsref.s.pri ");
 422         else
 423            stgwrite("\tsref.pri ");
 424         outval(sym->addr, TRUE);
 425         code_idx += opcodes(1) + opargs(1);
 426      }
 427    else
 428      {
 429         assert(sym != NULL);
 430         markusage(sym, uWRITTEN);
 431         if (sym->vclass == sLOCAL)
 432            stgwrite("\tstor.s.pri ");
 433         else
 434            stgwrite("\tstor.pri ");
 435         outval(sym->addr, TRUE);
 436         code_idx += opcodes(1) + opargs(1);
 437      }                          /* if */
 438 }
 439
 440 /* source must in PRI, destination address in ALT. The "size"
 441  * parameter is in bytes, not cells.
 442  */
 443 void
 444 memcopy(cell size)
 445 {
 446    stgwrite("\tmovs ");
 447    outval(size, TRUE);
 448
 449    code_idx += opcodes(1) + opargs(1);
 450 }
 451
 452 /* Address of the source must already have been loaded in PRI
 453  * "size" is the size in bytes (not cells).
 454  */
 455 void
 456 copyarray(symbol * sym, cell size)
 457 {
 458    assert(sym != NULL);
 459    /* the symbol can be a local array, a global array, or an array
 460     * that is passed by reference.
 461     */
 462    if (sym->ident == iREFARRAY)
 463      {
 464         /* reference to an array; currently this is always a local variable */
 465         assert(sym->vclass == sLOCAL);  /* symbol must be stack relative */
 466         stgwrite("\tload.s.alt ");
 467      }
 468    else
 469      {
 470         /* a local or global array */
 471         if (sym->vclass == sLOCAL)
 472            stgwrite("\taddr.alt ");
 473         else
 474            stgwrite("\tconst.alt ");
 475      }                          /* if */
 476    outval(sym->addr, TRUE);
 477    markusage(sym, uWRITTEN);
 478
 479    code_idx += opcodes(1) + opargs(1);
 480    memcopy(size);
 481 }
 482
 483 void
 484 fillarray(symbol * sym, cell size, cell val)
 485 {
 486    const1(val);         /* load val in PRI */
 487
 488    assert(sym != NULL);
 489    /* the symbol can be a local array, a global array, or an array
 490     * that is passed by reference.
 491     */
 492    if (sym->ident == iREFARRAY)
 493      {
 494         /* reference to an array; currently this is always a local variable */
 495         assert(sym->vclass == sLOCAL);  /* symbol must be stack relative */
 496         stgwrite("\tload.s.alt ");
 497      }
 498    else
 499      {
 500         /* a local or global array */
 501         if (sym->vclass == sLOCAL)
 502            stgwrite("\taddr.alt ");
 503         else
 504            stgwrite("\tconst.alt ");
 505      }                          /* if */
 506    outval(sym->addr, TRUE);
 507    markusage(sym, uWRITTEN);
 508
 509    stgwrite("\tfill ");
 510    outval(size, TRUE);
 511
 512    code_idx += opcodes(2) + opargs(2);
 513 }
 514
 515 /*
 516  *  Instruction to get an immediate value into the primary register
 517  */
 518 void
 519 const1(cell val)
 520 {
 521    if (val == 0)
 522      {
 523         stgwrite("\tzero.pri\n");
 524         code_idx += opcodes(1);
 525      }
 526    else
 527      {
 528         stgwrite("\tconst.pri ");
 529         outval(val, TRUE);
 530         code_idx += opcodes(1) + opargs(1);
 531      }                          /* if */
 532 }
 533
 534 /*
 535  *  Instruction to get an immediate value into the secondary register
 536  */
 537 void
 538 const2(cell val)
 539 {
 540    if (val == 0)
 541      {
 542         stgwrite("\tzero.alt\n");
 543         code_idx += opcodes(1);
 544      }
 545    else
 546      {
 547         stgwrite("\tconst.alt ");
 548         outval(val, TRUE);
 549         code_idx += opcodes(1) + opargs(1);
 550      }                          /* if */
 551 }
 552
 553 /* Copy value in secondary register to the primary register */
 554 void
 555 moveto1(void)
 556 {
 557    stgwrite("\tmove.pri\n");
 558    code_idx += opcodes(1) + opargs(0);
 559 }
 560
 561 /*
 562  *  Push primary register onto the stack
 563  */
 564 void
 565 push1(void)
 566 {
 567    stgwrite("\tpush.pri\n");
 568    code_idx += opcodes(1);
 569 }
 570
 571 /*
 572  *  Push alternate register onto the stack
 573  */
 574 void
 575 push2(void)
 576 {
 577    stgwrite("\tpush.alt\n");
 578    code_idx += opcodes(1);
 579 }
 580
 581 /*
 582  *  Push a constant value onto the stack
 583  */
 584 void
 585 pushval(cell val)
 586 {
 587    stgwrite("\tpush.c ");
 588    outval(val, TRUE);
 589    code_idx += opcodes(1) + opargs(1);
 590 }
 591
 592 /*
 593  *  pop stack to the primary register
 594  */
 595 void
 596 pop1(void)
 597 {
 598    stgwrite("\tpop.pri\n");
 599    code_idx += opcodes(1);
 600 }
 601
 602 /*
 603  *  pop stack to the secondary register
 604  */
 605 void
 606 pop2(void)
 607 {
 608    stgwrite("\tpop.alt\n");
 609    code_idx += opcodes(1);
 610 }
 611
 612 /*
 613  *  swap the top-of-stack with the value in primary register
 614  */
 615 void
 616 swap1(void)
 617 {
 618    stgwrite("\tswap.pri\n");
 619    code_idx += opcodes(1);
 620 }
 621
 622 /* Switch statements
 623  * The "switch" statement generates a "case" table using the "CASE" opcode.
 624  * The case table contains a list of records, each record holds a comparison
 625  * value and a label to branch to on a match. The very first record is an
 626  * exception: it holds the size of the table (excluding the first record) and
 627  * the label to branch to when none of the values in the case table match.
 628  * The case table is sorted on the comparison value. This allows more advanced
 629  * abstract machines to sift the case table with a binary search.
 630  */
 631 void
 632 ffswitch(int label)
 633 {
 634    stgwrite("\tswitch ");
 635    outval(label, TRUE);         /* the label is the address of the case table */
 636    code_idx += opcodes(1) + opargs(1);
 637 }
 638
 639 void
 640 ffcase(cell val, char *labelname, int newtable)
 641 {
 642    if (newtable)
 643      {
 644         stgwrite("\tcasetbl\n");
 645         code_idx += opcodes(1);
 646      }                          /* if */
 647    stgwrite("\tcase ");
 648    outval(val, FALSE);
 649    stgwrite(" ");
 650    stgwrite(labelname);
 651    stgwrite("\n");
 652    code_idx += opcodes(0) + opargs(2);
 653 }
 654
 655 /*
 656  *  Call specified function
 657  */
 658 void
 659 ffcall(symbol * sym, int numargs)
 660 {
 661    assert(sym != NULL);
 662    assert(sym->ident == iFUNCTN);
 663    if ((sym->usage & uNATIVE) != 0)
 664      {
 665         /* reserve a SYSREQ id if called for the first time */
 666         if (sc_status == statWRITE && (sym->usage & uREAD) == 0
 667             && sym->addr >= 0)
 668            sym->addr = ntv_funcid++;
 669         stgwrite("\tsysreq.c ");
 670         outval(sym->addr, FALSE);
 671         stgwrite("\n\tstack ");
 672         outval((numargs + 1) * sizeof(cell), TRUE);
 673         code_idx += opcodes(2) + opargs(2);
 674      }
 675    else
 676      {
 677         /* normal function */
 678         stgwrite("\tcall ");
 679         stgwrite(sym->name);
 680         stgwrite("\n");
 681         code_idx += opcodes(1) + opargs(1);
 682      }                          /* if */
 683 }
 684
 685 /*  Return from function
 686  *
 687  *  Global references: funcstatus  (referred to only)
 688  */
 689 void
 690 ffret(void)
 691 {
 692    stgwrite("\tretn\n");
 693    code_idx += opcodes(1);
 694 }
 695
 696 void
 697 ffabort(int reason)
 698 {
 699    stgwrite("\thalt ");
 700    outval(reason, TRUE);
 701    code_idx += opcodes(1) + opargs(1);
 702 }
 703
 704 void
 705 ffbounds(cell size)
 706 {
 707    if ((sc_debug & sCHKBOUNDS) != 0)
 708      {
 709         stgwrite("\tbounds ");
 710         outval(size, TRUE);
 711         code_idx += opcodes(1) + opargs(1);
 712      }                          /* if */
 713 }
 714
 715 /*
 716  *  Jump to local label number (the number is converted to a name)
 717  */
 718 void
 719 jumplabel(int number)
 720 {
 721    stgwrite("\tjump ");
 722    outval(number, TRUE);
 723    code_idx += opcodes(1) + opargs(1);
 724 }
 725
 726 /*
 727  *   Define storage (global and static variables)
 728  */
 729 void
 730 defstorage(void)
 731 {
 732    stgwrite("dump ");
 733 }
 734
 735 /*
 736  *  Inclrement/decrement stack pointer. Note that this routine does
 737  *  nothing if the delta is zero.
 738  */
 739 void
 740 modstk(int delta)
 741 {
 742    if (delta)
 743      {
 744         stgwrite("\tstack ");
 745         outval(delta, TRUE);
 746         code_idx += opcodes(1) + opargs(1);
 747      }                          /* if */
 748 }
 749
 750 /* set the stack to a hard offset from the frame */
 751 void
 752 setstk(cell val)
 753 {
 754    stgwrite("\tlctrl 5\n");     /* get FRM */
 755    assert(val <= 0);            /* STK should always become <= FRM */
 756    if (val < 0)
 757      {
 758         stgwrite("\tadd.c ");
 759         outval(val, TRUE);      /* add (negative) offset */
 760         code_idx += opcodes(1) + opargs(1);
 761         // ??? write zeros in the space between STK and the val in PRI (the new stk)
 762         //     get val of STK in ALT
 763         //     zero PRI
 764         //     need new FILL opcode that takes a variable size
 765      }                          /* if */
 766    stgwrite("\tsctrl 4\n");     /* store in STK */
 767    code_idx += opcodes(2) + opargs(2);
 768 }
 769
 770 void
 771 modheap(int delta)
 772 {
 773    if (delta)
 774      {
 775         stgwrite("\theap ");
 776         outval(delta, TRUE);
 777         code_idx += opcodes(1) + opargs(1);
 778      }                          /* if */
 779 }
 780
 781 void
 782 setheap_pri(void)
 783 {
 784    stgwrite("\theap ");         /* ALT = HEA++ */
 785    outval(sizeof(cell), TRUE);
 786    stgwrite("\tstor.i\n");      /* store PRI (default value) at address ALT */
 787    stgwrite("\tmove.pri\n");    /* move ALT to PRI: PRI contains the address */
 788    code_idx += opcodes(3) + opargs(1);
 789 }
 790
 791 void
 792 setheap(cell val)
 793 {
 794    stgwrite("\tconst.pri ");    /* load default val in PRI */
 795    outval(val, TRUE);
 796    code_idx += opcodes(1) + opargs(1);
 797    setheap_pri();
 798 }
 799
 800 /*
 801  *  Convert a cell number to a "byte" address; i.e. double or quadruple
 802  *  the primary register.
 803  */
 804 void
 805 cell2addr(void)
 806 {
 807 #if defined(BIT16)
 808    stgwrite("\tshl.c.pri 1\n");
 809 #else
 810    stgwrite("\tshl.c.pri 2\n");
 811 #endif
 812    code_idx += opcodes(1) + opargs(1);
 813 }
 814
 815 /*
 816  *  Double or quadruple the alternate register.
 817  */
 818 void
 819 cell2addr_alt(void)
 820 {
 821 #if defined(BIT16)
 822    stgwrite("\tshl.c.alt 1\n");
 823 #else
 824    stgwrite("\tshl.c.alt 2\n");
 825 #endif
 826    code_idx += opcodes(1) + opargs(1);
 827 }
 828
 829 /*
 830  *  Convert "distance of addresses" to "number of cells" in between.
 831  *  Or convert a number of packed characters to the number of cells (with
 832  *  truncation).
 833  */
 834 void
 835 addr2cell(void)
 836 {
 837 #if defined(BIT16)
 838    stgwrite("\tshr.c.pri 1\n");
 839 #else
 840    stgwrite("\tshr.c.pri 2\n");
 841 #endif
 842    code_idx += opcodes(1) + opargs(1);
 843 }
 844
 845 /* Convert from character index to byte address. This routine does
 846  * nothing if a character has the size of a byte.
 847  */
 848 void
 849 char2addr(void)
 850 {
 851    if (charbits == 16)
 852      {
 853         stgwrite("\tshl.c.pri 1\n");
 854         code_idx += opcodes(1) + opargs(1);
 855      }                          /* if */
 856 }
 857
 858 /* Align PRI (which should hold a character index) to an address.
 859  * The first character in a "pack" occupies the highest bits of
 860  * the cell. This is at the lower memory address on Big Endian
 861  * computers and on the higher address on Little Endian computers.
 862  * The ALIGN.pri/alt instructions must solve this machine dependence;
 863  * that is, on Big Endian computers, ALIGN.pri/alt shuold do nothing
 864  * and on Little Endian computers they should toggle the address.
 865  */
 866 void
 867 charalign(void)
 868 {
 869    stgwrite("\talign.pri ");
 870    outval(charbits / 8, TRUE);
 871    code_idx += opcodes(1) + opargs(1);
 872 }
 873
 874 /*
 875  *  Add a constant to the primary register.
 876  */
 877 void
 878 addconst(cell val)
 879 {
 880    if (val != 0)
 881      {
 882         stgwrite("\tadd.c ");
 883         outval(val, TRUE);
 884         code_idx += opcodes(1) + opargs(1);
 885      }                          /* if */
 886 }
 887
 888 /*
 889  *  signed multiply of primary and secundairy registers (result in primary)
 890  */
 891 void
 892 os_mult(void)
 893 {
 894    stgwrite("\tsmul\n");
 895    code_idx += opcodes(1);
 896 }
 897
 898 /*
 899  *  signed divide of alternate register by primary register (quotient in
 900  *  primary; remainder in alternate)
 901  */
 902 void
 903 os_div(void)
 904 {
 905    stgwrite("\tsdiv.alt\n");
 906    code_idx += opcodes(1);
 907 }
 908
 909 /*
 910  *  modulus of (alternate % primary), result in primary (signed)
 911  */
 912 void
 913 os_mod(void)
 914 {
 915    stgwrite("\tsdiv.alt\n");
 916    stgwrite("\tmove.pri\n");    /* move ALT to PRI */
 917    code_idx += opcodes(2);
 918 }
 919
 920 /*
 921  *  Add primary and alternate registers (result in primary).
 922  */
 923 void
 924 ob_add(void)
 925 {
 926    stgwrite("\tadd\n");
 927    code_idx += opcodes(1);
 928 }
 929
 930 /*
 931  *  subtract primary register from alternate register (result in primary)
 932  */
 933 void
 934 ob_sub(void)
 935 {
 936    stgwrite("\tsub.alt\n");
 937    code_idx += opcodes(1);
 938 }
 939
 940 /*
 941  *  arithmic shift left alternate register the number of bits
 942  *  given in the primary register (result in primary).
 943  *  There is no need for a "logical shift left" routine, since
 944  *  logical shift left is identical to arithmic shift left.
 945  */
 946 void
 947 ob_sal(void)
 948 {
 949    stgwrite("\txchg\n");
 950    stgwrite("\tshl\n");
 951    code_idx += opcodes(2);
 952 }
 953
 954 /*
 955  *  arithmic shift right alternate register the number of bits
 956  *  given in the primary register (result in primary).
 957  */
 958 void
 959 os_sar(void)
 960 {
 961    stgwrite("\txchg\n");
 962    stgwrite("\tsshr\n");
 963    code_idx += opcodes(2);
 964 }
 965
 966 /*
 967  *  logical (unsigned) shift right of the alternate register by the
 968  *  number of bits given in the primary register (result in primary).
 969  */
 970 void
 971 ou_sar(void)
 972 {
 973    stgwrite("\txchg\n");
 974    stgwrite("\tshr\n");
 975    code_idx += opcodes(2);
 976 }
 977
 978 /*
 979  *  inclusive "or" of primary and secondary registers (result in primary)
 980  */
 981 void
 982 ob_or(void)
 983 {
 984    stgwrite("\tor\n");
 985    code_idx += opcodes(1);
 986 }
 987
 988 /*
 989  *  "exclusive or" of primary and alternate registers (result in primary)
 990  */
 991 void
 992 ob_xor(void)
 993 {
 994    stgwrite("\txor\n");
 995    code_idx += opcodes(1);
 996 }
 997
 998 /*
 999  *  "and" of primary and secundairy registers (result in primary)
1000  */
1001 void
1002 ob_and(void)
1003 {
1004    stgwrite("\tand\n");
1005    code_idx += opcodes(1);
1006 }
1007
1008 /*
1009  *  test ALT==PRI; result in primary register (1 or 0).
1010  */
1011 void
1012 ob_eq(void)
1013 {
1014    stgwrite("\teq\n");
1015    code_idx += opcodes(1);
1016 }
1017
1018 /*
1019  *  test ALT!=PRI
1020  */
1021 void
1022 ob_ne(void)
1023 {
1024    stgwrite("\tneq\n");
1025    code_idx += opcodes(1);
1026 }
1027
1028 /* The abstract machine defines the relational instructions so that PRI is
1029  * on the left side and ALT on the right side of the operator. For example,
1030  * SLESS sets PRI to either 1 or 0 depending on whether the expression
1031  * "PRI < ALT" is true.
1032  *
1033  * The compiler generates comparisons with ALT on the left side of the
1034  * relational operator and PRI on the right side. The XCHG instruction
1035  * prefixing the relational operators resets this. We leave it to the
1036  * peephole optimizer to choose more compact instructions where possible.
1037  */
1038
1039 /* Relational operator prefix for chained relational expressions. The
1040  * "suffix" code restores the stack.
1041  * For chained relational operators, the goal is to keep the comparison
1042  * result "so far" in PRI and the value of the most recent operand in
1043  * ALT, ready for a next comparison.
1044  * The "prefix" instruction pushed the comparison result (PRI) onto the
1045  * stack and moves the value of ALT into PRI. If there is a next comparison,
1046  * PRI can now serve as the "left" operand of the relational operator.
1047  */
1048 void
1049 relop_prefix(void)
1050 {
1051    stgwrite("\tpush.pri\n");
1052    stgwrite("\tmove.pri\n");
1053    code_idx += opcodes(2);
1054 }
1055
1056 void
1057 relop_suffix(void)
1058 {
1059    stgwrite("\tswap.alt\n");
1060    stgwrite("\tand\n");
1061    stgwrite("\tpop.alt\n");
1062    code_idx += opcodes(3);
1063 }
1064
1065 /*
1066  *  test ALT<PRI (signed)
1067  */
1068 void
1069 os_lt(void)
1070 {
1071    stgwrite("\txchg\n");
1072    stgwrite("\tsless\n");
1073    code_idx += opcodes(2);
1074 }
1075
1076 /*
1077  *  test ALT<=PRI (signed)
1078  */
1079 void
1080 os_le(void)
1081 {
1082    stgwrite("\txchg\n");
1083    stgwrite("\tsleq\n");
1084    code_idx += opcodes(2);
1085 }
1086
1087 /*
1088  *  test ALT>PRI (signed)
1089  */
1090 void
1091 os_gt(void)
1092 {
1093    stgwrite("\txchg\n");
1094    stgwrite("\tsgrtr\n");
1095    code_idx += opcodes(2);
1096 }
1097
1098 /*
1099  *  test ALT>=PRI (signed)
1100  */
1101 void
1102 os_ge(void)
1103 {
1104    stgwrite("\txchg\n");
1105    stgwrite("\tsgeq\n");
1106    code_idx += opcodes(2);
1107 }
1108
1109 /*
1110  *  logical negation of primary register
1111  */
1112 void
1113 lneg(void)
1114 {
1115    stgwrite("\tnot\n");
1116    code_idx += opcodes(1);
1117 }
1118
1119 /*
1120  *  two's complement primary register
1121  */
1122 void
1123 neg(void)
1124 {
1125    stgwrite("\tneg\n");
1126    code_idx += opcodes(1);
1127 }
1128
1129 /*
1130  *  one's complement of primary register
1131  */
1132 void
1133 invert(void)
1134 {
1135    stgwrite("\tinvert\n");
1136    code_idx += opcodes(1);
1137 }
1138
1139 /*
1140  *  nop
1141  */
1142 void
1143 nooperation(void)
1144 {
1145    stgwrite("\tnop\n");
1146    code_idx += opcodes(1);
1147 }
1148
1149 /*  increment symbol
1150  */
1151 void
1152 inc(value * lval)
1153 {
1154    symbol             *sym;
1155
1156    sym = lval->sym;
1157    if (lval->ident == iARRAYCELL)
1158      {
1159         /* indirect increment, address already in PRI */
1160         stgwrite("\tinc.i\n");
1161         code_idx += opcodes(1);
1162      }
1163    else if (lval->ident == iARRAYCHAR)
1164      {
1165         /* indirect increment of single character, address already in PRI */
1166         stgwrite("\tpush.pri\n");
1167         stgwrite("\tpush.alt\n");
1168         stgwrite("\tmove.alt\n");       /* copy address */
1169         stgwrite("\tlodb.i ");  /* read from PRI into PRI */
1170         outval(charbits / 8, TRUE);     /* read one or two bytes */
1171         stgwrite("\tinc.pri\n");
1172         stgwrite("\tstrb.i ");  /* write PRI to ALT */
1173         outval(charbits / 8, TRUE);     /* write one or two bytes */
1174         stgwrite("\tpop.alt\n");
1175         stgwrite("\tpop.pri\n");
1176         code_idx += opcodes(8) + opargs(2);
1177      }
1178    else if (lval->ident == iREFERENCE)
1179      {
1180         assert(sym != NULL);
1181         stgwrite("\tpush.pri\n");
1182         /* load dereferenced value */
1183         assert(sym->vclass == sLOCAL);  /* global references don't exist in Small */
1184         if (sym->vclass == sLOCAL)
1185            stgwrite("\tlref.s.pri ");
1186         else
1187            stgwrite("\tlref.pri ");
1188         outval(sym->addr, TRUE);
1189         /* increment */
1190         stgwrite("\tinc.pri\n");
1191         /* store dereferenced value */
1192         if (sym->vclass == sLOCAL)
1193            stgwrite("\tsref.s.pri ");
1194         else
1195            stgwrite("\tsref.pri ");
1196         outval(sym->addr, TRUE);
1197         stgwrite("\tpop.pri\n");
1198         code_idx += opcodes(5) + opargs(2);
1199      }
1200    else
1201      {
1202         /* local or global variable */
1203         assert(sym != NULL);
1204         if (sym->vclass == sLOCAL)
1205            stgwrite("\tinc.s ");
1206         else
1207            stgwrite("\tinc ");
1208         outval(sym->addr, TRUE);
1209         code_idx += opcodes(1) + opargs(1);
1210      }                          /* if */
1211 }
1212
1213 /*  decrement symbol
1214  *
1215  *  in case of an integer pointer, the symbol must be incremented by 2.
1216  */
1217 void
1218 dec(value * lval)
1219 {
1220    symbol             *sym;
1221
1222    sym = lval->sym;
1223    if (lval->ident == iARRAYCELL)
1224      {
1225         /* indirect decrement, address already in PRI */
1226         stgwrite("\tdec.i\n");
1227         code_idx += opcodes(1);
1228      }
1229    else if (lval->ident == iARRAYCHAR)
1230      {
1231         /* indirect decrement of single character, address already in PRI */
1232         stgwrite("\tpush.pri\n");
1233         stgwrite("\tpush.alt\n");
1234         stgwrite("\tmove.alt\n");       /* copy address */
1235         stgwrite("\tlodb.i ");  /* read from PRI into PRI */
1236         outval(charbits / 8, TRUE);     /* read one or two bytes */
1237         stgwrite("\tdec.pri\n");
1238         stgwrite("\tstrb.i ");  /* write PRI to ALT */
1239         outval(charbits / 8, TRUE);     /* write one or two bytes */
1240         stgwrite("\tpop.alt\n");
1241         stgwrite("\tpop.pri\n");
1242         code_idx += opcodes(8) + opargs(2);
1243      }
1244    else if (lval->ident == iREFERENCE)
1245      {
1246         assert(sym != NULL);
1247         stgwrite("\tpush.pri\n");
1248         /* load dereferenced value */
1249         assert(sym->vclass == sLOCAL);  /* global references don't exist in Small */
1250         if (sym->vclass == sLOCAL)
1251            stgwrite("\tlref.s.pri ");
1252         else
1253            stgwrite("\tlref.pri ");
1254         outval(sym->addr, TRUE);
1255         /* decrement */
1256         stgwrite("\tdec.pri\n");
1257         /* store dereferenced value */
1258         if (sym->vclass == sLOCAL)
1259            stgwrite("\tsref.s.pri ");
1260         else
1261            stgwrite("\tsref.pri ");
1262         outval(sym->addr, TRUE);
1263         stgwrite("\tpop.pri\n");
1264         code_idx += opcodes(5) + opargs(2);
1265      }
1266    else
1267      {
1268         /* local or global variable */
1269         assert(sym != NULL);
1270         if (sym->vclass == sLOCAL)
1271            stgwrite("\tdec.s ");
1272         else
1273            stgwrite("\tdec ");
1274         outval(sym->addr, TRUE);
1275         code_idx += opcodes(1) + opargs(1);
1276      }                          /* if */
1277 }
1278
1279 /*
1280  *  Jumps to "label" if PRI != 0
1281  */
1282 void
1283 jmp_ne0(int number)
1284 {
1285    stgwrite("\tjnz ");
1286    outval(number, TRUE);
1287    code_idx += opcodes(1) + opargs(1);
1288 }
1289
1290 /*
1291  *  Jumps to "label" if PRI == 0
1292  */
1293 void
1294 jmp_eq0(int number)
1295 {
1296    stgwrite("\tjzer ");
1297    outval(number, TRUE);
1298    code_idx += opcodes(1) + opargs(1);
1299 }
1300
1301 /* write a value in hexadecimal; optionally adds a newline */
1302 void
1303 outval(cell val, int newline)
1304 {
1305    stgwrite(itoh(val));
1306    if (newline)
1307       stgwrite("\n");
1308 }