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