home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / gofer / Sources / c / machine < prev    next >
Encoding:
Text File  |  1993-02-12  |  32.9 KB  |  1,256 lines
  1. /* --------------------------------------------------------------------------
  2.  * machine.c:   Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  * Graph reduction engine, code generation and execution
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #include "prelude.h"
  10. #include "storage.h"
  11. #include "connect.h"
  12. #include "errors.h"
  13. #include <setjmp.h>
  14.  
  15. /*#define DEBUG_CODE*/
  16. Bool   andorOptimise = TRUE;        /* TRUE => optimise uses of &&, || */
  17. Bool   failOnError   = TRUE;        /* TRUE => abort as soon as error  */
  18.                     /*       occurs           */
  19.  
  20. /* --------------------------------------------------------------------------
  21.  * Data structures for machine memory (program storage):
  22.  * ------------------------------------------------------------------------*/
  23.  
  24. /* This list defines the sequence of all instructions that can be used in
  25.  * the abstract machine code for Gofer.  The Ins() macro is used to
  26.  * ensure that the correct mapping of instructions to labels is used when
  27.  * compiling the GCC_THREADED version.
  28.  */
  29. #define INSTRLIST    Ins(iLOAD),  Ins(iCELL),   Ins(iCHAR),      \
  30.             Ins(iINT),   Ins(iFLOAT),  Ins(iSTRING),  \
  31.             Ins(iMKAP),  Ins(iUPDATE), Ins(iUPDAP),      \
  32.             Ins(iEVAL),  Ins(iRETURN), Ins(iINTGE),   \
  33.             Ins(iINTEQ), Ins(iINTDV),  Ins(iTEST),      \
  34.             Ins(iGOTO),  Ins(iSETSTK), Ins(iALLOC),      \
  35.             Ins(iSLIDE), Ins(iROOT),   Ins(iDICT),      \
  36.             Ins(iFAIL)
  37.   
  38. #define Ins(x) x
  39. typedef enum { INSTRLIST } Instr;
  40. #undef  Ins
  41.  
  42. typedef Int Label;
  43.  
  44. typedef union {
  45.     Int   mint;
  46. #if !BREAK_FLOATS
  47.     Float mfloat;
  48. #endif
  49.     Cell  cell;
  50.     Text  text;
  51.     Addr  addr;
  52.     Instr instr;
  53.     Label lab;
  54. } MemCell;
  55.  
  56. typedef MemCell far *Memory;
  57. static    Memory        memory;
  58. #define intAt(m)    memory[m].mint
  59. #if !BREAK_FLOATS
  60. #define floatAt(m)  memory[m].mfloat
  61. #endif
  62. #define cellAt(m)   memory[m].cell
  63. #define textAt(m)   memory[m].text
  64. #define addrAt(m)   memory[m].addr
  65. #define instrAt(m)  memory[m].instr
  66. #define labAt(m)    memory[m].lab
  67.  
  68. /* --------------------------------------------------------------------------
  69.  * Local function prototypes:
  70.  * ------------------------------------------------------------------------*/
  71.  
  72. static Void  local instrNone    Args((Instr));
  73. static Void  local instrInt    Args((Instr,Int));
  74. static Void  local instrFloat   Args((Instr,FloatPro));
  75. static Void  local instrCell    Args((Instr,Cell));
  76. static Void  local instrText    Args((Instr,Text));
  77. static Void  local instrLab    Args((Instr,Label));
  78. static Void  local instrIntLab    Args((Instr,Int,Label));
  79. static Void  local instrCellLab Args((Instr,Cell,Label));
  80.  
  81. static Void  local asSTART    Args((Void));
  82. static Label local newLabel    Args((Label));
  83. static Void  local asEND    Args((Void));
  84. static Void  local asDICT    Args((Int));
  85. static Void  local asSLIDE    Args((Int));
  86. static Void  local asMKAP    Args((Int));
  87. static Void  local asUPDATE    Args((Int));
  88. static Void  local asGOTO    Args((Label));
  89.  
  90. #ifdef DEBUG_CODE
  91. static Void  local dissassemble Args((Addr,Addr));
  92. static Void  local printCell    Args((Cell));
  93. static Addr  local dissNone    Args((Addr,String));
  94. static Addr  local dissInt    Args((Addr,String));
  95. static Addr  local dissFloat    Args((Addr,String));
  96. static Addr  local dissCell    Args((Addr,String));
  97. static Addr  local dissText    Args((Addr,String));
  98. static Addr  local dissAddr    Args((Addr,String));
  99. static Addr  local dissIntAddr    Args((Addr,String));
  100. static Addr  local dissCellAddr Args((Addr,String));
  101. #endif
  102.  
  103. static Void  local build    Args((Cell,Int));
  104. static Void  local buildGuards    Args((List,Int));
  105. static Int   local buildLoc    Args((List,Int));
  106.  
  107. static Void  local make     Args((Cell,Int,Label,Label));
  108. static Void  local makeCond    Args((Cell,Cell,Cell,Int,Label,Label));
  109. static Void  local testGuard    Args((Pair,Int,Label,Label,Label));
  110. static Void  local testCase    Args((Pair,Int,Label,Label,Label));
  111.  
  112. static Void  local analyseAp    Args((Cell));
  113. static Void  local buildAp    Args((Cell,Int,Label,Bool));
  114.  
  115. static Void  local evalString   Args((Cell));
  116. static Void  local run        Args((Addr,StackPtr));
  117.  
  118. /* --------------------------------------------------------------------------
  119.  * Assembler: (Low level, instruction code storage)
  120.  * ------------------------------------------------------------------------*/
  121.  
  122. static Addr  startInstr;        /* first instruction after START   */
  123. static Addr  lastInstr;            /* last instr written (for peephole*/
  124.                     /* optimisations etc.)           */
  125. static Addr  noMatch;            /* address of a single FAIL instr  */
  126. static Int   srsp;            /* simulated runtime stack pointer */
  127. static Int   offsPosn[NUM_OFFSETS];    /* mapping from logical to physical*/
  128.                     /* offset positions           */
  129.  
  130. static Void local instrNone(opc)    /* Opcode with no operands       */
  131. Instr opc; {
  132.     lastInstr           = getMem(1);
  133.     instrAt(lastInstr) = opc;
  134. }
  135.  
  136. static Void local instrInt(opc,n)    /* Opcode with integer operand       */
  137. Instr opc;
  138. Int   n; {
  139.     lastInstr           = getMem(2);
  140.     instrAt(lastInstr) = opc;
  141.     intAt(lastInstr+1) = n;
  142. }
  143.  
  144. static Void local instrFloat(opc,fl)    /* Opcode with Float operand       */
  145. Instr    opc;
  146. FloatPro fl; {
  147. #if BREAK_FLOATS
  148.     lastInstr         = getMem(3);
  149.     instrAt(lastInstr)     = opc;
  150.     cellAt(lastInstr+1)     = part1Float(fl);
  151.     cellAt(lastInstr+2)  = part2Float(fl);
  152. #else
  153.     lastInstr            = getMem(2);
  154.     instrAt(lastInstr)   = opc;
  155.     floatAt(lastInstr+1) = fl;
  156. #endif
  157. }
  158.  
  159. static Void local instrCell(opc,c)    /* Opcode with Cell operand       */
  160. Instr opc;
  161. Cell  c; {
  162.     lastInstr        = getMem(2);
  163.     instrAt(lastInstr)    = opc;
  164.     cellAt(lastInstr+1) = c;
  165. }
  166.  
  167. static Void local instrText(opc,t)    /* Opcode with Text operand       */
  168. Instr opc;
  169. Text  t; {
  170.     lastInstr        = getMem(2);
  171.     instrAt(lastInstr)    = opc;
  172.     textAt(lastInstr+1) = t;
  173. }
  174.  
  175. static Void local instrLab(opc,l)    /* Opcode with label operand       */
  176. Instr opc;
  177. Label l; {
  178.     lastInstr           = getMem(2);
  179.     instrAt(lastInstr) = opc;
  180.     labAt(lastInstr+1) = l;
  181.     if (l<0)
  182.     internal("bad Label");
  183. }
  184.  
  185. static Void local instrIntLab(opc,n,l)    /* Opcode with int, label operands */
  186. Instr opc;
  187. Int   n;
  188. Label l; {
  189.     lastInstr           = getMem(3);
  190.     instrAt(lastInstr) = opc;
  191.     intAt(lastInstr+1) = n;
  192.     labAt(lastInstr+2) = l;
  193.     if (l<0)
  194.     internal("bad Label");
  195. }
  196.  
  197. static Void local instrCellLab(opc,c,l)    /* Opcode with cell, label operands*/
  198. Instr opc;
  199. Cell  c;
  200. Label l; {
  201.     lastInstr        = getMem(3);
  202.     instrAt(lastInstr)    = opc;
  203.     cellAt(lastInstr+1) = c;
  204.     labAt(lastInstr+2)    = l;
  205.     if (l<0)
  206.     internal("bad Label");
  207. }
  208.  
  209. /* --------------------------------------------------------------------------
  210.  * Main low level assembler control: (includes label assignment and fixup)
  211.  *
  212.  * Labels are used as a simple form of continuation during the code gen:
  213.  *  RUNON    => produce code which does not make jump at end of construction
  214.  *  UPDRET   => produce code which performs UPDATE 0, RETURN at end
  215.  *  VALRET   => produce code which performs RETURN at end
  216.  *  other(d) => produce code which branches to label d at end
  217.  * ------------------------------------------------------------------------*/
  218.  
  219. static    Label          nextLab;           /* next label number to allocate    */
  220. #define SHOULDNTFAIL  (-1)
  221. #define RUNON          (-2)
  222. #define UPDRET          (-3)
  223. #define VALRET          (-4)
  224. static    Addr          fixups[NUM_FIXUPS]; /* fixup table maps Label -> Addr*/
  225. #define atLabel(n)    fixups[n] = getMem(0)
  226. #define endLabel(d,l) if (d==RUNON) atLabel(l)
  227. #define fix(a)          addrAt(a) = fixups[labAt(a)]
  228.  
  229. static Void local asSTART() {           /* initialise assembler           */
  230.     fixups[0]    = noMatch;
  231.     nextLab    = 1;
  232.     startInstr    = getMem(0);
  233.     lastInstr    = startInstr-1;
  234.     srsp    = 0;
  235.     offsPosn[0] = 0;
  236. }
  237.  
  238. static Label local newLabel(d)           /* allocate new label           */
  239. Label d; {
  240.     if (d==RUNON) {
  241.     if (nextLab>=NUM_FIXUPS) {
  242.         ERROR(0) "Compiled code too complex"
  243.         EEND;
  244.     }
  245.     return nextLab++;
  246.     }
  247.     return d;
  248. }
  249.  
  250. static Void local asEND() {           /* Fix addresses in assembled code  */
  251.     Addr pc = startInstr;
  252.  
  253.     while (pc<=lastInstr)
  254.     switch (instrAt(pc)) {
  255.         case iEVAL     :           /* opcodes taking no arguments       */
  256.         case iFAIL     :
  257.         case iRETURN : pc++;
  258.                break;
  259.  
  260.         case iGOTO     : fix(pc+1);  /* opcodes taking one argument       */
  261.         case iSETSTK :
  262.         case iALLOC  :
  263.         case iSLIDE  :
  264.         case iROOT     :
  265.             case iDICT   :
  266.         case iLOAD     :
  267.         case iCELL     :
  268.         case iCHAR     :
  269.         case iINT     :
  270. #if !BREAK_FLOATS
  271.         case iFLOAT  :
  272. #endif
  273.         case iSTRING :
  274.         case iMKAP     :
  275.         case iUPDATE :
  276.         case iUPDAP  : pc+=2;
  277.                break;
  278. #if BREAK_FLOATS
  279.         case iFLOAT  : pc+=3;
  280.                break;
  281. #endif
  282.  
  283.         case iINTGE  :           /* opcodes taking two arguments       */
  284.         case iINTEQ  :
  285.         case iINTDV     :
  286.         case iTEST     : fix(pc+2);
  287.                pc+=3;
  288.                break;
  289.  
  290.         default     : internal("fixAddrs");
  291.     }
  292. }
  293.  
  294. /* --------------------------------------------------------------------------
  295.  * Assembler Opcodes: (includes simple peephole optimisations)
  296.  * ------------------------------------------------------------------------*/
  297.  
  298. #define asINTEGER(n) instrInt(iINT,n);        srsp++
  299. #define asFLOAT(fl)  instrFloat(iFLOAT,fl);    srsp++
  300. #define asSTRING(t)  instrText(iSTRING,t);    srsp++
  301. #define asCHAR(n)    instrInt(iCHAR,n);        srsp++
  302. #define asLOAD(n)    instrInt(iLOAD,n);        srsp++
  303. #define asALLOC(n)   instrInt(iALLOC,n);    srsp+=n
  304. #define asROOT(n)    instrInt(iROOT,n);        srsp++
  305. #define asSETSTK(n)  instrInt(iSETSTK,n);    srsp=n
  306. #define asEVAL()     instrNone(iEVAL);        srsp--    /* inaccurate srsp */
  307. #define asRETURN()   instrNone(iRETURN)
  308. #define asCELL(c)    instrCell(iCELL,c);    srsp++
  309. #define asTEST(c,l)  instrCellLab(iTEST,c,l)        /* inaccurate srsp */
  310. #define asINTGE(n,l) instrIntLab(iINTGE,n,l)        /* inaccurate srsp */
  311. #define asINTEQ(n,l) instrIntLab(iINTEQ,n,l)
  312. #define asINTDV(n,l) instrIntLab(iINTDV,n,l)        /* inaccurate srsp */
  313. #define asFAIL()     instrNone(iFAIL)
  314.  
  315. static Void local asDICT(n)        /* pick element of dictionary       */
  316. Int n; {
  317. /* Sadly, the following optimisation cannot be used unless CELL references
  318.  * in compiled code are garbage collected (and possibly modified when cell  
  319.  * indirections are found).
  320.  *
  321.  *    if (instrAt(lastInstr)==iCELL)
  322.  *    -- Peephole optimisation: CELL {dict m};DICT n ==> CELL dict(m+n)
  323.  *    if (whatIs(cellAt(lastInstr+1))==DICTCELL)
  324.  *        cellAt(lastInstr+1) = dict(dictOf(cellAt(lastInstr+1))+n);
  325.  *    else
  326.  *        internal("asDICT");
  327.  *    else  ...
  328.  */
  329.     if (n!=0)                /* optimisation:DICT 0 has no use  */
  330.     instrInt(iDICT,n);        /* for std dictionary construction */
  331. }
  332.  
  333. static Void local asSLIDE(n)        /* Slide results down stack       */
  334. Int n; {
  335.     if (instrAt(lastInstr)==iSLIDE)    /* Peephole optimisation:       */
  336.     intAt(lastInstr+1)+=n;        /* SLIDE n;SLIDE m ===> SLIDE (n+m)*/
  337.     else
  338.     instrInt(iSLIDE,n);
  339.     srsp -= n;
  340. }
  341.  
  342. static Void local asMKAP(n)        /* Make application nodes ...       */
  343. Int n; {
  344.     if (instrAt(lastInstr)==iMKAP)    /* Peephole optimisation:       */
  345.     intAt(lastInstr+1)+=n;        /* MKAP n; MKAP m  ===> MKAP (n+m) */
  346.     else
  347.     instrInt(iMKAP,n);
  348.     srsp -= n;
  349. }
  350.  
  351. static Void local asUPDATE(n)        /* Update node ...           */
  352. Int n; {
  353.     if (instrAt(lastInstr)==iMKAP) {    /* Peephole optimisations:       */
  354.     if (intAt(lastInstr+1)>1) {    /* MKAP (n+1); UPDATE p           */
  355.         intAt(lastInstr+1)--;    /*          ===> MKAP n; UPDAP p */
  356.         instrInt(iUPDAP,n);
  357.     }
  358.     else {
  359.         instrAt(lastInstr) = iUPDAP;
  360.         intAt(lastInstr+1) = n;    /* MKAP 1; UPDATE p ===> UPDAP p   */
  361.     }
  362.     }
  363.     else
  364.     instrInt(iUPDATE,n);
  365.     srsp--;
  366. }
  367.  
  368. static Void local asGOTO(l)        /* End evaluation of expr in manner*/
  369. Label l; {                /* indicated by label l           */
  370.     switch (l) {                    /* inaccurate srsp */
  371.     case UPDRET : asUPDATE(0);
  372.     case VALRET : asRETURN();
  373.     case RUNON  : break;
  374.     default     : instrLab(iGOTO,l);
  375.               break;
  376.     }
  377. }
  378.  
  379. /* --------------------------------------------------------------------------
  380.  * Dissassembler:
  381.  * ------------------------------------------------------------------------*/
  382.  
  383. #ifdef DEBUG_CODE
  384. #define printAddr(a) printf("0x%04X",a)/* printable representation of Addr */
  385.  
  386. static Void local dissassemble(pc,end) /* print dissassembly of code       */
  387. Addr pc;
  388. Addr end; {
  389.     while (pc<=end) {
  390.     printAddr(pc);
  391.     printf("\t");
  392.     switch (instrAt(pc)) {
  393.         case iLOAD     : pc = dissInt(pc,"LOAD");     break;
  394.         case iCELL     : pc = dissCell(pc,"CELL");     break;
  395.         case iCHAR     : pc = dissInt(pc,"CHAR");     break;
  396.         case iINT     : pc = dissInt(pc,"INT");     break;
  397.         case iFLOAT  : pc = dissFloat(pc,"FLOAT");   break;
  398.         case iSTRING : pc = dissText(pc,"STRING");     break;
  399.         case iMKAP     : pc = dissInt(pc,"MKAP");     break;
  400.         case iUPDATE : pc = dissInt(pc,"UPDATE");     break;
  401.         case iUPDAP  : pc = dissInt(pc,"UPDAP");     break;
  402.         case iEVAL     : pc = dissNone(pc,"EVAL");     break;
  403.         case iRETURN : pc = dissNone(pc,"RETURN");     break;
  404.         case iINTGE  : pc = dissIntAddr(pc,"INTGE"); break;
  405.         case iINTEQ  : pc = dissIntAddr(pc,"INTEQ"); break;
  406.         case iINTDV  : pc = dissIntAddr(pc,"INTDV"); break;
  407.         case iTEST     : pc = dissCellAddr(pc,"TEST"); break;
  408.         case iGOTO     : pc = dissAddr(pc,"GOTO");     break;
  409.         case iSETSTK : pc = dissInt(pc,"SETSTK");     break;
  410.         case iALLOC  : pc = dissInt(pc,"ALLOC");     break;
  411.         case iSLIDE  : pc = dissInt(pc,"SLIDE");     break;
  412.         case iROOT     : pc = dissInt(pc,"ROOT");     break;
  413.             case iDICT   : pc = dissInt(pc,"DICT");      break;
  414.         case iFAIL     : pc = dissNone(pc,"FAIL");     break;
  415.         default     : internal("unknown instruction");
  416.     }
  417.     }
  418. }
  419.  
  420. static Void local printCell(c)           /* printable representation of Cell */
  421. Cell c; {
  422.     if (isName(c))
  423.     printf("%s",textToStr(name(c).text));
  424.     else
  425.     printf("$%d",c);
  426. }
  427.  
  428. static Addr local dissNone(pc,s)       /* dissassemble instr no args       */
  429. Addr   pc;
  430. String s; {
  431.     printf("%s\n",s);
  432.     return pc+1;
  433. }
  434.  
  435. static Addr local dissInt(pc,s)        /* dissassemble instr with Int arg  */
  436. Addr   pc;
  437. String s; {
  438.     printf("%s\t%d\n",s,intAt(pc+1));
  439.     return pc+2;
  440. }
  441.  
  442. static Addr local dissFloat(pc,s)      /* dissassemble instr with Float arg*/
  443. Addr   pc;
  444. String s; {
  445. #if BREAK_FLOATS
  446.     printf("%s\t%s\n",s,
  447.     floatToString(floatFromParts(cellAt(pc+1),cellAt(pc+2))));
  448.     return pc+3;
  449. #else
  450.     printf("%s\t%s\n",s,floatToString(floatAt(pc+1)));
  451.     return pc+2;
  452. #endif
  453. }
  454.  
  455. static Addr local dissCell(pc,s)       /* dissassemble instr with Cell arg */
  456. Addr   pc;
  457. String s; {
  458.     printf("%s\t",s);
  459.     printCell(cellAt(pc+1));
  460.     printf("\n");
  461.     return pc+2;
  462. }
  463.  
  464. static Addr local dissText(pc,s)       /* dissassemble instr with Text arg */
  465. Addr   pc;
  466. String s; {
  467.     printf("%s\t%s\n",s,textToStr(textAt(pc+1)));
  468.     return pc+2;
  469. }
  470.  
  471. static Addr local dissAddr(pc,s)       /* dissassemble instr with Addr arg */
  472. Addr   pc;
  473. String s; {
  474.     printf("%s\t",s);
  475.     printAddr(addrAt(pc+1));
  476.     printf("\n");
  477.     return pc+2;
  478. }
  479.  
  480. static Addr local dissIntAddr(pc,s)    /* dissassemble instr with Int/Addr */
  481. Addr   pc;
  482. String s; {
  483.     printf("%s\t%d\t",s,intAt(pc+1));
  484.     printAddr(addrAt(pc+2));
  485.     printf("\n");
  486.     return pc+3;
  487. }
  488.  
  489. static Addr local dissCellAddr(pc,s)   /* dissassemble instr with Cell/Addr*/
  490. Addr   pc;
  491. String s; {
  492.     printf("%s\t",s);
  493.     printCell(cellAt(pc+1));
  494.     printf("\t");
  495.     printAddr(addrAt(pc+2));
  496.     printf("\n");
  497.     return pc+3;
  498. }
  499. #endif
  500.  
  501. /* --------------------------------------------------------------------------
  502.  * Compile expression to code which will build expression without any
  503.  * evaluation.
  504.  * ------------------------------------------------------------------------*/
  505.  
  506. static Void local build(e,co)        /* Generate code which will build  */
  507. Cell e;                    /* instance of given expression but*/
  508. Int  co; {                /* perform no evaluation        */
  509.     Int n;
  510.  
  511.     switch (whatIs(e)) {
  512.  
  513.     case LETREC    : n = buildLoc(fst(snd(e)),co);
  514.                  build(snd(snd(e)),co+n);
  515.                  asSLIDE(n);
  516.                  break;
  517.  
  518.     case FATBAR    : build(snd(snd(e)),co);
  519.                  build(fst(snd(e)),co);
  520.                  asCELL(nameFatbar);
  521.                  asMKAP(2);
  522.                  break;
  523.  
  524.     case COND      : build(thd3(snd(e)),co);
  525.                  build(snd3(snd(e)),co);
  526.                  build(fst3(snd(e)),co);
  527.                  asCELL(nameIf);
  528.                    asMKAP(3);
  529.                    break;
  530.  
  531.     case GUARDED   : buildGuards(snd(e),co);
  532.                  break;
  533.  
  534.     case AP        : buildAp(e,co,SHOULDNTFAIL,FALSE);
  535.                  break;
  536.  
  537.     case UNIT      :
  538.     case TUPLE     :
  539.     case NAME      : asCELL(e);
  540.              break;
  541.  
  542.     case DICTCELL  : asCELL(dict(dictOf(e)));    /* see comments for*/
  543.              break;                /* DICTCELL in make*/
  544.                             /* function below  */
  545.     case INTCELL   : asINTEGER(intOf(e));
  546.              break;
  547.  
  548.         case FLOATCELL : asFLOAT(floatOf(e));
  549.              break;
  550.  
  551.     case STRCELL   : asSTRING(textOf(e));
  552.              break;
  553.  
  554.     case CHARCELL  : asCHAR(charOf(e));
  555.              break;
  556.  
  557.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  558.                  break;
  559.  
  560.     default        : internal("build");
  561.     }
  562. }
  563.  
  564. static Void local buildGuards(gs,co)    /* Generate code to compile list   */
  565. List gs;                /* of guards to a conditional expr */
  566. Int  co; {                /* without evaluation           */
  567.     if (isNull(gs)) {
  568.     asCELL(nameFail);
  569.     }
  570.     else {
  571.     buildGuards(tl(gs),co);
  572.     build(snd(hd(gs)),co);
  573.     build(fst(hd(gs)),co);
  574.     asCELL(nameIf);
  575.     asMKAP(3);
  576.     }
  577. }
  578.  
  579. static Int local buildLoc(vs,co)    /* Generate code to build local var*/
  580. List vs;                /* bindings on stack,  with no eval*/
  581. Int  co; {
  582.     Int n = length(vs);
  583.     Int i;
  584.  
  585.     for (i=1; i<=n; i++)
  586.     offsPosn[co+i] = srsp+i;
  587.     asALLOC(n);
  588.     for (i=1; i<=n; i++) {
  589.     build(hd(vs),co+n);
  590.     asUPDATE(offsPosn[co+i]);
  591.     vs = tl(vs);
  592.     }
  593.     return n;
  594. }
  595.  
  596. /* --------------------------------------------------------------------------
  597.  * Compile expression to code which will build expression evaluating guards
  598.  * and testing cases to avoid building complete graph.
  599.  * ------------------------------------------------------------------------*/
  600.  
  601. #define makeTests(ct,tests,co,f,d)     {   Label l1 = newLabel(d);        \
  602.                        List  xs = tests;            \
  603.                        while (nonNull(tl(xs))) {        \
  604.                            Label l2   = newLabel(RUNON);\
  605.                            Int savesp = srsp;        \
  606.                            ct(hd(xs),co,f,l2,l1);        \
  607.                            atLabel(l2);            \
  608.                            srsp = savesp;            \
  609.                            xs   = tl(xs);            \
  610.                        }                    \
  611.                        ct(hd(xs),co,f,f,d);            \
  612.                        endLabel(d,l1);            \
  613.                        }
  614.  
  615. static Void local make(e,co,f,d)       /* Construct code to build e, given */
  616. Cell  e;                   /* current offset co, and branch       */
  617. Int   co;                   /* to f on failure, d on completion */
  618. Label f;
  619. Label d; {
  620.     switch (whatIs(e)) {
  621.  
  622.     case LETREC    : {   Int n = buildLoc(fst(snd(e)),co);
  623.                  make(snd(snd(e)),co+n,f,RUNON);
  624.                  asSLIDE(n);
  625.                  asGOTO(d);
  626.                  }
  627.                  break;
  628.  
  629.     case FATBAR    : {   Label l1     = newLabel(RUNON);
  630.                  Label l2     = newLabel(d);
  631.                  Int   savesp = srsp;
  632.  
  633.                  make(fst(snd(e)),co,l1,l2);
  634.  
  635.                  atLabel(l1);
  636.                  srsp = savesp;
  637.                  asSETSTK(srsp);
  638.                  make(snd(snd(e)),co,f,l2);
  639.  
  640.                  endLabel(d,l2);
  641.                  }
  642.                  break;
  643.  
  644.     case COND      : makeCond(fst3(snd(e)),
  645.                   snd3(snd(e)),
  646.                   thd3(snd(e)),co,f,d);
  647.                  break;
  648.  
  649.     case CASE      : make(fst(snd(e)),co,SHOULDNTFAIL,RUNON);
  650.                  asEVAL();
  651.                  makeTests(testCase,snd(snd(e)),co,f,d);
  652.                  break;
  653.  
  654.     case GUARDED   : makeTests(testGuard,snd(e),co,f,d);
  655.                  break;
  656.  
  657.     case AP        : if (andorOptimise) {
  658.                  Cell h = getHead(e);
  659.                  if (h==nameAnd && argCount==2) {
  660.                  /* x && y ==> if x then y else False       */
  661.                  makeCond(arg(fun(e)),arg(e),nameFalse,co,f,d);
  662.                  break;
  663.                  }
  664.                  else if (h==nameOr && argCount==2) {
  665.                  /* x || y ==> if x then True else y       */
  666.                  makeCond(arg(fun(e)),nameTrue,arg(e),co,f,d);
  667.                  break;
  668.                  }
  669.              }
  670.                          buildAp(e,co,f,TRUE);
  671.                          asGOTO(d);
  672.                          break;
  673.  
  674.     case UNIT      :
  675.     case TUPLE     :
  676.     case NAME      : asCELL(e);
  677.                  asGOTO(d);
  678.                  break;
  679.  
  680.     /* for dict cells, ensure that CELL referred to in the code is the */
  681.     /* dictionary cell at the head of the dictionary; not just a copy  */
  682.  
  683.     case DICTCELL  : asCELL(dict(dictOf(e)));
  684.                  asGOTO(d);
  685.                  break;
  686.  
  687.     case INTCELL   : asINTEGER(intOf(e));
  688.                  asGOTO(d);
  689.                  break;
  690.  
  691.         case FLOATCELL : asFLOAT(floatOf(e));
  692.                  asGOTO(d);
  693.              break;
  694.  
  695.     case STRCELL   : asSTRING(textOf(e));
  696.                  asGOTO(d);
  697.                  break;
  698.  
  699.     case CHARCELL  : asCHAR(charOf(e));
  700.                  asGOTO(d);
  701.                  break;
  702.  
  703.     case OFFSET    : asLOAD(offsPosn[offsetOf(e)]);
  704.                  asGOTO(d);
  705.                  break;
  706.  
  707.     default        : internal("make");
  708.     }
  709. }
  710.  
  711. static Void local makeCond(i,t,e,co,f,d)/* Build code for conditional       */
  712. Cell  i,t,e;
  713. Int   co;
  714. Label f;
  715. Label d; {
  716.     Label l1 = newLabel(RUNON);
  717.     Label l2 = newLabel(d);
  718.     Int   savesp;
  719.  
  720.     make(i,co,f,RUNON);
  721.     asEVAL();
  722.  
  723.     savesp = srsp;
  724.     asTEST(nameTrue,l1);
  725.     make(t,co,f,l2);
  726.  
  727.     srsp = savesp;
  728.     atLabel(l1);
  729.     make(e,co,f,l2);
  730.  
  731.     endLabel(d,l2);
  732. }
  733.  
  734. static Void local testGuard(g,co,f,cf,d)/* Produce code for guard       */
  735. Pair  g;
  736. Int   co;
  737. Label f;
  738. Label cf;
  739. Label d; {
  740.     make(fst(g),co,SHOULDNTFAIL,RUNON);
  741.     asEVAL();
  742.     asTEST(nameTrue,cf);
  743.     make(snd(g),co,f,d);
  744. }
  745.  
  746. static Void local testCase(c,co,f,cf,d) /* Produce code for guard       */
  747. Pair  c;
  748. Int   co;                /* labels determine where to go if:*/
  749. Label f;                /* match succeeds, but rest fails  */
  750. Label cf;                /* this match fails           */
  751. Label d; {
  752.     Int n = discrArity(fst(c));
  753.     Int i;
  754.     switch (whatIs(fst(c))) {
  755.     case INTCELL : asINTEQ(intOf(fst(c)),cf);
  756.                break;
  757.     case ADDPAT  : asINTGE(intValOf(fst(c)),cf);
  758.                break;
  759.     case MULPAT  : asINTDV(intValOf(fst(c)),cf);
  760.                break;
  761.     default      : asTEST(fst(c),cf);
  762.                break;
  763.     }
  764.     for (i=1; i<=n; i++)
  765.     offsPosn[co+i] = ++srsp;
  766.     make(snd(c),co+n,f,d);
  767. }
  768.  
  769. /* --------------------------------------------------------------------------
  770.  * We frequently encounter functions which call themselves recursively with
  771.  * a number of initial arguments preserved:
  772.  * e.g.  (map f) []    = []
  773.  *     (map f) (x:xs) = f x : (map f) xs
  774.  * Lambda lifting, in particular, is likely to introduce such functions.
  775.  * Rather than reconstructing a new instance of the recursive function and
  776.  * it's arguments, we can extract the relevant portion of the root of the
  777.  * current redex.
  778.  *
  779.  * The following functions implement this optimisation.
  780.  * ------------------------------------------------------------------------*/
  781.  
  782. static Int  nonRoots;               /* #args which can't get from root  */
  783. static Int  rootPortion;           /* portion of root used ...       */
  784. static Name definingName;           /* name of func being defined,if any*/
  785. static Int  definingArity;           /* arity of definingName        */
  786.  
  787. static Void local analyseAp(e)           /* Determine if any portion of an   */
  788. Cell e; {                   /* application can be built using a */
  789.     if (isAp(e)) {               /* portion of the root           */
  790.     analyseAp(fun(e));
  791.     if (nonRoots==0 && rootPortion>1
  792.             && isOffset(arg(e))
  793.             && offsetOf(arg(e))==rootPortion-1)
  794.         rootPortion--;
  795.     else
  796.         nonRoots++;
  797.     }
  798.     else if (e==definingName)
  799.     rootPortion = definingArity+1;
  800.     else
  801.     rootPortion = 0;
  802. }
  803.  
  804. static Void local buildAp(e,co,f,str)    /* Build application, making use of*/
  805. Cell  e;                /* root optimisation if poss.       */
  806. Int   co;
  807. Label f;
  808. Bool  str; {
  809.     Int nr, rp, i;
  810.  
  811.     nonRoots = 0;
  812.     analyseAp(e);
  813.     nr = nonRoots;
  814.     rp = rootPortion;
  815.  
  816.     for (i=0; i<nr; ++i) {
  817.     build(arg(e),co);
  818.     e = fun(e);
  819.     }
  820.  
  821.     if (isSelect(e)) {
  822.         if (selectOf(e)>0) {
  823.         asDICT(selectOf(e));
  824.     }
  825.     }
  826.     else {
  827.     if (isName(e) && name(e).defn==MFUN) {
  828.         asDICT(name(e).number);
  829.         nr--;    /* AP node for member function need never be built */
  830.     }
  831.     else {
  832.         if (0<rp && rp<=definingArity) {
  833.         asROOT(rp-1);
  834.             }
  835.         else
  836.         if (str)
  837.             make(e,co,f,RUNON);
  838.         else
  839.             build(e,co);
  840.     }
  841.  
  842.     if (nr>0) {
  843.         asMKAP(nr);
  844.         }
  845.     }
  846. }
  847.  
  848. /* --------------------------------------------------------------------------
  849.  * Code generator entry point:
  850.  * ------------------------------------------------------------------------*/
  851.  
  852. Addr codeGen(n,arity,e)            /* Generate code for expression e,  */
  853. Name n;                    /* treating return value of CAFs    */
  854. Int  arity;                   /* differently to functs with args  */
  855. Cell e; {
  856.     definingName  = n;
  857.     definingArity = arity;
  858.     asSTART();
  859.     if (nonNull(n)) {
  860.         Int i;
  861.         for (i=1; i<=arity; i++)
  862.         offsPosn[i] = ++srsp;
  863.         make(e,arity,noMatch,(arity>0 ? UPDRET : VALRET));
  864.     }
  865.     else {
  866.         build(e,0);
  867.         asRETURN();
  868.     }
  869.     asEND();
  870. #ifdef DEBUG_CODE
  871.     if (nonNull(n))
  872.     printf("name=%s\n",textToStr(name(n).text));
  873.     dissassemble(startInstr,lastInstr);
  874.     printf("------------------\n");
  875. #endif
  876.     if (nonNull(n))
  877.     name(n).defn  = NIL;
  878.     return startInstr;
  879. }
  880.  
  881. /* --------------------------------------------------------------------------
  882.  * Evaluator:
  883.  * ------------------------------------------------------------------------*/
  884.  
  885. Int   whnfArgs;                   /* number of arguments of whnf term */
  886. Cell  whnfHead;                   /* head cell of term in whnf       */
  887. Int   whnfInt;                   /* value of INTCELL (in whnf)       */
  888. Float whnfFloat;               /* value of FLOATCELL (in whnf)     */
  889. Long  numReductions;               /* number of reductions counted       */
  890.  
  891. static Cell    errorRedex;           /* irreducible error expression       */
  892. static jmp_buf *evalError = 0;           /* jump buffer for eval errors       */
  893.  
  894. Void eval(n)                   /* Graph reduction evaluator    */
  895. Cell n; {
  896.     StackPtr base = sp;
  897.     Int      ar;
  898.  
  899. unw:switch (whatIs(n)) {           /* unwind spine of application  */
  900.  
  901.     case AP        : push(n);
  902.              n = fun(n);
  903.              goto unw;
  904.  
  905.     case INDIRECT  : n = arg(n);
  906.              allowBreak();
  907.              goto unw;
  908.  
  909.     case NAME      : ar = name(n).arity;
  910.              if (name(n).defn!=CFUN && sp-base>=ar) {
  911.                  allowBreak();
  912.                  if (ar>0) {             /* fn with args*/
  913.                  StackPtr root;
  914.  
  915.                  push(NIL);            /* rearrange   */
  916.                  root = sp;
  917.                  do {
  918.                      stack(root) = arg(stack(root-1));
  919.                      --root;
  920.                  } while (--ar>0);
  921.  
  922.                  if (name(n).primDef)        /* reduce       */
  923.                      (*name(n).primDef)(root);
  924.                  else
  925.                      run(name(n).code,root);
  926.  
  927.                  numReductions++;
  928.  
  929.                  sp = root;            /* continue... */
  930.                  n  = pop();
  931.                  }
  932.                  else {                /* CAF       */
  933.                  if (isNull(name(n).defn)) {/* build CAF   */
  934.                      push(n);            /* save CAF    */
  935.  
  936.                      if (name(n).primDef)
  937.                      (*name(n).primDef)(sp);
  938.                      else
  939.                      run(name(n).code,sp);
  940.  
  941.                      numReductions++;
  942.  
  943.                      name(n).defn = pop();
  944.                      drop();            /* drop CAF    */
  945.                  }
  946.                  n = name(n).defn;        /*already built*/
  947.                  if (sp>base)
  948.                      fun(top()) = n;
  949.                  }
  950.                  goto unw;
  951.              }
  952.              break;
  953.  
  954.     case INTCELL   : whnfInt = intOf(n);
  955.              break;
  956.  
  957.         case FLOATCELL : whnfFloat = floatOf(n);
  958.              break;
  959.  
  960.     case STRCELL   : evalString(n);
  961.              goto unw;
  962.  
  963.     case FILECELL  : evalFile(n);
  964.              goto unw;
  965.     }
  966.  
  967.     whnfHead = n;               /* rearrange components of term on  */
  968.     whnfArgs = sp - base;           /* stack, now in whnf ...       */
  969.     for (ar=whnfArgs; ar>0; ar--) {
  970.     fun(stack(base+ar)) = n;
  971.     n            = stack(base+ar);
  972.     stack(base+ar)        = arg(n);
  973.     }
  974. }
  975.  
  976. Void unwind(n)                   /* unwind spine of application;       */
  977. Cell n; {                   /* like eval except that we always  */
  978.     whnfArgs = 0;               /* treat the expression n as if it  */
  979.                        /* were already in whnf.        */
  980. unw:switch (whatIs(n)) {
  981.     case AP        : push(arg(n));
  982.              whnfArgs++;
  983.              n = fun(n);
  984.              goto unw;
  985.  
  986.     case INDIRECT  : n = arg(n);
  987.              allowBreak();
  988.              goto unw;
  989.  
  990.     case INTCELL   : whnfInt = intOf(n);
  991.              break;
  992.  
  993.         case FLOATCELL : whnfFloat = floatOf(n);
  994.              break;
  995.  
  996.     case STRCELL   : evalString(n);
  997.              goto unw;
  998.     }
  999.     whnfHead = n;
  1000. }
  1001.  
  1002. static Void local evalString(n)        /* expand STRCELL at node n       */
  1003. Cell n; {
  1004.     Text t = textOf(n);
  1005.     Int  c = textToStr(t)[0];
  1006.     if (c==0) {
  1007.     fst(n) = INDIRECT;
  1008.     snd(n) = nameNil;
  1009.     return;
  1010.     }
  1011.     else if (c=='\\') {
  1012.     c = textToStr(++t)[0];
  1013.         if (c!='\\')
  1014.         c = 0;
  1015.     }
  1016.     fst(n) = consChar(c);
  1017.     snd(n) = mkStr(++t);
  1018. }
  1019.  
  1020. static Void local run(start,root)      /* execute code beginning at given  */
  1021. Addr     start;                   /* address with local stack starting*/
  1022. StackPtr root; {               /* at given root offset           */
  1023.     register Memory pc = memory+start;
  1024.  
  1025. #if     GCC_THREADED
  1026. #define Ins(x)        &&l##x
  1027. static  void *labs[] = { INSTRLIST };
  1028. #undef  Ins
  1029. #define Case(x)        l##x
  1030. #define    Continue    goto *labs[(pc++)->instr]
  1031. #define    Dispatch    Continue;
  1032. #define EndDispatch
  1033. #else
  1034. #define Dispatch    for (;;) switch((pc++)->instr) {
  1035. #define    Case(x)        case x
  1036. #define    Continue    continue
  1037. #define EndDispatch    default : internal("illegal instruction"); \
  1038.                   break;               \
  1039.             }
  1040. #endif
  1041.  
  1042.     Dispatch
  1043.  
  1044.     Case(iLOAD)   : push(stack(root+pc->mint));     /* load from stack*/
  1045.             pc++;
  1046.             Continue;
  1047.  
  1048.     Case(iCELL)   : push(pc->cell);             /* load const Cell*/
  1049.             pc++;
  1050.             Continue;
  1051.  
  1052.     Case(iCHAR)   : push(mkChar(pc->mint));         /* load char const*/
  1053.             pc++;
  1054.             Continue;
  1055.  
  1056.     Case(iINT)    : push(mkInt(pc->mint));         /* load int const */
  1057.             pc++;
  1058.             Continue;
  1059.  
  1060. #if BREAK_FLOATS
  1061.     Case(iFLOAT)  : push(mkFloat(floatFromParts     /* load dbl const */
  1062.                 (pc->cell,(pc+1)->cell)));
  1063.             pc+=2;
  1064.             Continue;
  1065. #else
  1066.     Case(iFLOAT)  : push(mkFloat(pc->mfloat));     /* load float cnst*/
  1067.             pc++;
  1068.             Continue;
  1069. #endif
  1070.  
  1071.     Case(iSTRING) : push(mkStr(pc->text));         /* load str const */
  1072.             pc++;
  1073.             Continue;
  1074.  
  1075.     Case(iMKAP)   : {   Cell t = pushed(0);         /* make AP nodes  */
  1076.                 Int  i = pc->text;
  1077.                 while (0<i--) {
  1078.                 drop();
  1079.                 t=ap(t,pushed(0));
  1080.                 }
  1081.                 pushed(0)=t;
  1082.             }
  1083.             pc++;
  1084.             Continue;
  1085.  
  1086.     Case(iUPDATE) : {   Cell t = stack(root        /* update cell ...*/
  1087.                          + pc->mint);
  1088.                 fst(t) = INDIRECT;
  1089.                 snd(t) = pop();
  1090.             }
  1091.             pc++;
  1092.             Continue;
  1093.  
  1094.     Case(iUPDAP)  : {   Cell t = stack(root         /* update AP node */
  1095.                          + pc->mint);
  1096.                 fst(t) = pop();
  1097.                 snd(t) = pop();
  1098.             }
  1099.             pc++;
  1100.             Continue;
  1101.  
  1102.     Case(iEVAL)   : eval(pop());             /* evaluate top() */
  1103.             Continue;
  1104.  
  1105.     Case(iRETURN) : return;                 /* terminate       */
  1106.  
  1107.     Case(iINTGE)  : if (whnfInt>=pc->mint) {     /* test integer >=*/
  1108.                 push(mkInt(whnfInt-pc->mint));
  1109.                 pc += 2;
  1110.             }
  1111.             else
  1112.                 pc = memory + (pc+1)->addr;
  1113.             Continue;
  1114.  
  1115.     Case(iINTEQ)  : if (whnfInt==pc->mint)         /* test integer ==*/
  1116.                 pc += 2;
  1117.             else
  1118.                 pc = memory + (pc+1)->addr;
  1119.             Continue;
  1120.  
  1121.     Case(iINTDV)  : if (whnfInt>=0 &&         /* test for mult  */
  1122.                 (whnfInt%(pc->mint)==0)) {
  1123.                 push(mkInt(whnfInt/(pc->mint)));
  1124.                 pc += 2;
  1125.             }
  1126.             else
  1127.                 pc = memory + (pc+1)->addr;
  1128.             Continue;
  1129.  
  1130.     Case(iTEST)   : if (whnfHead==pc->cell)         /* test for cell  */
  1131.                 pc += 2;
  1132.             else
  1133.                 pc = memory + (pc+1)->addr;
  1134.             Continue;
  1135.  
  1136.     Case(iGOTO)   : pc = memory + pc->addr;         /* goto label       */
  1137.             Continue;
  1138.  
  1139.     Case(iSETSTK) : sp=root + pc->mint;          /* set stack ptr  */
  1140.             pc++;
  1141.             Continue;
  1142.  
  1143.     Case(iALLOC)  : {   Int i = pc->mint;         /* alloc loc vars */
  1144.                 chkStack(i);
  1145.                 while (0<i--)
  1146.                 onto(ap(NIL,NIL));
  1147.             }
  1148.             pc++;
  1149.             Continue;
  1150.  
  1151.     Case(iDICT)   : top() = dict(dictOf(top()) + pc->mint);
  1152.             pc++;                 /* dict lookup    */
  1153.             Continue;
  1154.  
  1155.     Case(iROOT)   : {   Cell t = stack(root);     /* partial root   */
  1156.                 Int  i = pc->mint;
  1157.                 while (fst(t)==INDIRECT) {
  1158.                 allowBreak();
  1159.                 t = arg(t);
  1160.                 }
  1161.                 while (0<i--) {
  1162.                 t = fun(t);
  1163.                 while (fst(t)==INDIRECT) {
  1164.                     allowBreak();
  1165.                     t = arg(t);
  1166.                 }
  1167.                 }
  1168.                 push(t);
  1169.             }
  1170.             pc++;
  1171.             Continue;
  1172.  
  1173.     Case(iSLIDE)  : pushed(pc->mint) = top();     /* remove loc vars*/
  1174.             sp -= pc->mint;
  1175.             pc++;
  1176.             Continue;
  1177.  
  1178.     Case(iFAIL)   : evalFails(root);         /* cannot reduce  */
  1179.             return;/*NOT REACHED*/
  1180.  
  1181.     EndDispatch
  1182.  
  1183. #undef Dispatch
  1184. #undef Case
  1185. #undef Continue
  1186. #undef EndDispatch
  1187. }
  1188.  
  1189. Cell evalWithNoError(e)            /* Evaluate expression, returning   */
  1190. Cell e; {                   /* NIL if successful, irreducible   */
  1191.     Cell badRedex;               /* expression if not...           */
  1192.     jmp_buf *oldCatch = evalError;
  1193.  
  1194. #if JMPBUF_ARRAY
  1195.     jmp_buf catch[1];
  1196.     evalError = catch;
  1197.     if (setjmp(catch[0])==0) {
  1198.     eval(e);
  1199.     badRedex = NIL;
  1200.     }
  1201.     else
  1202.     badRedex = errorRedex;
  1203. #else
  1204.     jmp_buf catch;
  1205.     evalError = &catch;
  1206.     if (setjmp(catch)==0) {
  1207.         eval(e); 
  1208.     badRedex = NIL;
  1209.     }
  1210.     else
  1211.         badRedex = errorRedex;
  1212. #endif
  1213.  
  1214.     evalError = oldCatch;
  1215.     return badRedex;
  1216. }
  1217.  
  1218. Void evalFails(root)            /* Eval of current redex fails       */
  1219. StackPtr root; {
  1220.     errorRedex = stack(root);        /* get error & bypass indirections */
  1221.     while (isPair(errorRedex) && fst(errorRedex)==INDIRECT)
  1222.     errorRedex = snd(errorRedex);
  1223.  
  1224.     if (failOnError)
  1225.     abandon("Program",errorRedex);
  1226.     else if (evalError)
  1227.     longjmp(*evalError,1);
  1228.     else
  1229.     internal("uncaught eval error");
  1230. }
  1231.  
  1232. Cell graphForExp() {            /* Build graph for expression to be*/
  1233.     clearStack();            /* reduced...               */
  1234.     run(inputCode,sp);
  1235.     return pop();
  1236. }
  1237.  
  1238. /* --------------------------------------------------------------------------
  1239.  * Machine control:
  1240.  * ------------------------------------------------------------------------*/
  1241.  
  1242. Void machine(what)
  1243. Int what; {
  1244.     switch (what) {
  1245.     case INSTALL : machine(RESET);
  1246.                memory  = (Memory)farCalloc(NUM_ADDRS,sizeof(MemCell));
  1247.                if (memory==0)
  1248.                fatal("Cannot allocate program memory");
  1249.                instrNone(iFAIL);
  1250.                noMatch = lastInstr;
  1251.                break;
  1252.     }
  1253. }
  1254.  
  1255. /* ------------------------------------------------------------------------*/
  1256.