/* -------------------------------------------------------------------------- * Graph reduction engine, code generation and execution * * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU, * 1994-2003, All rights reserved.  It is distributed as free software under * the license in the file "License", which is included in the distribution. * * $RCSfile: machine.c,v $ * $Revision: 1.26 $ * $Date: 2006/02/14 16:12:19 $ * ------------------------------------------------------------------------*/ #include "prelude.h"#include "storage.h"#include "connect.h"#include "errors.h"#include "char.h"#include "opts.h"	/* needed for DEBUG_CODE */#include <setjmp.h> #if OBSERVATIONSBool   rootOpt       = TRUE;		/* TRUE => enable root optimisation*/#endif#if DEBUG_CODEBool   debugCode     = FALSE;		/* TRUE => print G-code to screen  */#endif#if DEBUG_SHOWSCBool   debugSC	     = FALSE;		/* TRUE => print SC-code to screen */#endif Int    evalDepth;			/* depth of nested eval()'s        */ /* -------------------------------------------------------------------------- * Data structures for machine memory (program storage): * ------------------------------------------------------------------------*/ /* This list defines the sequence of all instructions that can be used in * the abstract machine code for Hugs.  The Ins() macro is used to * ensure that the correct mapping of instructions to labels is used when * compiling the GCC_THREADED version. */ #define INSTRLIST       Ins(iLOAD),  Ins(iCELL),   Ins(iCHAR),    \			Ins(iINT),   Ins(iDOUBLE), Ins(iSTRING),  \			Ins(iMKAP),  Ins(iUPDATE), Ins(iUPDAP),   \			Ins(iEVAL),  Ins(iRETURN), Ins(iTEST),    \			Ins(iGOTO),  Ins(iSETSTK), Ins(iROOT),    \			Ins(iSLIDE), Ins(iSTAP),   Ins(iTABLE),   \			Ins(iLEVAL), Ins(iRUPDAP), Ins(iRUPDATE), \			Ins(iFAIL),  Ins(iALLOC)  #define Ins(x) xtypedef enum { INSTRLIST } Instr;#undef  Ins typedef Int Label; typedef union {    Int   mint;#if !BREAK_FLOATS    Float mfloat;#endif    Cell  cell;    Text  text;    Addr  addr;    Instr instr;    Label lab;} MemCell; typedef MemCell far *Memory;static  Memory      memory;#if !WANT_FIXED_SIZE_TABLES/* (Dynamically) growable memory. */DynTable* dynMemory = NULL;#endif #if !WANT_FIXED_SIZE_TABLESvoidgrowMemory(void){    growDynTable(dynMemory);    memory = (Memory)(dynMemory->data);    if (memory==0)	fatal("Cannot allocate program memory");}#endif #define intAt(m)    memory[m].mint#if !BREAK_FLOATS#define floatAt(m)  memory[m].mfloat#endif#define cellAt(m)   memory[m].cell#define textAt(m)   memory[m].text#define setAddrAt(m,a) memory[m].addr = ((a)-(m))#define addrAt(m)   (memory[m].addr+(m))#define instrAt(m)  memory[m].instr#define labAt(m)    memory[m].lab #if BYTECODE_PRIMS Int IntAt(m)Addr m; {    return intAt(m);} Float FloatAt(m)Addr m; {#if BREAK_FLOATS    return floatFromParts(cellAt(m),cellAt(m+1));#else    return floatAt(m);#endif} Double DoubleAt(m)Addr m; {    return doubleFromParts(cellAt(m),cellAt(m+1));} Cell CellAt(m)Addr m; {    return cellAt(m);} Text TextAt(m)Addr m; {    return textAt(m);} Addr AddrAt(m)Addr m; {    return addrAt(m);} Int InstrAt(m)Addr m; {    return instrAt(m);} #endif /* BYTECODE_PRIMS */ /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ static Void  local instrNone    Args((Instr));static Void  local instrInt     Args((Instr,Int));static Void  local instrDouble  Args((Instr,DoublePro));static Void  local instrCell    Args((Instr,Cell));static Void  local instrText    Args((Instr,Text));static Void  local instrLab     Args((Instr,Label));static Void  local instrCellLab Args((Instr,Cell,Label)); static Void  local asSTART      Args((Void));static Label local newLabel     Args((Label));static Void  local asEND        Args((Void));static Void  local asEVAL       Args((Void));static Void  local asTEST       Args((Cell,Label));static Void  local asSLIDE      Args((Int));static Void  local asMKAP       Args((Int));static Void  local asUPDATE     Args((Int));static Void  local asRUPDATE    Args((Void));static Void  local asGOTO       Args((Label)); #if DEBUG_CODEstatic Void  local dissassemble Args((Addr,Addr));static Addr  local dissInstr    Args((Addr));static Void  local printCell    Args((Cell));static Addr  local dissNone     Args((Addr,String));static Addr  local dissInt      Args((Addr,String));static Addr  local dissDouble   Args((Addr,String));static Addr  local dissCell     Args((Addr,String));static Addr  local dissText     Args((Addr,String));static Addr  local dissAddr     Args((Addr,String));static Addr  local dissCellAddr Args((Addr,String));#endif static Void  local build        Args((Cell,Int));static Void  local buildGuards  Args((List,Int));static Int   local buildLoc     Args((List,Int));#if BIGNUMSstatic Void  local buildBignum  Args((Bignum));#endif#if TREXstatic Void  local buildName	Args((Cell));#endif static Void  local make         Args((Cell,Int,Label,Label));static Void  local makeCond     Args((Cell,Cell,Cell,Int,Label,Label));static Void  local makeNumcase  Args((Triple,Int,Label,Label));#if TREXstatic Void  local makeExtcase  Args((Triple,Int,Label,Label));#endifstatic Void  local testGuard    Args((Pair,Int,Label,Label,Label));static Void  local testCase     Args((Pair,Int,Label,Label,Label)); static Void  local analyseAp    Args((Cell));#if TREXstatic Int   local fastBuildRec	Args((Cell,Int));#endifstatic Void  local buildAp      Args((Cell,Int,Label,Bool)); static Void  local evalString   Args((Cell)); /* -------------------------------------------------------------------------- * Assembler: (Low level, instruction code storage) * ------------------------------------------------------------------------*/ static Addr  startInstr;                /* first instruction after START   */static Addr  lastInstr;                 /* last instr written (for peephole*/					/* optimisations etc.)             */static Bool  newBasicBlock;		/* lastInstr ends a basic block    */					/* (so no peeping at lastInstr)    */static Addr  noMatch;                   /* address of a single FAIL instr  */static Int   srsp;                      /* simulated runtime stack pointer */static Int   offsPosn[NUM_OFFSETS];     /* mapping from logical to physical*/					/* offset positions                */ static Void local instrNone(opc)        /* Opcode with no operands         */Instr opc; {    lastInstr          = getMem(1);    instrAt(lastInstr) = opc;    newBasicBlock      = FALSE;} static Void local instrInt(opc,n)       /* Opcode with integer operand     */Instr opc;Int   n; {    lastInstr          = getMem(2);    instrAt(lastInstr) = opc;    intAt(lastInstr+1) = n;    newBasicBlock      = FALSE;} static Void local instrDouble(opc,fl)    /* Opcode with Double operand     */Instr    opc;DoublePro fl; {    lastInstr            = getMem(3);    instrAt(lastInstr)   = opc;    cellAt(lastInstr+1)  = part1Double(fl);    cellAt(lastInstr+2)  = part2Double(fl);    newBasicBlock        = FALSE;} static Void local instrCell(opc,c)      /* Opcode with Cell operand        */Instr opc;Cell  c; {    lastInstr           = getMem(2);    instrAt(lastInstr)  = opc;    cellAt(lastInstr+1) = c;    newBasicBlock       = FALSE;} static Void local instrText(opc,t)      /* Opcode with Text operand        */Instr opc;Text  t; {    lastInstr           = getMem(2);    instrAt(lastInstr)  = opc;    textAt(lastInstr+1) = t;    newBasicBlock       = FALSE;} static Void local instrLab(opc,l)       /* Opcode with label operand       */Instr opc;Label l; {    lastInstr          = getMem(2);    instrAt(lastInstr) = opc;    labAt(lastInstr+1) = l;    if (l<0)	internal("bad Label");    newBasicBlock      = FALSE;} static Void local instrCellLab(opc,c,l) /* Opcode with cell, label operands*/Instr opc;Cell  c;Label l; {    lastInstr           = getMem(3);    instrAt(lastInstr)  = opc;    cellAt(lastInstr+1) = c;    labAt(lastInstr+2)  = l;    if (l<0)	internal("bad Label");    newBasicBlock       = FALSE;} /* -------------------------------------------------------------------------- * Main low level assembler control: (includes label assignment and fixup) * * Labels are used as a simple form of continuation during the code gen: *  RUNON    => produce code which does not make jump at end of construction *  UPDRET   => produce code which performs RUPDATE at end *  VALRET   => produce code which performs RETURN at end *  other(d) => produce code which branches to label d at end * ------------------------------------------------------------------------*/ static  Label         nextLab;         /* next label number to allocate    */#define SHOULDNTFAIL  (-1)#define RUNON         (-2)#define UPDRET        (-3)#define VALRET        (-4)static  Addr          fixups[NUM_FIXUPS]; /* fixup table maps Label -> Addr*/#define atLabel(n)    (newBasicBlock = TRUE, fixups[n] = getMem(0))#define endLabel(d,l) if (d==RUNON) atLabel(l)#define fix(a)        setAddrAt(a,fixups[labAt(a)]) static  Addr          lengthAddr; static Void local asSTART() {          /* initialise assembler             */    fixups[0]   = noMatch;    nextLab     = 1;    lengthAddr  = getMem(1);    startInstr  = getMem(0);    lastInstr   = startInstr-1;    newBasicBlock = TRUE;    srsp        = 0;    offsPosn[0] = 0;} static Label local newLabel(d)         /* allocate new label               */Label d; {    if (d==RUNON) {	if (nextLab>=NUM_FIXUPS) {	    ERRMSG(0) "Compiled code too complex"	    EEND;	}	return nextLab++;    }    return d;} static Void local asEND() {            /* Fix addresses in assembled code  */    Addr pc = startInstr;     intAt(lengthAddr) = lastInstr - startInstr + 1;    while (pc<=lastInstr)	switch (instrAt(pc)) {	    case iEVAL   :             /* opcodes taking no arguments      */	    case iFAIL   :	    case iSTAP   :	    case iRUPDATE:	    case iRUPDAP :	    case iRETURN : pc++;			   break; 	    case iGOTO   : fix(pc+1);  /* opcodes taking one argument      */	    case iSETSTK :	    case iALLOC  :	    case iSLIDE  :	    case iROOT   :	    case iLOAD   :	    case iLEVAL  :	    case iCELL   : 	    case iCHAR   :	    case iINT    :	    case iSTRING :	    case iMKAP   :	    case iUPDATE :	    case iUPDAP  : pc+=2;			   break; 	    case iDOUBLE : pc+=3;			   break; 	    case iTEST   : fix(pc+2);			   pc+=3;			   break; 	    default      : internal("fixAddrs");	}} /* -------------------------------------------------------------------------- * Assembler Opcodes: (includes simple peephole optimisations) * ------------------------------------------------------------------------*/ #define asINTEGER(n) instrInt(iINT,n);          srsp++#define asDOUBLE(fl) instrDouble(iDOUBLE,fl);   srsp++#define asSTRING(t)  instrText(iSTRING,t);      srsp++#define asCHAR(n)    instrInt(iCHAR,n);         srsp++#define asLOAD(n)    instrInt(iLOAD,n);         srsp++#define asALLOC(n)   instrInt(iALLOC,n);        srsp+=n#define asROOT(n)    instrInt(iROOT,n);         srsp++#define asSETSTK(n)  instrInt(iSETSTK,n);       srsp=n#define asSTAP()     instrNone(iSTAP);          srsp--#define asRETURN()   instrNone(iRETURN)#define asCELL(c)    instrCell(iCELL,c);        srsp++#define asFAIL()     instrNone(iFAIL) /* Peephole optimisations are unsafe if we're at the start of a new   'basic block' (newBasicBlock is TRUE) -- e.g., 	f a b = if (if a then True else b) then foo else bar    After having emitted the code for the conditional, we want to evaluate   it, BUT we better _not_ look at the last instruction of the code   comprising the conditional expression and decide whether or not to   peephole the EVAL into an LEVAL.*/ static Void local asEVAL() {            /* load and eval stack element     */    if (!newBasicBlock && instrAt(lastInstr)==iLOAD)					/* Peephole optimisation:          */	instrAt(lastInstr) = iLEVAL;	/* LOAD n; EVAL ===> LEVAL n       */    else	instrNone(iEVAL);    srsp--;} static Void local asTEST(c,l)           /* test whnf and branch on mismatch*/Cell  c;Label l; {    switch (whatIs(c)) {	case TUPLE   : return;          /* typing guarantees that tags will*/					/* match without further tests     */	case NAME    : if (isCfun(c) && cfunOf(c)==0)			   return;    }    instrCellLab(iTEST,c,l);} static Void local asSLIDE(n)            /* Slide results down stack        */Int n; {    if (!newBasicBlock && instrAt(lastInstr)==iSLIDE)					/* Peephole optimisation:          */	intAt(lastInstr+1)+=n;          /* SLIDE n;SLIDE m ===> SLIDE (n+m)*/    else	instrInt(iSLIDE,n);    srsp -= n;} static Void local asMKAP(n)             /* Make application nodes ...      */Int n; {    if (!newBasicBlock && instrAt(lastInstr)==iMKAP)					/* Peephole optimisation:          */	intAt(lastInstr+1)+=n;          /* MKAP n; MKAP m  ===> MKAP (n+m) */    else	instrInt(iMKAP,n);    srsp -= n;} static Void local asUPDATE(n)           /* Update node ...                 */Int n; {    if (!newBasicBlock && instrAt(lastInstr)==iMKAP) {	Int m = intAt(lastInstr+1);	/* Peephole optimisations:         */	nextInstr(lastInstr);	if (m==1)                       /* MKAP 1; UPDATE p ===> UPDAP p   */	    instrInt(iUPDAP,n);	else {                          /* MKAP m; UPDATE p                */	    instrInt(iMKAP,m-1);        /*       ===> MKAP (m-1); UPDAP p  */	    instrInt(iUPDAP,n);	}    }    else	instrInt(iUPDATE,n);    srsp--;} static Void local asRUPDATE() {         /* Update node and return ...      */    if (!newBasicBlock && instrAt(lastInstr)==iMKAP) {	Int m = intAt(lastInstr+1);	/* Peephole optimisations:         */	nextInstr(lastInstr);	if (m==1)                       /* MKAP 1; RUPDATE ===> RUPDAP     */	    instrNone(iRUPDAP);	else {                          /* MKAP m; RUPDATE                 */	    instrInt(iMKAP,m-1);        /*       ===> MKAP (m-1); RUPDAP   */	    instrNone(iRUPDAP);	}    }    else	instrNone(iRUPDATE);} static Void local asGOTO(l)             /* End evaluation of expr in manner*/Label l; {                              /* indicated by label l            */    switch (l) {                                        /* inaccurate srsp */	case UPDRET : asRUPDATE();		      break;	case VALRET : asRETURN();	case RUNON  : break;	default     : instrLab(iGOTO,l);		      break;    }} /* -------------------------------------------------------------------------- * Constructor function tables: * * Tables of constructor functions for enumerated types are needed to * produce derived instances. * ------------------------------------------------------------------------*/ Void addCfunTable(tc)                   /* Add a constructor fun table to  */Tycon tc; {                             /* constructors for tycon tc       */    if (isTycon(tc) && tycon(tc).what==DATATYPE) {	List cs = tycon(tc).defn;	if (hasCfun(cs) && hasCfun(tl(cs)) && name(hd(cs)).code<=0) {	    Int  l     = length(cs);	    Addr a     = getMem(2+l);

Lines 1–500 of 1957. Load more