-/* -*- mode: hugs-c; -*- */
+
/* -----------------------------------------------------------------------------
- * $Id: Assembler.h,v 1.4 1999/02/05 16:02:18 simonm Exp $
+ * $Id: Assembler.h,v 1.5 1999/03/01 14:47:09 sewardj Exp $
*
* (c) The GHC Team 1994-1998.
*
* Allocating (top level) heap objects
* ------------------------------------------------------------------------*/
-extern AsmBCO asmBeginBCO ( void );
+extern AsmBCO asmBeginBCO ( int /*StgExpr*/ e );
extern void asmEndBCO ( AsmBCO bco );
-extern AsmBCO asmBeginContinuation ( AsmSp sp );
+extern AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts );
extern void asmEndContinuation ( AsmBCO bco );
extern AsmObject asmMkObject ( AsmClosure c );
extern AsmSp asmBeginCase ( AsmBCO bco );
extern void asmEndCase ( AsmBCO bco );
extern AsmSp asmContinuation ( AsmBCO bco, AsmBCO ret_addr );
-
+
extern AsmSp asmBeginAlt ( AsmBCO bco );
extern void asmEndAlt ( AsmBCO bco, AsmSp sp );
extern AsmPc asmTest ( AsmBCO bco, AsmWord tag );
extern AsmSp asmBeginPrim ( AsmBCO bco );
extern void asmEndPrim ( AsmBCO bco, const AsmPrim* prim, AsmSp base );
+extern AsmBCO asm_BCO_catch ( void );
+extern AsmBCO asm_BCO_raise ( void );
+extern AsmBCO asm_BCO_seq ( void );
+
+
/* --------------------------------------------------------------------------
* Heap manipulation
* ------------------------------------------------------------------------*/
* Hugs version 1.4, December 1997
*
* $RCSfile: options.h,v $
- * $Revision: 1.3 $
- * $Date: 1999/01/13 16:26:37 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:47:09 $
* ------------------------------------------------------------------------*/
#define LARGE_HUGS 1
#define NUM_SYNTAX 100
-#define NUM_TUPLES 100
+#define NUM_TUPLES /*100*/ 10
#define NUM_OFFSETS 1024
#define NUM_CHARS 256
#if TREX
#define MINIMUMHEAP Pick(7500, 19000, 19000)
#define MAXIMUMHEAP Pick(32765, 0, 0)
-#define DEFAULTHEAP Pick(28000, 50000, 300000)
+#define DEFAULTHEAP Pick(28000, 50000, 1500000 /*300000*/ )
#define NUM_SCRIPTS Pick(64, 100, 100)
#define NUM_MODULE NUM_SCRIPTS
*/
#define PROVIDE_INTEGER
-#define PROVIDE_INT64
-#define PROVIDE_WORD
+#undef PROVIDE_INT64
+#undef PROVIDE_WORD
#define PROVIDE_ADDR
-#define PROVIDE_STABLE
+#undef PROVIDE_STABLE
#define PROVIDE_FOREIGN
-#define PROVIDE_WEAK
+#undef PROVIDE_WEAK
#define PROVIDE_ARRAY
-#define PROVIDE_CONCURRENT
-#define PROVIDE_PTREQUALITY
-#define PROVIDE_COERCE
+#undef PROVIDE_CONCURRENT
+#undef PROVIDE_PTREQUALITY
+#undef PROVIDE_COERCE
/* The following aren't options at the moment - but could be
* #define PROVIDE_FLOAT
/* Should lambda lifter lift constant expressions out to top level?
* Experimental optimisation.
*/
-#define LIFT_CONSTANTS 1
+#define LIFT_CONSTANTS 0
/* Should we run optimizer on Hugs code?
* Experimental optimisation.
*/
-#define USE_HUGS_OPTIMIZER 1
+#define USE_HUGS_OPTIMIZER 0
/* Are things being used in an interactive setting or a batch setting?
* In an interactive setting, System.exitWith should not call _exit
/* Turn on debugging output and some sanity checks
*/
-/*#define DEBUG */
+#define DEBUG 1
/*#define NDEBUG */
/* Make stack tags more informative than just their size.
* Helps when printing the stack and when running sanity checks.
*/
-/*#define DEBUG_EXTRA */
+#define DEBUG_EXTRA 1
/* Turn lazy blackholing on/off.
* Warning: Lazy blackholing can't be disabled in GHC generated code.
* Hugs version 1.4, December 1997
*
* $RCSfile: backend.h,v $
- * $Revision: 1.1 $
- * $Date: 1999/02/03 17:05:14 $
+ * $Revision: 1.2 $
+ * $Date: 1999/03/01 14:46:42 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
*
* Expr -> LETREC ([Var],Expr) -- Vars contain their bound value
* | LAMBDA ([Var],Expr) -- all vars bound to NIL
- * | CASE (Expr,[Alt])
- * | PRIMCASE (Expr,[PrimAlt])
+ * | CASE (Expr,[Alt]) -- algebraic case
+ * | PRIMCASE (Expr,[PrimAlt]) -- primitive case
* | STGPRIM (Prim,[Atom])
* | STGAPP (Var, [Atom]) -- tail call
* | Var -- Abbreviation for STGAPP(Var,[])
* Hugs version 1.4, December 1997
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:25 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:42 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "Assembler.h"
#include "link.h"
+#include "Rts.h" /* IF_DEBUG */
+#include "RtsFlags.h"
/* --------------------------------------------------------------------------
* Local function prototypes:
static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
-static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
+//static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
static AsmBCO cgLambda ( StgExpr e );
static AsmBCO cgRhs ( StgRhs rhs );
static void beginTop ( StgVar v );
static Void pushVar( AsmBCO bco, StgVar v )
{
Cell info = stgVarInfo(v);
- assert(isStgVar(v));
+ // if (!isStgVar(v)) {
+ //printf("\n\nprefail\n");
+ //print(v,1000);
+ assert(isStgVar(v));
+ //}
if (isPtr(info)) {
asmClosure(bco,ptrOf(info));
} else if (isInt(info)) {
static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
{
- AsmBCO bco = asmBeginContinuation(sp);
+ AsmBCO bco = asmBeginContinuation(sp,alts);
/* ppStgAlts(alts); */
for(; nonNull(alts); alts=tl(alts)) {
StgCaseAlt alt = hd(alts);
StgPat pat = stgCaseAltPat(alt);
StgExpr body = stgCaseAltBody(alt);
if (isDefaultPat(pat)) {
- AsmSp begin = asmBeginAlt(bco);
+ //AsmSp begin = asmBeginAlt(bco);
cgBind(bco,pat);
cgExpr(bco,root,body);
asmEndContinuation(bco);
setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
} else {
asmBeginUnpack(bco);
- map1Proc(cgBind,bco,rev(vs));
+ map1Proc(cgBind,bco,reverse(vs));
asmEndUnpack(bco);
}
cgExpr(bco,root,body);
}
}
+#if 0 /* appears to be unused */
static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
{
assert(0); /* ToDo: test for patterns */
map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
cgExpr(bco,root,e);
}
+#endif
+
static AsmBCO cgLambda( StgExpr e )
{
- AsmBCO bco = asmBeginBCO();
+ AsmBCO bco = asmBeginBCO(e);
AsmSp root = asmBeginArgCheck(bco);
- map1Proc(cgBind,bco,rev(stgLambdaArgs(e)));
+ map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
asmEndArgCheck(bco,root);
/* ppStgExpr(e); */
static AsmBCO cgRhs( StgRhs rhs )
{
- AsmBCO bco = asmBeginBCO( );
+ AsmBCO bco = asmBeginBCO(rhs );
AsmSp root = asmBeginArgCheck(bco);
asmEndArgCheck(bco,root);
return bco;
}
+
static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
{
+ //printf("cgExpr:");ppStgExpr(e);printf("\n");
switch (whatIs(e)) {
case LETREC:
{
/* No need to use return address or to Slide */
AsmSp beginPrim = asmBeginPrim(bco);
- map1Proc(pushAtom,bco,rev(stgPrimArgs(scrut)));
+ map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
for(; nonNull(alts); alts=tl(alts)) {
List pats = stgPrimAltPats(alt);
StgExpr body = stgPrimAltBody(alt);
AsmSp altBegin = asmBeginAlt(bco);
- map1Proc(cgBind,bco,rev(pats));
+ map1Proc(cgBind,bco,reverse(pats));
testPrimPats(bco,root,pats,body);
asmEndAlt(bco,altBegin);
}
case STGAPP: /* Tail call */
{
AsmSp env = asmBeginEnter(bco);
- map1Proc(pushAtom,bco,rev(stgAppArgs(e)));
+ map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
pushAtom(bco,stgAppFun(e));
asmEndEnter(bco,env,root);
break;
case STGPRIM: /* Tail call again */
{
AsmSp beginPrim = asmBeginPrim(bco);
- map1Proc(pushAtom,bco,rev(stgPrimArgs(e)));
+ map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
/* map1Proc(cgBind,bco,rs_vars); */
assert(0); /* asmReturn_retty(); */
}
}
+void* itblNames[1000];
+int nItblNames = 0;
+
/* allocate space for top level variable
* any change requires a corresponding change in 'build'.
*/
pushAtom(bco,hd(args));
setPos(v,asmBox(bco,boxingConRep(con)));
} else {
- setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
+
+ void* vv = stgConInfo(con);
+ assert (nItblNames < (1000-2));
+ if (isName(con)) {
+ itblNames[nItblNames++] = vv;
+ itblNames[nItblNames++] = textToStr(name(con).text);
+ } else
+ if (isTuple(con)) {
+ char* cc = malloc(10);
+ assert(cc);
+ sprintf(cc, "Tuple%d", tupleOf(con) );
+ itblNames[nItblNames++] = vv;
+ itblNames[nItblNames++] = cc;
+ } else
+ assert ( /* cant identify constructor name */ 0 );
+
+ setPos(v,asmAllocCONSTR(bco, vv));
}
break;
}
{
StgRhs rhs = stgVarBody(v);
assert(isStgVar(v));
+
switch (whatIs(rhs)) {
case STGCON:
{
doNothing(); /* already done in alloc */
} else {
AsmSp start = asmBeginPack(bco);
- map1Proc(pushAtom,bco,rev(args));
+ map1Proc(pushAtom,bco,reverse(args));
asmEndPack(bco,getPos(v),start,stgConInfo(con));
}
return;
&& whatIs(stgVarBody(fun)) == LAMBDA
&& length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
AsmSp start = asmBeginMkPAP(bco);
- map1Proc(pushAtom,bco,rev(args));
+ map1Proc(pushAtom,bco,reverse(args));
pushAtom(bco,fun);
asmEndMkPAP(bco,getPos(v),start); /* optimisation */
} else {
AsmSp start = asmBeginMkAP(bco);
- map1Proc(pushAtom,bco,rev(args));
+ map1Proc(pushAtom,bco,reverse(args));
pushAtom(bco,fun);
asmEndMkAP(bco,getPos(v),start);
}
* for each top level variable - this should be simpler!
* ------------------------------------------------------------------------*/
+#if 0 /* appears to be unused */
static void cgAddVar( AsmObject obj, StgAtom v )
{
if (isName(v)) {
assert(isStgVar(v));
asmAddPtr(obj,getObj(v));
}
+#endif
+
/* allocate AsmObject for top level variables
* any change requires a corresponding change in endTop
switch (whatIs(rhs)) {
case STGCON:
{
- List as = stgConArgs(rhs);
+ //List as = stgConArgs(rhs);
setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
break;
}
case LAMBDA:
- setObj(v,asmBeginBCO());
+ setObj(v,asmBeginBCO(rhs));
break;
default:
setObj(v,asmBeginCAF());
static void endTop( StgVar v )
{
StgRhs rhs = stgVarBody(v);
- ppStgRhs(rhs);
+ //ppStgRhs(rhs);
switch (whatIs(rhs)) {
case STGCON:
{
/* ToDo: merge this code with cgLambda */
AsmBCO bco = (AsmBCO)getObj(v);
AsmSp root = asmBeginArgCheck(bco);
- map1Proc(cgBind,bco,rev(stgLambdaArgs(rhs)));
+ map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
asmEndArgCheck(bco,root);
cgExpr(bco,root,stgLambdaBody(rhs));
static void zap( StgVar v )
{
- stgVarBody(v) = NIL;
+ // ToDo: reinstate
+ // stgVarBody(v) = NIL;
}
/* external entry point */
Void cgBinds( List binds )
{
+ List b;
+ int i;
+
+ //if (lastModule() != modulePrelude) {
+ // printf("\n\ncgBinds: before ll\n\n" );
+ // for (b=binds; nonNull(b); b=tl(b)) {
+ // printStg ( stdout, hd(b) ); printf("\n\n");
+ // }
+ //}
+
binds = liftBinds(binds);
- mapProc(beginTop,binds);
- mapProc(endTop,binds);
- mapProc(zap,binds);
+
+ //if (lastModule() != modulePrelude) {
+ // printf("\n\ncgBinds: after ll\n\n" );
+ // for (b=binds; nonNull(b); b=tl(b)) {
+ // printStg ( stdout, hd(b) ); printf("\n\n");
+ // }
+ //}
+
+
+ //mapProc(beginTop,binds);
+ for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
+ //printf("beginTop %d\n", i);
+ beginTop(hd(b));
+ }
+
+ //mapProc(endTop,binds);
+ for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
+ endTop(hd(b));
+ //if (lastModule() != modulePrelude) {
+ // printStg ( stdout, hd(b) ); printf("\n\n");
+ //}
+ }
+
+ //mapProc(zap,binds);
}
/* --------------------------------------------------------------------------
* in the distribution for details.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:26 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:43 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "Schedule.h"
#include "link.h"
-/*#define DEBUG_SHOWSC*/ /* Must also be set in output.c */
-
Addr inputCode; /* Addr of compiled code for expr */
static Name currentName; /* Top level name being processed */
#if DEBUG_CODE
static Bool local eqExtDiscr Args((Cell,Cell));
#endif
-static Cell local lift Args((Int,List,Cell));
-static Void local liftPair Args((Int,List,Pair));
-static Void local liftTriple Args((Int,List,Triple));
-static Void local liftAlt Args((Int,List,Cell));
-static Void local liftNumcase Args((Int,List,Triple));
-static Cell local liftVar Args((List,Cell));
-static Cell local liftLetrec Args((Int,List,Cell));
-static Void local liftFundef Args((Int,List,Triple));
-static Void local solve Args((List));
-
-static Cell local preComp Args((Cell));
-static Cell local preCompPair Args((Pair));
-static Cell local preCompTriple Args((Triple));
-static Void local preCompCase Args((Pair));
-static Cell local preCompOffset Args((Int));
-
static Void local compileGlobalFunction Args((Pair));
static Void local compileGenFunction Args((Name));
static Name local compileSelFunction Args((Pair));
-static Void local newGlobalFunction Args((Name,Int,List,Int,Cell));
/* --------------------------------------------------------------------------
* Translation: Convert input expressions into a less complex language
* get inserted in the symbol table but never get removed.
*/
Name n = newName(inventText(),NIL);
+ Cell e;
StgVar v = mkStgVar(NIL,NIL);
name(n).stgVar = v;
compiler(RESET);
- stgDefn(n,0,pmcTerm(0,NIL,translate(inputExpr)));
+ e = pmcTerm(0,NIL,translate(inputExpr));
+ stgDefn(n,0,e); //ppStg(name(n).stgVar);
inputExpr = NIL;
stgCGBinds(addGlobals(singleton(v)));
-
/* Run thread (and any other runnable threads) */
/* Re-initialise the scheduler - ToDo: do I need this? */
StgVar nv = mkStgVar(NIL,NIL);
Text t = textOf(fst(bind));
Name n = findName(t);
-
+ //printf ( "addStgVar %s\n", textToStr(t));
if (isNull(n)) { /* Lookup global name - the only way*/
n = newName(t,NIL); /* this (should be able to happen) */
} /* is with new global var introduced*/
Void compileDefns() { /* compile script definitions */
Target t = length(valDefns) + length(genDefns) + length(selDefns);
Target i = 0;
-
List binds = NIL;
+
+ /* a nasty hack. But I don't know an easier way to make */
+ /* these things appear. */
+ if (lastModule() == modulePrelude) {
+ //printf ( "------ Adding cons (:) [] () \n" );
+ implementCfun ( nameCons, NIL );
+ implementCfun ( nameNil, NIL );
+ implementCfun ( nameUnit, NIL );
+ }
+
{
List vss;
List vs;
binds = addGlobals(binds);
#if USE_HUGS_OPTIMIZER
mapProc(optimiseBind,binds);
+#error optimiser
#endif
stgCGBinds(binds);
List defs = snd(bind);
Int arity = length(fst(hd(defs)));
assert(isName(n));
+
+ //{ Cell cc;
+ // printf ( "compileGlobalFunction %s\n", textToStr(name(n).text));
+ // cc = defs;
+ // while (nonNull(cc)) {
+ // printExp(stdout, fst(hd(cc)));
+ // printf ( "\n = " );
+ // printExp(stdout, snd(hd(cc)));
+ // printf( "\n" );
+ // cc = tl(cc);
+ // }
+ // printf ( "\n\n\n" );
+ //}
+
compiler(RESET);
stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
}
List defs = name(n).defn;
Int arity = length(fst(hd(defs)));
+ //{ Cell cc;
+ // printf ( "compileGenFunction %s\n", textToStr(name(n).text));
+ // cc = defs;
+ // while (nonNull(cc)) {
+ // printExp(stdout, fst(hd(cc)));
+ // printf ( "\n = " );
+ // printExp(stdout, snd(hd(cc)));
+ // printf( "\n" );
+ // cc = tl(cc);
+ // }
+ // printf ( "\n\n\n" );
+ //}
+
compiler(RESET);
currentName = n;
mapProc(transAlt,defs);
}
-#if 0
-I think this is 98-specific.
-static Void local newGlobalFunction(n,arity,fvs,co,e)
-Name n;
-Int arity;
-List fvs;
-Int co;
-Cell e; {
-#ifdef DEBUG_SHOWSC
- extern Void printSc Args((FILE*, Text, Int, Cell));
-#endif
- extraVars = fvs;
- numExtraVars = length(extraVars);
- localOffset = co;
- localArity = arity;
- name(n).arity = arity+numExtraVars;
- e = preComp(e);
-#ifdef DEBUG_SHOWSC
- if (debugCode) {
- printSc(stdout,name(n).text,name(n).arity,e);
- }
-#endif
- name(n).code = codeGen(n,name(n).arity,e);
-}
-#endif
-
/* --------------------------------------------------------------------------
* Compiler control:
* ------------------------------------------------------------------------*/
* in the distribution for details.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:27 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:43 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/
extern Module modulePrelude;
-extern Module modulePreludeHugs;
+//extern Module modulePreludeHugs;
/* --------------------------------------------------------------------------
* Primitive constructor functions
extern Void abandon Args((String,Cell));
extern Void outputString Args((FILE *));
extern Void dialogue Args((Cell));
-#define consChar(c) ap(conCons,mkChar(c))
+#define consChar(c) ap(nameCons,mkChar(c))
#if BIGNUMS
extern Bignum bigInt Args((Int));
extern Void deriveControl Args((Int));
extern Void translateControl Args((Int));
extern Void codegen Args((Int));
+extern Void machdep Args((Int));
+
+extern Void linkPreludeNames(void);
+
+extern Kind starToStar; /* Type -> Type */
+extern Type boundPair; /* (mkOffset(0),mkOffset(0)) */
+extern Type typeOrdering;
+
+extern Type conToTagType Args((Tycon));
+extern Type tagToConType Args((Tycon));
+
+#define BOGUS(k) (-9000000-(k))
+
+extern Void putChr Args((Int));
+extern Void putStr Args((String));
+extern Void putInt Args((Int));
+extern Void putPtr Args((Ptr));
+
+extern Void unlexCharConst Args((Cell));
+extern FILE *outputStream; /* current output stream */
+extern Int outColumn; /* current output column number */
+
+extern Void unlexStrConst Args((Text));
+extern Void unlexVar Args((Text));
+extern List offsetTyvarsIn Args((Type,List));
+
+extern List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
* Hugs version 1.4, December 1997
*
* $RCSfile: derive.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:27 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:44 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "backend.h"
#include "connect.h"
#include "errors.h"
+#include "Assembler.h"
+#include "link.h"
static Cell varTrue;
static Cell varFalse;
static Cell varRange;
static Cell varIndex;
static Cell varMult;
-static Cell varPlus;
+static Cell qvarPlus;
static Cell varMap;
-static Cell varMinus;
+static Cell qvarMinus;
static Cell varError;
#endif
#if DERIVE_ENUM
return singleton(pair(NIL,pair(mkInt(line),r)));
}
+#if DERIVE_EQ || DERIVE_ORD
+static List local makeDPats2(h,n) /* generate pattern list */
+Cell h; /* by putting two new patterns with*/
+Int n; { /* head h and new var components */
+ List us = getDiVars(2*n);
+ List vs = NIL;
+ Cell p;
+ Int i;
+
+ for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
+ p = ap(p,hd(us));
+ us = tl(us);
+ }
+ vs = cons(p,vs);
+
+ for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
+ p = ap(p,hd(us));
+ us = tl(us);
+ }
+ return cons(p,vs);
+}
+#endif
+
+#if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
+static Bool local isEnumType(t) /* Determine whether t is an enumeration */
+Tycon t; { /* type (i.e. all constructors arity == 0) */
+ if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
+ List cs = tycon(t).defn;
+ for (; hasCfun(cs); cs=tl(cs)) {
+ if (name(hd(cs)).arity!=0) {
+ return FALSE;
+ }
+ }
+ /* ToDo: correct? addCfunTable(t); */
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+
/* --------------------------------------------------------------------------
* Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
* The derived definitions of equality and ordering are given by:
* constructors in the datatype definition.
* ------------------------------------------------------------------------*/
-#define ap2(f,x,y) ap(ap(f,x),y)
+#if DERIVE_EQ
+
+static Pair local mkAltEq Args((Int,List));
-List local deriveEq(t) /* generate binding for derived == */
+List deriveEq(t) /* generate binding for derived == */
Type t; { /* for some TUPLE or DATATYPE t */
List alts = NIL;
if (isTycon(t)) { /* deal with type constrs */
List cs = tycon(t).defn;
for (; hasCfun(cs); cs=tl(cs)) {
alts = cons(mkAltEq(tycon(t).line,
- makeDPats2(hd(cs),userArity(hd(cs)))),
+ makeDPats2(hd(cs),name(hd(cs)).arity)),
alts);
}
if (cfunOf(hd(tycon(t).defn))!=0) {
alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
- pair(mkInt(tycon(t).line),nameFalse)),alts);
+ pair(mkInt(tycon(t).line),varFalse)),alts);
}
alts = rev(alts);
- }
- else { /* special case for tuples */
+ } else { /* special case for tuples */
alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
}
return singleton(mkBind("==",alts));
List pats; { /* arguments */
Cell p = hd(pats);
Cell q = hd(tl(pats));
- Cell e = nameTrue;
+ Cell e = varTrue;
if (isAp(p)) {
- e = ap2(nameEq,arg(p),arg(q));
+ e = ap2(varEq,arg(p),arg(q));
for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
- e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
+ e = ap2(varAnd,ap2(varEq,arg(p),arg(q)),e);
}
}
return pair(pats,pair(mkInt(line),e));
}
+#endif /* DERIVE_EQ */
+
+#if DERIVE_ORD
+
+static Pair local mkAltOrd Args((Int,List));
List deriveOrd(t) /* make binding for derived compare*/
Type t; { /* for some TUPLE or DATATYPE t */
List alts = NIL;
if (isEnumType(t)) { /* special case for enumerations */
- alts = mkVarAlts(tycon(t).line,nameConCmp);
+ Cell u = inventVar();
+ Cell w = inventVar();
+ Cell rhs = NIL;
+ if (cfunOf(hd(tycon(t).defn))!=0) {
+ implementConToTag(t);
+ rhs = ap2(varCompare,
+ ap(tycon(t).conToTag,u),
+ ap(tycon(t).conToTag,w));
+ } else {
+ rhs = varEQ;
+ }
+ alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
} else if (isTycon(t)) { /* deal with type constrs */
List cs = tycon(t).defn;
for (; hasCfun(cs); cs=tl(cs)) {
alts = cons(mkAltOrd(tycon(t).line,
- makeDPats2(hd(cs),userArity(hd(cs)))),
+ makeDPats2(hd(cs),name(hd(cs)).arity)),
alts);
}
if (cfunOf(hd(tycon(t).defn))!=0) {
Cell u = inventVar();
Cell w = inventVar();
- alts = cons(pair(cons(u,singleton(w)),
+ implementConToTag(t);
+ alts = cons(pair(doubleton(u,w),
pair(mkInt(tycon(t).line),
- ap2(nameConCmp,u,w))),alts);
+ ap2(varCompare,
+ ap(tycon(t).conToTag,u),
+ ap(tycon(t).conToTag,w)))),
+ alts);
}
alts = rev(alts);
} else { /* special case for tuples */
List pats; { /* arguments */
Cell p = hd(pats);
Cell q = hd(tl(pats));
- Cell e = nameEQ;
+ Cell e = varEQ;
if (isAp(p)) {
- e = ap2(nameCompare,arg(p),arg(q));
+ e = ap2(varCompare,arg(p),arg(q));
for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
- e = ap(ap2(nameCompAux,arg(p),arg(q)),e);
+ e = ap3(varCompAux,arg(p),arg(q),e);
}
}
return pair(pats,pair(mkInt(line),e));
}
+#endif /* DERIVE_ORD */
-static List local makeDPats2(h,n) /* generate pattern list */
-Cell h; /* by putting two new patterns with*/
-Int n; { /* head h and new var components */
- List us = getDiVars(2*n);
- List vs = NIL;
- Cell p;
- Int i;
-
- for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
- p = ap(p,hd(us));
- us = tl(us);
- }
- vs = cons(p,vs);
-
- for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
- p = ap(p,hd(us));
- us = tl(us);
- }
- return cons(p,vs);
-}
/* --------------------------------------------------------------------------
* Deriving Ix and Enum:
* ------------------------------------------------------------------------*/
+#if DERIVE_ENUM
List deriveEnum(t) /* Construct definition of enumeration */
Tycon t; {
- Int l = tycon(t).line;
+ Int l = tycon(t).line;
+ Cell x = inventVar();
+ Cell y = inventVar();
+ Cell first = hd(tycon(t).defn);
+ Cell last = tycon(t).defn;
if (!isEnumType(t)) {
ERRMSG(l) "Can only derive instances of Enum for enumeration types"
EEND;
}
-
- return cons(mkBind("toEnum",mkVarAlts(l,ap(nameEnToEn,hd(tycon(t).defn)))),
- cons(mkBind("fromEnum",mkVarAlts(l,nameEnFrEn)),
- cons(mkBind("enumFrom",mkVarAlts(l,nameEnFrom)),
- cons(mkBind("enumFromTo",mkVarAlts(l,nameEnFrTo)),
- cons(mkBind("enumFromThen",mkVarAlts(l,nameEnFrTh)),NIL)))));
+ while (hasCfun(tl(last))) {
+ last = tl(last);
+ }
+ last = hd(last);
+ implementConToTag(t);
+ implementTagToCon(t);
+ return cons(mkBind("toEnum", mkVarAlts(l,tycon(t).tagToCon)),
+ cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
+ cons(mkBind("enumFrom", singleton(pair(singleton(x),
+ pair(mkInt(l),
+ ap2(varEnumFromTo,x,last))))),
+ /* default instance of enumFromTo is good */
+ cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),
+ pair(mkInt(l),
+ ap3(varEnumFromThenTo,x,y,
+ ap(COND,triple(ap2(varLe,x,y),
+ last,first))))))),
+ /* default instance of enumFromThenTo is good */
+ NIL))));
}
+#endif /* DERIVE_ENUM */
+
+#if DERIVE_IX
+static List local mkIxBindsEnum Args((Tycon));
+static List local mkIxBinds Args((Int,Cell,Int));
+static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
+static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
+static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
List deriveIx(t) /* Construct definition of indexing */
Tycon t; {
if (isEnumType(t)) { /* Definitions for enumerations */
- return cons(mkBind("range",mkVarAlts(tycon(t).line,nameEnRange)),
- cons(mkBind("index",mkVarAlts(tycon(t).line,nameEnIndex)),
- cons(mkBind("inRange",mkVarAlts(tycon(t).line,nameEnInRng)),
- NIL)));
+ implementConToTag(t);
+ implementTagToCon(t);
+ return mkIxBindsEnum(t);
} else if (isTuple(t)) { /* Definitions for product types */
return mkIxBinds(0,t,tupleOf(t));
} else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
return mkIxBinds(tycon(t).line,
hd(tycon(t).defn),
- userArity(hd(tycon(t).defn)));
+ name(hd(tycon(t).defn)).arity);
}
ERRMSG(tycon(t).line)
"Can only derive instances of Ix for enumeration or product types"
return NIL;/* NOTREACHED*/
}
-static Bool local isEnumType(t) /* Determine whether t is an enumeration */
-Tycon t; { /* type (i.e. all constructors arity == 0) */
- if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
- List cs = tycon(t).defn;
- for (; hasCfun(cs); cs=tl(cs)) {
- if (name(hd(cs)).arity!=0) {
- return FALSE;
- }
- }
- /* ToDo: correct? addCfunTable(t); */
- return TRUE;
- }
- return FALSE;
+/* instance Ix T where
+ * range (c1,c2) = map tagToCon [conToTag c1 .. conToTag c2]
+ * index b@(c1,c2) ci
+ * | inRange b ci = conToTag ci - conToTag c1
+ * | otherwise = error "Ix.index.T: Index out of range."
+ * inRange (c1,c2) ci = conToTag c1 <= i && i <= conToTag c2
+ * where i = conToTag ci
+ */
+static List local mkIxBindsEnum(t)
+Tycon t; {
+ Int l = tycon(t).line;
+ Name tagToCon = tycon(t).tagToCon;
+ Name conToTag = tycon(t).conToTag;
+ Cell b = inventVar();
+ Cell c1 = inventVar();
+ Cell c2 = inventVar();
+ Cell ci = inventVar();
+ return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),
+ c1,c2)), pair(mkInt(l),ap2(varMap,tagToCon,
+ ap2(varEnumFromTo,ap(conToTag,c1),
+ ap(conToTag,c2))))))),
+ cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,
+ ap2(mkTuple(2),c1,c2))),ci),
+ pair(mkInt(l),ap(COND,
+ triple(ap2(varInRange,b,ci),
+ ap2(qvarMinus,ap(conToTag,ci),
+ ap(conToTag,c1)),
+ ap(varError,mkStr(findText(
+ "Ix.index: Index out of range"))))))))),
+ cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),
+ c1,c2),ci), pair(mkInt(l),ap2(varAnd,
+ ap2(varLe,ap(conToTag,c1),ap(conToTag,ci)),
+ ap2(varLe,ap(conToTag,ci),
+ ap(conToTag,c2))))))),
+ /* ToDo: share conToTag ci */
+ NIL)));
}
static List local mkIxBinds(line,h,n) /* build bindings for derived Ix on*/
pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
return cons(prodRange(line,singleton(pr),ls,us,is),
- cons(prodIndex(line,pats,ls,us,is),
- cons(prodInRange(line,pats,ls,us,is),NIL)));
+ cons(prodIndex(line,pats,ls,us,is),
+ cons(prodInRange(line,pats,ls,us,is),
+ NIL)));
}
static Cell local prodRange(line,pats,ls,us,is)
List e = NIL;
for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
e = cons(ap(FROMQUAL,pair(arg(is),
- ap(nameRange,ap2(mkTuple(2),
+ ap(varRange,ap2(mkTuple(2),
arg(ls),
arg(us))))),e);
}
List xs = NIL;
Cell e = NIL;
for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
- xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
+ xs = cons(ap2(varIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
}
for (e=hd(xs); nonNull(xs=tl(xs));) {
Cell x = hd(xs);
- e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
+ e = ap2(qvarPlus,x,ap2(varMult,ap(varRangeSize,arg(fun(x))),e));
}
e = singleton(pair(pats,pair(mkInt(line),e)));
return mkBind("index",e);
* inRange (X a b c, X p q r) (X x y z)
* = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
*/
- Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
+ Cell e = ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
- e = ap2(nameAnd,
- ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
+ e = ap2(varAnd,
+ ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
e);
}
e = singleton(pair(pats,pair(mkInt(line),e)));
return mkBind("inRange",e);
}
+#endif /* DERIVE_IX */
+
/* --------------------------------------------------------------------------
* Deriving Show:
#endif /* DERIVE_BOUNDED */
+
+/* --------------------------------------------------------------------------
+ * Helpers: conToTag and tagToCon
+ * ------------------------------------------------------------------------*/
+
+/* \ v -> case v of { ...; Ci _ _ -> i; ... } */
+Void implementConToTag(t)
+Tycon t; {
+ if (isNull(tycon(t).conToTag)) {
+ List cs = tycon(t).defn;
+ Name nm = newName(inventText(),NIL);
+ StgVar v = mkStgVar(NIL,NIL);
+ List alts = NIL; /* can't fail */
+
+ assert(isTycon(t) && (tycon(t).what==DATATYPE
+ || tycon(t).what==NEWTYPE));
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
+ StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),
+ NIL);
+ StgExpr tag = mkStgLet(singleton(r),r);
+ List vs = NIL;
+ Int i;
+ for(i=0; i < name(c).arity; ++i) {
+ vs = cons(mkStgVar(NIL,NIL),vs);
+ }
+ alts = cons(mkStgCaseAlt(c,vs,tag),alts);
+ }
+
+ name(nm).line = tycon(t).line;
+ name(nm).type = conToTagType(t);
+ name(nm).arity = 1;
+ name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
+ NIL);
+ tycon(t).conToTag = nm;
+ /* hack to make it print out */
+ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ }
+}
+
+/* \ v -> case v of { ...; i -> Ci; ... } */
+Void implementTagToCon(t)
+Tycon t; {
+ if (isNull(tycon(t).tagToCon)) {
+ String etxt;
+ String tyconname;
+ List cs;
+ Name nm;
+ StgVar v1;
+ StgVar v2;
+ Cell txt0;
+ StgVar bind1;
+ StgVar bind2;
+ StgVar bind3;
+ List alts;
+
+ assert(nameMkA);
+ assert(nameUnpackString);
+ assert(nameError);
+ assert(isTycon(t) && (tycon(t).what==DATATYPE
+ || tycon(t).what==NEWTYPE));
+
+ tyconname = textToStr(tycon(t).text);
+ etxt = malloc(100+strlen(tyconname));
+ assert(etxt);
+ sprintf(etxt,
+ "out-of-range arg for `toEnum' "
+ "in derived `instance Enum %s'",
+ tyconname);
+
+ cs = tycon(t).defn;
+ nm = newName(inventText(),NIL);
+ v1 = mkStgVar(NIL,NIL);
+ v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
+
+ txt0 = mkStr(findText(etxt));
+ bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
+ bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)),NIL);
+ bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)),NIL);
+
+ alts = singleton(
+ mkStgPrimAlt(
+ singleton(
+ mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
+ ),
+ makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
+ )
+ );
+
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
+ StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
+ assert(name(c).arity==0);
+ alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
+ }
+
+ name(nm).line = tycon(t).line;
+ name(nm).type = tagToConType(t);
+ name(nm).arity = 1;
+ name(nm).stgVar = mkStgVar(
+ mkStgLambda(
+ singleton(v1),
+ mkStgCase(
+ v1,
+ singleton(
+ mkStgCaseAlt(
+ nameMkI,
+ singleton(v2),
+ mkStgPrimCase(v2,alts))))),
+ NIL
+ );
+ tycon(t).tagToCon = nm;
+ /* hack to make it print out */
+ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ if (etxt) free(etxt);
+ }
+}
+
+
/* --------------------------------------------------------------------------
* Derivation control:
* ------------------------------------------------------------------------*/
Void deriveControl(what)
Int what; {
- Text textPrelude = findText("PreludeBuiltin");
+ Text textPrelude = findText("Prelude");
switch (what) {
case INSTALL :
varTrue = mkQVar(textPrelude,findText("True"));
varRange = mkQVar(textPrelude,findText("range"));
varIndex = mkQVar(textPrelude,findText("index"));
varMult = mkQVar(textPrelude,findText("*"));
- varPlus = mkQVar(textPrelude,findText("+"));
+ qvarPlus = mkQVar(textPrelude,findText("+"));
varMap = mkQVar(textPrelude,findText("map"));
- varMinus = mkQVar(textPrelude,findText("-"));
+ qvarMinus = mkQVar(textPrelude,findText("-"));
varError = mkQVar(textPrelude,findText("error"));
#endif
#if DERIVE_ENUM
varToEnum = mkQVar(textPrelude,findText("toEnum"));
varFromEnum = mkQVar(textPrelude,findText("fromEnum"));
- varEnumFromTo = mkQVar(textPrelude,findText("enumFromTo"));
- varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo"));
+ varEnumFromTo = mkQVar(textPrelude,findText("enumFromTo"));
+ varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo"));
#endif
#if DERIVE_BOUNDED
varMinBound = mkQVar(textPrelude,findText("minBound"));
mark(varRange);
mark(varIndex);
mark(varMult);
- mark(varPlus);
+ mark(qvarPlus);
mark(varMap);
- mark(varMinus);
+ mark(qvarMinus);
mark(varError);
#endif
#if DERIVE_ENUM
* Hugs version 1.4, December 1997
*
* $RCSfile: dynamic.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:28 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:45 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include <stdio.h>
#include <dlfcn.h>
+#if 0 /* apparently unused */
ObjectFile loadLibrary(fn)
String fn; {
return dlopen(fn,RTLD_NOW | RTLD_GLOBAL);
String symbol; {
return dlsym(file,symbol);
}
+#endif
void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */
String dll;
* in the distribution for details.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:29 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:45 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
static Bool showStats = FALSE; /* TRUE => print stats after eval */
static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
static Bool addType = FALSE; /* TRUE => print type with value */
-static Bool useShow = TRUE; /* TRUE => use Text/show printer */
static Bool chaseImports = TRUE; /* TRUE => chase imports on load */
static Bool useDots = RISCOS; /* TRUE => use dots in progress */
static Bool quiet = FALSE; /* TRUE => don't show progress */
static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
static String lastEdit = 0; /* Name of script to edit (if any) */
-static Int lastLine = 0; /* Editor line number (if possible)*/
+static Int lastEdLine = 0; /* Editor line number (if possible)*/
static String prompt = 0; /* Prompt string */
static Int hpSize = DEFAULTHEAP; /* Desired heap size */
String hugsEdit = 0; /* String for editor command */
Main main(argc,argv)
int argc;
char *argv[]; {
-
#ifdef HAVE_CONSOLE_H /* Macintosh port */
_ftype = 'TEXT';
_fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
interpreter(argc,argv);
Printf("[Leaving Hugs]\n");
everybody(EXIT);
+ shutdownHaskell();
FlushStdout();
fflush(stderr);
exit(0);
#endif /* USE_REGISTRY */
readOptions(fromEnv("HUGSFLAGS",""));
- for (i=1; i<argc; ++i) { /* process command line arguments */
+ startupHaskell ( argc, argv );
+ argc = prog_argc; argv = prog_argv;
+
+ for (i=1; i<argc; ++i) { /* process command line arguments */
if (strcmp(argv[i],"+")==0 && i+1<argc) {
if (proj) {
ERRMSG(0) "Multiple project filenames on command line"
addScriptName(argv[i],TRUE);
}
}
- /* ToDo: clean up this hack */
- {
- static char* my_argv[] = {"Hugs"};
- startupHaskell(sizeof(my_argv)/sizeof(char*),my_argv);
- }
+
#ifdef DEBUG
DEBUG_LoadSymbols(argv[0]);
#endif
Int n = 0;
String t = s;
- if (*s=='\0' || !isascii(*s) || !isdigit(*s)) {
+ if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
ERRMSG(0) "Missing integer in option setting \"%s\"", t
EEND;
}
EEND;
}
n = 10*n + d;
- } while (isascii(*s) && isdigit(*s));
+ } while (isascii((int)(*s)) && isdigit((int)(*s)));
if (*s=='K' || *s=='k') {
if (n > (MAXPOSINT/1000)) {
}
static Void local runEditor() { /* run editor on script lastEdit */
- if (startEdit(lastLine,lastEdit)) /* at line lastLine */
+ if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
readScripts(scriptBase);
}
if (lastEdit)
free(lastEdit);
lastEdit = strCopy(fname);
- lastLine = line;
+ lastEdLine = line;
#if HUGS_FOR_WINDOWS
DrawStatusLine(hWndMain); /* Redo status line */
#endif
static Void local evaluator() { /* evaluate expr and print value */
Type type, bd;
Kinds ks = NIL;
- Cell temp = NIL;
setCurrModule(findEvalModule());
scriptFile = 0;
#ifdef WANT_TIMER
updateTimers();
#endif
+
+#if 1
if (typeMatches(type,ap(typeIO,typeUnit))) {
inputExpr = ap(nameRunIO,inputExpr);
evalExp();
ERRTEXT "\n"
EEND;
}
- inputExpr = ap2(namePrint,d,inputExpr);
- inputExpr = ap(nameRunIO,inputExpr);
- evalExp();
+ //inputExpr = ap2(namePrint,d,inputExpr);
+ //inputExpr = ap(nameRunIO,inputExpr);
+
+ inputExpr = ap2(findName(findText("show")),d,inputExpr);
+ inputExpr = ap(findName(findText("putStr")), inputExpr);
+ inputExpr = ap(nameRunIO, inputExpr);
+
+ evalExp(); printf("\n");
if (addType) {
printf(" :: ");
printType(stdout,type);
Putchar('\n');
}
}
+#endif
+
+#if 0
+ printf ( "result type is " );
+ printType ( stdout, type );
+ printf ( "\n" );
+ evalExp();
+ printf ( "\n" );
+#endif
+
}
static Void local stopAnyPrinting() { /* terminate printing of expression,*/
Tycon tc = findTycon(t);
Class cl = findClass(t);
Name nm = findName(t);
- Module mod = findEvalModule();
+ //Module mod = findEvalModule();
if (nonNull(tc)) { /* as a type constructor */
Type t = tc;
case NON_ASS : break;
}
Printf(" %i ",precOf(sy));
- if (isascii(*s) && isalpha(*s)) {
+ if (isascii((int)(*s)) && isalpha((int)(*s))) {
Printf("`%s`",s);
} else {
Printf("%s",s);
/* ----------------------------------------------------------------------- */
-static HugsStream outputStream;
+static HugsStream outputStreamH;
/* ADR note:
- * We rely on standard C semantics to initialise outputStream.next to 0.
+ * We rely on standard C semantics to initialise outputStreamH.next to 0.
*/
Void hugsEnableOutput(f)
}
String hugsClearOutputBuffer() {
- return bufferClear(&outputStream);
+ return bufferClear(&outputStreamH);
}
#ifdef HAVE_STDARG_H
if (!disableOutput) {
vprintf(fmt, ap);
} else {
- vBufferedPrintf(&outputStream, fmt, ap);
+ vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap); /* clean up */
}
if (!disableOutput) {
vprintf(fmt, ap);
} else {
- vBufferedPrintf(&outputStream, fmt, ap);
+ vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap); /* clean up */
}
if (!disableOutput) {
putchar(c);
} else {
- bufferedPutchar(&outputStream, c);
+ bufferedPutchar(&outputStreamH, c);
}
}
if (!disableOutput) {
vfprintf(fp, fmt, ap);
} else {
- vBufferedPrintf(&outputStream, fmt, ap);
+ vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap);
}
if (!disableOutput) {
vfprintf(fp, fmt, ap);
} else {
- vBufferedPrintf(&outputStream, fmt, ap);
+ vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap);
}
if (!disableOutput) {
putc(c,fp);
} else {
- bufferedPutchar(&outputStream, c);
+ bufferedPutchar(&outputStreamH, c);
}
}
* in the distribution for details.
*
* $RCSfile: input.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:30 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:46 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Text textModule, textImport;
static Text textHiding, textQualified, textAsMod;
-static Text textExport, textInterface, textRequires, textUnsafe;
+static Text textExport, textUnsafe;
Text textNum; /* Num */
Text textPrelude; /* Prelude */
}
endToken();
-#ifndef HAVE_LIBM
- ERRMSG(row) "No floating point numbers in this implementation"
- EEND;
-#endif
-
return mkFloat(stringToFloat(tokenStr));
}
* Hugs version 1.4, December 1997
*
* $RCSfile: lift.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:31 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:47 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
return TRUE; /* those at top level are already there */
} else {
#if LIFT_CONSTANTS
+#error lift constants
StgRhs rhs = stgVarBody(v);
switch (whatIs(rhs)) {
case STGCON:
case STGCON:
case STGAPP:
#if LIFT_CONSTANTS
+#error lift constants
if (isNull(fvs)) {
StgVar v = mkStgVar(rhs,NONE);
stgVarBody(bind) = mkStgLet(singleton(v),v);
stgVarBody(bind) = makeStgApp(v, fvs);
}
#if LIFT_CONSTANTS
+#error lift constants
else {
StgVar r = mkStgVar(rhs,NIL); /* copy the var */
StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
* Hugs version 1.4, December 1997
*
* $RCSfile: link.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/02/03 17:08:31 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/01 14:46:47 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "link.h"
-Module modulePreludeHugs;
+////Module modulePreludeHugs;
-Type typeArrow; /* Function spaces */
-Type typeChar;
-Type typeInt;
+Type typeArrow =BOGUS(1); /* Function spaces */
+
+Type typeChar =BOGUS(2);
+Type typeInt =BOGUS(3);
#ifdef PROVIDE_INT64
-Type typeInt64;
+Type typeInt64 =BOGUS(4);
#endif
#ifdef PROVIDE_INTEGER
-Type typeInteger;
+Type typeInteger =BOGUS(5);
#endif
#ifdef PROVIDE_WORD
-Type typeWord;
+Type typeWord =BOGUS(6);
#endif
#ifdef PROVIDE_ADDR
-Type typeAddr;
+Type typeAddr =BOGUS(7);
#endif
#ifdef PROVIDE_ARRAY
-Type typePrimArray;
-Type typePrimByteArray;
-Type typeRef;
-Type typePrimMutableArray;
-Type typePrimMutableByteArray;
-#endif
-Type typeFloat;
-Type typeDouble;
+Type typePrimArray =BOGUS(8);
+Type typePrimByteArray =BOGUS(9);
+Type typeRef =BOGUS(10);
+Type typePrimMutableArray =BOGUS(11);
+Type typePrimMutableByteArray =BOGUS(12);
+#endif
+Type typeFloat =BOGUS(13);
+Type typeDouble =BOGUS(14);
#ifdef PROVIDE_STABLE
-Type typeStable;
+Type typeStable =BOGUS(15);
#endif
#ifdef PROVIDE_WEAK
-Type typeWeak;
+Type typeWeak =BOGUS(16);
#endif
#ifdef PROVIDE_FOREIGN
-Type typeForeign;
+Type typeForeign =BOGUS(17);
#endif
#ifdef PROVIDE_CONCURRENT
-Type typeThreadId;
-Type typeMVar;
-#endif
-
-Type typeList;
-Type typeUnit;
-Type typeString;
-Type typeBool;
-Type typeST;
-Type typeIO;
-Type typeException;
-
-Class classEq; /* `standard' classes */
-Class classOrd;
-Class classShow;
-Class classRead;
-Class classIx;
-Class classEnum;
-Class classBounded;
+Type typeThreadId =BOGUS(18);
+Type typeMVar =BOGUS(19);
+#endif
+
+Type typeList =BOGUS(20);
+Type typeUnit =BOGUS(21);
+Type typeString =BOGUS(22);
+Type typeBool =BOGUS(23);
+Type typeST =BOGUS(24);
+Type typeIO =BOGUS(25);
+Type typeException =BOGUS(26);
+
+Class classEq =BOGUS(27); /* `standard' classes */
+Class classOrd =BOGUS(28);
+Class classShow =BOGUS(29);
+Class classRead =BOGUS(30);
+Class classIx =BOGUS(31);
+Class classEnum =BOGUS(32);
+Class classBounded =BOGUS(33);
#if EVAL_INSTANCES
-Class classEval;
-#endif
-
-Class classReal; /* `numeric' classes */
-Class classIntegral;
-Class classRealFrac;
-Class classRealFloat;
-Class classFractional;
-Class classFloating;
-Class classNum;
-
-Class classMonad; /* Monads and monads with a zero */
-/*Class classMonad0;*/
-
-List stdDefaults; /* standard default values */
-
-Name nameTrue, nameFalse; /* primitive boolean constructors */
-Name nameNil, nameCons; /* primitive list constructors */
-Name nameUnit; /* primitive Unit type constructor */
-
-Name nameEq;
-Name nameFromInt, nameFromDouble; /* coercion of numerics */
-Name nameFromInteger;
-Name nameReturn, nameBind; /* for translating monad comps */
-Name nameZero; /* for monads with a zero */
+Class classEval =BOGUS(34);
+#endif
+
+Class classReal =BOGUS(35); /* `numeric' classes */
+Class classIntegral =BOGUS(36);
+Class classRealFrac =BOGUS(37);
+Class classRealFloat =BOGUS(38);
+Class classFractional =BOGUS(39);
+Class classFloating =BOGUS(40);
+Class classNum =BOGUS(41);
+
+Class classMonad =BOGUS(42); /* Monads and monads with a zero */
+/*Class classMonad0 =BOGUS();*/
+
+List stdDefaults =BOGUS(43); /* standard default values */
+
+Name nameTrue =BOGUS(44),
+ nameFalse =BOGUS(45); /* primitive boolean constructors */
+Name nameNil =BOGUS(46),
+ nameCons =BOGUS(47); /* primitive list constructors */
+Name nameUnit =BOGUS(48); /* primitive Unit type constructor */
+
+Name nameEq =BOGUS(49);
+Name nameFromInt =BOGUS(50),
+ nameFromDouble =BOGUS(51); /* coercion of numerics */
+Name nameFromInteger =BOGUS(52);
+Name nameReturn =BOGUS(53),
+ nameBind =BOGUS(54); /* for translating monad comps */
+Name nameZero =BOGUS(55); /* for monads with a zero */
#if EVAL_INSTANCES
-Name nameStrict; /* Members of class Eval */
-Name nameSeq;
+Name nameStrict =BOGUS(56); /* Members of class Eval */
+Name nameSeq =BOGUS(57);
#endif
-Name nameId;
-Name nameRunIO;
-Name namePrint;
+Name nameId =BOGUS(58);
+Name nameRunIO =BOGUS(59);
+Name namePrint =BOGUS(60);
-Name nameOtherwise;
-Name nameUndefined; /* generic undefined value */
+Name nameOtherwise =BOGUS(61);
+Name nameUndefined =BOGUS(62); /* generic undefined value */
#if NPLUSK
-Name namePmSub;
+Name namePmSub =BOGUS(63);
#endif
-Name namePMFail;
-Name nameEqChar;
-Name nameEqInt;
+Name namePMFail =BOGUS(64);
+Name nameEqChar =BOGUS(65);
+Name nameEqInt =BOGUS(66);
#if !OVERLOADED_CONSTANTS
-Name nameEqInteger;
-#endif
-Name nameEqDouble;
-Name namePmInt;
-Name namePmInteger;
-Name namePmDouble;
-Name namePmLe;
-Name namePmSubtract;
-Name namePmFromInteger;
-Name nameMkIO;
-Name nameUnpackString;
-Name nameError;
-Name nameInd;
-
-Name nameForce;
-
-Name nameAnd;
-Name nameHw;
-Name nameConCmp;
-Name nameCompAux;
-Name nameEnFrTh;
-Name nameEnFrTo;
-Name nameEnFrom;
-Name nameEnFrEn;
-Name nameEnToEn;
-Name nameEnInRng;
-Name nameEnIndex;
-Name nameEnRange;
-Name nameRangeSize;
-Name nameComp;
-Name nameShowField;
-Name nameApp;
-Name nameShowParen;
-Name nameReadParen;
-Name nameLex;
-Name nameReadField;
-Name nameFlip;
-Name nameFromTo;
-Name nameFromThen;
-Name nameFrom;
-Name nameFromThenTo;
-Name nameNegate;
+Name nameEqInteger =BOGUS(67);
+#endif
+Name nameEqDouble =BOGUS(68);
+Name namePmInt =BOGUS(69);
+Name namePmInteger =BOGUS(70);
+Name namePmDouble =BOGUS(71);
+Name namePmLe =BOGUS(72);
+Name namePmSubtract =BOGUS(73);
+Name namePmFromInteger =BOGUS(74);
+Name nameMkIO =BOGUS(75);
+Name nameUnpackString =BOGUS(76);
+Name nameError =BOGUS(77);
+Name nameInd =BOGUS(78);
+
+Name nameForce =BOGUS(79);
+
+Name nameAnd =BOGUS(80);
+Name nameConCmp =BOGUS(82);
+Name nameCompAux =BOGUS(83);
+Name nameEnFrTh =BOGUS(84);
+Name nameEnFrTo =BOGUS(85);
+Name nameEnFrom =BOGUS(86);
+Name nameEnFrEn =BOGUS(87);
+Name nameEnToEn =BOGUS(88);
+Name nameEnInRng =BOGUS(89);
+Name nameEnIndex =BOGUS(90);
+Name nameEnRange =BOGUS(91);
+Name nameRangeSize =BOGUS(92);
+Name nameComp =BOGUS(93);
+Name nameShowField =BOGUS(94);
+Name nameApp =BOGUS(95);
+Name nameShowParen =BOGUS(96);
+Name nameReadParen =BOGUS(97);
+Name nameLex =BOGUS(98);
+Name nameReadField =BOGUS(99);
+Name nameFlip =BOGUS(100);
+Name nameFromTo =BOGUS(101);
+Name nameFromThen =BOGUS(102);
+Name nameFrom =BOGUS(103);
+Name nameFromThenTo =BOGUS(104);
+Name nameNegate =BOGUS(105);
/* these names are required before we've had a chance to do the right thing */
-Name nameSel;
-Name nameUnsafeUnpackCString;
+Name nameSel =BOGUS(106);
+Name nameUnsafeUnpackCString =BOGUS(107);
/* constructors used during translation and codegen */
-Name nameMkC; /* Char# -> Char */
-Name nameMkI; /* Int# -> Int */
+Name nameMkC =BOGUS(108); /* Char# -> Char */
+Name nameMkI =BOGUS(109); /* Int# -> Int */
#ifdef PROVIDE_INT64
-Name nameMkInt64; /* Int64# -> Int64 */
+Name nameMkInt64 =BOGUS(110); /* Int64# -> Int64 */
#endif
#ifdef PROVIDE_INTEGER
-Name nameMkInteger; /* Integer# -> Integer */
+Name nameMkInteger =BOGUS(111); /* Integer# -> Integer */
#endif
#ifdef PROVIDE_WORD
-Name nameMkW; /* Word# -> Word */
+Name nameMkW =BOGUS(112); /* Word# -> Word */
#endif
#ifdef PROVIDE_ADDR
-Name nameMkA; /* Addr# -> Addr */
+Name nameMkA =BOGUS(113); /* Addr# -> Addr */
#endif
-Name nameMkF; /* Float# -> Float */
-Name nameMkD; /* Double# -> Double */
+Name nameMkF =BOGUS(114); /* Float# -> Float */
+Name nameMkD =BOGUS(115); /* Double# -> Double */
#ifdef PROVIDE_ARRAY
-Name nameMkPrimArray;
-Name nameMkPrimByteArray;
-Name nameMkRef;
-Name nameMkPrimMutableArray;
-Name nameMkPrimMutableByteArray;
+Name nameMkPrimArray =BOGUS(116);
+Name nameMkPrimByteArray =BOGUS(117);
+Name nameMkRef =BOGUS(118);
+Name nameMkPrimMutableArray =BOGUS(119);
+Name nameMkPrimMutableByteArray =BOGUS(120);
#endif
#ifdef PROVIDE_STABLE
-Name nameMkStable; /* StablePtr# a -> StablePtr a */
+Name nameMkStable =BOGUS(121); /* StablePtr# a -> StablePtr a */
#endif
#ifdef PROVIDE_WEAK
-Name nameMkWeak; /* Weak# a -> Weak a */
+Name nameMkWeak =BOGUS(122); /* Weak# a -> Weak a */
#endif
#ifdef PROVIDE_FOREIGN
-Name nameMkForeign; /* ForeignObj# -> ForeignObj */
+Name nameMkForeign =BOGUS(123); /* ForeignObj# -> ForeignObj */
#endif
#ifdef PROVIDE_CONCURRENT
-Name nameMkThreadId; /* ThreadId# -> ThreadId */
-Name nameMkMVar; /* MVar# -> MVar */
+Name nameMkThreadId =BOGUS(124); /* ThreadId# -> ThreadId */
+Name nameMkMVar =BOGUS(125); /* MVar# -> MVar */
#endif
+
+
+Name nameMinBnd =BOGUS(400);
+Name nameMaxBnd =BOGUS(401);
+Name nameCompare =BOGUS(402);
+Name nameShowsPrec =BOGUS(403);
+Name nameIndex =BOGUS(404);
+Name nameReadsPrec =BOGUS(405);
+Name nameRange =BOGUS(406);
+Name nameEQ =BOGUS(407);
+Name nameInRange =BOGUS(408);
+Name nameGt =BOGUS(409);
+Name nameLe =BOGUS(410);
+Name namePlus =BOGUS(411);
+Name nameMult =BOGUS(412);
+Name nameMFail =BOGUS(413);
+Type typeOrdering =BOGUS(414);
+Module modulePrelude =BOGUS(415);
+
+#define QQ(lval) assert(lval != 0); assert(lval <= -900000); lval
+
+/* --------------------------------------------------------------------------
+ * Frequently used type skeletons:
+ * ------------------------------------------------------------------------*/
+
+/* ToDo: move these to link.c and call them 'typeXXXX' */
+ Type arrow=BOGUS(500); /* mkOffset(0) -> mkOffset(1) */
+ Type boundPair=BOGUS(500);; /* (mkOffset(0),mkOffset(0)) */
+ Type listof=BOGUS(500);; /* [ mkOffset(0) ] */
+ Type typeVarToVar=BOGUS(500);; /* mkOffset(0) -> mkOffset(0) */
+
+ Cell predNum=BOGUS(500);; /* Num (mkOffset(0)) */
+ Cell predFractional=BOGUS(500);; /* Fractional (mkOffset(0)) */
+ Cell predIntegral=BOGUS(500);; /* Integral (mkOffset(0)) */
+ Kind starToStar=BOGUS(500);; /* Type -> Type */
+ Cell predMonad=BOGUS(500);; /* Monad (mkOffset(0)) */
+
/* --------------------------------------------------------------------------
*
* ------------------------------------------------------------------------*/
static Tycon linkTycon ( String s );
static Tycon linkClass ( String s );
static Name linkName ( String s );
-static Void mkTypes ();
+static Void mkTypes ( void );
static Tycon linkTycon( String s )
return nm;
}
-Void linkPreludeTC() { /* Hook to tycons and classes in */
+Void linkPreludeTC(void) { /* Hook to tycons and classes in */
static Bool initialised = FALSE; /* prelude when first loaded */
if (!initialised) {
Int i;
initialised = TRUE;
- setCurrModule(modulePreludeHugs);
+ ////setCurrModule(modulePreludeHugs);
+ setCurrModule(modulePrelude);
- typeChar = linkTycon("Char");
- typeInt = linkTycon("Int");
+ QQ(typeChar ) = linkTycon("Char");
+ QQ(typeInt ) = linkTycon("Int");
#ifdef PROVIDE_INT64
- typeInt64 = linkTycon("Int64");
+ QQ(typeInt64 ) = linkTycon("Int64");
#endif
#ifdef PROVIDE_INTEGER
- typeInteger = linkTycon("Integer");
+ QQ(typeInteger ) = linkTycon("Integer");
#endif
#ifdef PROVIDE_WORD
- typeWord = linkTycon("Word");
+ QQ(typeWord ) = linkTycon("Word");
#endif
#ifdef PROVIDE_ADDR
- typeAddr = linkTycon("Addr");
+ QQ(typeAddr ) = linkTycon("Addr");
#endif
#ifdef PROVIDE_ARRAY
- typePrimArray = linkTycon("PrimArray");
- typePrimByteArray = linkTycon("PrimByteArray");
- typeRef = linkTycon("Ref");
- typePrimMutableArray = linkTycon("PrimMutableArray");
- typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
-#endif
- typeFloat = linkTycon("Float");
- typeDouble = linkTycon("Double");
+ QQ(typePrimArray ) = linkTycon("PrimArray");
+ QQ(typePrimByteArray) = linkTycon("PrimByteArray");
+ QQ(typeRef ) = linkTycon("Ref");
+ QQ(typePrimMutableArray) = linkTycon("PrimMutableArray");
+ QQ(typePrimMutableByteArray) = linkTycon("PrimMutableByteArray");
+#endif
+ QQ(typeFloat ) = linkTycon("Float");
+ QQ(typeDouble ) = linkTycon("Double");
#ifdef PROVIDE_STABLE
- typeStable = linkTycon("StablePtr");
+ QQ(typeStable ) = linkTycon("StablePtr");
#endif
#ifdef PROVIDE_WEAK
- typeWeak = linkTycon("Weak");
+ QQ(typeWeak ) = linkTycon("Weak");
#endif
#ifdef PROVIDE_FOREIGN
- typeForeign = linkTycon("ForeignObj");
+ QQ(typeForeign ) = linkTycon("ForeignObj");
#endif
#ifdef PROVIDE_CONCURRENT
- typeThreadId = linkTycon("ThreadId");
- typeMVar = linkTycon("MVar");
-#endif
-
- typeBool = linkTycon("Bool");
- typeST = linkTycon("ST");
- typeIO = linkTycon("IO");
- typeException = linkTycon("Exception");
- typeList = linkTycon("[]");
- typeUnit = linkTycon("()");
- typeString = linkTycon("String");
-
- classEq = linkClass("Eq");
- classOrd = linkClass("Ord");
- classIx = linkClass("Ix");
- classEnum = linkClass("Enum");
- classShow = linkClass("Show");
- classRead = linkClass("Read");
- classBounded = linkClass("Bounded");
+ QQ(typeThreadId ) = linkTycon("ThreadId");
+ QQ(typeMVar ) = linkTycon("MVar");
+#endif
+
+ QQ(typeBool ) = linkTycon("Bool");
+ QQ(typeST ) = linkTycon("ST");
+ QQ(typeIO ) = linkTycon("IO");
+ QQ(typeException ) = linkTycon("Exception");
+ //qqfail QQ(typeList ) = linkTycon("[]");
+ //qqfail QQ(typeUnit ) = linkTycon("()");
+ QQ(typeString ) = linkTycon("String");
+ QQ(typeOrdering ) = linkTycon("Ordering");
+
+ QQ(classEq ) = linkClass("Eq");
+ QQ(classOrd ) = linkClass("Ord");
+ QQ(classIx ) = linkClass("Ix");
+ QQ(classEnum ) = linkClass("Enum");
+ QQ(classShow ) = linkClass("Show");
+ QQ(classRead ) = linkClass("Read");
+ QQ(classBounded ) = linkClass("Bounded");
#if EVAL_INSTANCES
classEval = linkClass("Eval");
#endif
- classReal = linkClass("Real");
- classIntegral = linkClass("Integral");
- classRealFrac = linkClass("RealFrac");
- classRealFloat = linkClass("RealFloat");
- classFractional = linkClass("Fractional");
- classFloating = linkClass("Floating");
- classNum = linkClass("Num");
- classMonad = linkClass("Monad");
- /*classMonad0 = linkClass("MonadZero");*/
+ QQ(classReal ) = linkClass("Real");
+ QQ(classIntegral ) = linkClass("Integral");
+ QQ(classRealFrac ) = linkClass("RealFrac");
+ QQ(classRealFloat) = linkClass("RealFloat");
+ QQ(classFractional) = linkClass("Fractional");
+ QQ(classFloating ) = linkClass("Floating");
+ QQ(classNum ) = linkClass("Num");
+ QQ(classMonad ) = linkClass("Monad");
stdDefaults = NIL;
stdDefaults = cons(typeDouble,stdDefaults);
#endif
mkTypes();
- nameMkC = addPrimCfun(findText("C#"),1,0,CHAR_REP);
- nameMkI = addPrimCfun(findText("I#"),1,0,INT_REP);
+ QQ(nameMkC ) = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
+ QQ(nameMkI ) = addPrimCfunREP(findText("I#"),1,0,INT_REP);
#ifdef PROVIDE_INT64
- nameMkInt64 = addPrimCfun(findText("Int64#"),1,0,INT64_REP);
+ QQ(nameMkInt64 ) = addPrimCfunREP(findText("Int64#"),1,0,INT64_REP);
#endif
#ifdef PROVIDE_WORD
- nameMkW = addPrimCfun(findText("W#"),1,0,WORD_REP);
+ QQ(nameMkW ) = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
#endif
#ifdef PROVIDE_ADDR
- nameMkA = addPrimCfun(findText("A#"),1,0,ADDR_REP);
+ QQ(nameMkA ) = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
#endif
- nameMkF = addPrimCfun(findText("F#"),1,0,FLOAT_REP);
- nameMkD = addPrimCfun(findText("D#"),1,0,DOUBLE_REP);
+ QQ(nameMkF ) = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
+ QQ(nameMkD ) = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
#ifdef PROVIDE_STABLE
- nameMkStable = addPrimCfun(findText("Stable#"),1,0,STABLE_REP);
+ QQ(nameMkStable ) = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
#endif
#ifdef PROVIDE_INTEGER
- nameMkInteger = addPrimCfun(findText("Integer#"),1,0,0);
+ QQ(nameMkInteger ) = addPrimCfunREP(findText("Integer#"),1,0,0);
#endif
#ifdef PROVIDE_FOREIGN
- nameMkForeign = addPrimCfun(findText("Foreign#"),1,0,0);
+ QQ(nameMkForeign ) = addPrimCfunREP(findText("Foreign#"),1,0,0);
#endif
#ifdef PROVIDE_WEAK
- nameMkWeak = addPrimCfun(findText("Weak#"),1,0,0);
+ QQ(nameMkWeak ) = addPrimCfunREP(findText("Weak#"),1,0,0);
#endif
#ifdef PROVIDE_ARRAY
- nameMkPrimArray = addPrimCfun(findText("PrimArray#"),1,0,0);
- nameMkPrimByteArray = addPrimCfun(findText("PrimByteArray#"),1,0,0);
- nameMkRef = addPrimCfun(findText("Ref#"),1,0,0);
- nameMkPrimMutableArray = addPrimCfun(findText("PrimMutableArray#"),1,0,0);
- nameMkPrimMutableByteArray = addPrimCfun(findText("PrimMutableByteArray#"),1,0,0);
+ QQ(nameMkPrimArray ) = addPrimCfunREP(findText("PrimArray#"),1,0,0);
+ QQ(nameMkPrimByteArray ) = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
+ QQ(nameMkRef ) = addPrimCfunREP(findText("Ref#"),1,0,0);
+ QQ(nameMkPrimMutableArray ) = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
+ QQ(nameMkPrimMutableByteArray) = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
#endif
#ifdef PROVIDE_CONCURRENT
- nameMkThreadId = addPrimCfun(findText("ThreadId#"),1,0,0);
- nameMkMVar = addPrimCfun(findText("MVar#"),1,0,0);
+ QQ(nameMkThreadId) = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
+ QQ(nameMkMVar ) = addPrimCfun(findTextREP("MVar#"),1,0,0);
+#endif
+#if 1
+ /* The following primitives are referred to in derived instances and
+ * hence require types; the following types are a little more general
+ * than we might like, but they are the closest we can get without a
+ * special datatype class.
+ */
+ name(nameConCmp).type
+ = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
+ name(nameEnRange).type
+ = mkPolyType(starToStar,fn(boundPair,listof));
+ name(nameEnIndex).type
+ = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
+ name(nameEnInRng).type
+ = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
+ name(nameEnToEn).type
+ = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
+ name(nameEnFrEn).type
+ = mkPolyType(starToStar,fn(aVar,typeInt));
+ name(nameEnFrom).type
+ = mkPolyType(starToStar,fn(aVar,listof));
+ name(nameEnFrTo).type
+ = name(nameEnFrTh).type
+ = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
#endif
-
#if EVAL_INSTANCES
addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->) */
#endif
}
}
-static Void mkTypes()
+static Void mkTypes ( void )
{
- arrow = fn(aVar,mkOffset(1));
- listof = ap(typeList,aVar);
- predNum = ap(classNum,aVar);
- predFractional = ap(classFractional,aVar);
- predIntegral = ap(classIntegral,aVar);
- predMonad = ap(classMonad,aVar);
- /*predMonad0 = ap(classMonad0,aVar);*/
+ //qqfail QQ(arrow ) = fn(aVar,mkOffset(1));
+ //qqfail QQ(listof ) = ap(typeList,aVar);
+ QQ(predNum ) = ap(classNum,aVar);
+ QQ(predFractional) = ap(classFractional,aVar);
+ QQ(predIntegral ) = ap(classIntegral,aVar);
+ QQ(predMonad ) = ap(classMonad,aVar);
}
-Void linkPreludeCM() { /* Hook to cfuns and mfuns in */
+Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
static Bool initialised = FALSE; /* prelude when first loaded */
if (!initialised) {
Int i;
initialised = TRUE;
- setCurrModule(modulePreludeHugs);
+ ////setCurrModule(modulePreludeHugs);
+ setCurrModule(modulePrelude);
/* constructors */
- nameFalse = linkName("False");
- nameTrue = linkName("True");
- nameNil = linkName("[]");
- nameCons = linkName(":");
- nameUnit = linkName("()");
+ QQ(nameFalse ) = linkName("False");
+ QQ(nameTrue ) = linkName("True");
+ //qqfail QQ(nameNil ) = linkName("[]");
+ //qqfail QQ(nameCons ) = linkName(":");
+ //qqfail QQ(nameUnit ) = linkName("()");
/* members */
- nameEq = linkName("==");
- nameFromInt = linkName("fromInt");
- nameFromInteger = linkName("fromInteger");
- nameFromDouble = linkName("fromDouble");
+ QQ(nameEq ) = linkName("==");
+ QQ(nameFromInt ) = linkName("fromInt");
+ QQ(nameFromInteger) = linkName("fromInteger");
+ QQ(nameFromDouble) = linkName("fromDouble");
#if EVAL_INSTANCES
nameStrict = linkName("strict");
nameSeq = linkName("seq");
#endif
- nameReturn = linkName("return");
- nameBind = linkName(">>=");
- nameZero = linkName("zero");
-
+ QQ(nameReturn ) = linkName("return");
+ QQ(nameBind ) = linkName(">>=");
+
+ QQ(nameLe ) = linkName("<=");
+ QQ(nameGt ) = linkName(">");
+ QQ(nameShowsPrec ) = linkName("showsPrec");
+ QQ(nameReadsPrec ) = linkName("readsPrec");
+ QQ(nameEQ ) = linkName("EQ");
+ QQ(nameCompare ) = linkName("compare");
+ QQ(nameMinBnd ) = linkName("minBound");
+ QQ(nameMaxBnd ) = linkName("maxBound");
+ QQ(nameRange ) = linkName("range");
+ QQ(nameIndex ) = linkName("index");
+ QQ(namePlus ) = linkName("+");
+ QQ(nameMult ) = linkName("*");
+ QQ(nameRangeSize ) = linkName("rangeSize");
+ QQ(nameInRange ) = linkName("inRange");
/* These come before calls to implementPrim */
for(i=0; i<NUM_TUPLES; ++i) {
implementTuple(i);
}
}
-Void linkPreludeNames() { /* Hook to names defined in Prelude */
+Void linkPreludeNames(void) { /* Hook to names defined in Prelude */
static Bool initialised = FALSE;
if (!initialised) {
Int i;
initialised = TRUE;
- setCurrModule(modulePreludeHugs);
+
+ setCurrModule(modulePrelude);
/* primops */
- nameMkIO = linkName("primMkIO");
+ QQ(nameMkIO) = linkName("primMkIO");
for (i=0; asmPrimOps[i].name; ++i) {
Text t = findText(asmPrimOps[i].name);
Name n = findName(t);
implementPrim(n);
}
+ /* hooks for handwritten bytecode */
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Text t = findText("primSeq");
+ Name n = newName(t,NIL);
+ name(n).line = name(n).defn = 0;
+ name(n).arity = 1;
+ name(n).type = primType(MONAD_Id, "ab", "b");
+ vv = mkStgVar(NIL,NIL);
+ stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
+
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Text t = findText("primCatch");
+ Name n = newName(t,NIL);
+ name(n).line = name(n).defn = 0;
+ name(n).arity = 2;
+ name(n).type = primType(MONAD_Id, "aH", "a");
+ stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
+
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Text t = findText("primRaise");
+ Name n = newName(t,NIL);
+ name(n).line = name(n).defn = 0;
+ name(n).arity = 1;
+ name(n).type = primType(MONAD_Id, "E", "a");
+ stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
+
+ /* static(tidyInfix) */
+ QQ(nameNegate ) = linkName("negate");
/* user interface */
- nameRunIO = linkName("primRunIO");
- namePrint = linkName("print");
+ QQ(nameRunIO ) = linkName("primRunIO");
+ QQ(namePrint ) = linkName("print");
/* typechecker (undefined member functions) */
- nameError = linkName("error");
+ //qqfail QQ(nameError ) = linkName("error");
/* desugar */
- nameId = linkName("id");
- nameOtherwise = linkName("otherwise");
- nameUndefined = linkName("undefined");
+ //qqfail QQ(nameId ) = linkName("id");
+ QQ(nameOtherwise ) = linkName("otherwise");
+ QQ(nameUndefined ) = linkName("undefined");
/* pmc */
#if NPLUSK
namePmSub = linkName("primPmSub");
#endif
/* translator */
- nameUnpackString = linkName("primUnpackString");
- namePMFail = linkName("primPmFail");
- nameEqChar = linkName("primEqChar");
- nameEqInt = linkName("primEqInt");
+ ////nameUnpackString = linkName("primUnpackString");
+ ////namePMFail = linkName("primPmFail");
+ QQ(nameEqChar ) = linkName("primEqChar");
+ QQ(nameEqInt ) = linkName("primEqInt");
#if !OVERLOADED_CONSTANTS
- nameEqInteger = linkName("primEqInteger");
+ QQ(nameEqInteger ) = linkName("primEqInteger");
#endif /* !OVERLOADED_CONSTANTS */
- nameEqDouble = linkName("primEqDouble");
- namePmInt = linkName("primPmInt");
- namePmInteger = linkName("primPmInteger");
- namePmDouble = linkName("primPmDouble");
- namePmLe = linkName("primPmLe");
- namePmSubtract = linkName("primPmSubtract");
- namePmFromInteger = linkName("primPmFromInteger");
+ QQ(nameEqDouble ) = linkName("primEqDouble");
+ QQ(namePmInt ) = linkName("primPmInt");
+ ////namePmInteger = linkName("primPmInteger");
+ ////namePmDouble = linkName("primPmDouble");
+ ////namePmLe = linkName("primPmLe");
+ ////namePmSubtract = linkName("primPmSubtract");
+ ////namePmFromInteger = linkName("primPmFromInteger");
}
}
+
+/* ToDo: fix pFun (or eliminate its use) */
+#define pFun(n,s) QQ(n) = predefinePrim(s)
+
Void linkControl(what)
Int what; {
- Int i;
-
switch (what) {
case RESET :
case MARK :
case INSTALL : linkControl(RESET);
- modulePreludeHugs = newModule(findText("PreludeBuiltin"));
-
- setCurrModule(modulePreludeHugs);
+ modulePrelude = newModule(textPrelude);
+ setCurrModule(modulePrelude);
typeArrow = addPrimTycon(findText("(->)"),
pair(STAR,pair(STAR,STAR)),
2,DATATYPE,NIL);
- /* ToDo: fix pFun (or eliminate its use) */
-#define pFun(n,s,t) n = predefinePrim(s)
/* newtype and USE_NEWTYPE_FOR_DICTS */
- pFun(nameId, "id", "id");
+ pFun(nameId, "id");
+
/* desugaring */
- pFun(nameInd, "_indirect","error");
+ pFun(nameInd, "_indirect");
name(nameInd).number = DFUNNAME;
+
/* pmc */
- pFun(nameSel, "_SEL", "sel");
+ pFun(nameSel, "_SEL");
+
/* strict constructors */
- pFun(nameForce, "primForce","id");
+ pFun(nameFlip, "flip" );
+
+ /* parser */
+ pFun(nameFromTo, "enumFromTo");
+ pFun(nameFromThenTo, "enumFromThenTo");
+ pFun(nameFrom, "enumFrom");
+ pFun(nameFromThen, "enumFromThen");
+
+ /* deriving */
+ pFun(nameApp, "++");
+ pFun(nameReadParen, "readParen");
+ pFun(nameShowParen, "showParen");
+ pFun(nameLex, "lex");
+ pFun(nameEnToEn, "toEnumPR"); //not sure
+ pFun(nameEnFrEn, "fromEnum"); //not sure
+ pFun(nameEnFrom, "enumFrom"); //not sure
+ pFun(nameEnFrTh, "enumFromThen"); //not sure
+ pFun(nameEnFrTo, "enumFromTo"); //not sure
+ pFun(nameEnRange, "range"); //not sure
+ pFun(nameEnIndex, "index"); //not sure
+ pFun(nameEnInRng, "inRange"); //not sure
+ pFun(nameConCmp, "_concmp"); //very not sure
+ pFun(nameComp, ".");
+ pFun(nameAnd, "&&");
+ pFun(nameCompAux, "primCompAux");
+
/* implementTagToCon */
- pFun(namePMFail, "primPmFail","primPmFail");
- pFun(nameError, "error","error");
- pFun(nameUnpackString, "primUnpackString", "primUnpackString");
-#undef pFun
+ pFun(namePMFail, "primPmFail");
+ pFun(nameError, "error");
+ pFun(nameUnpackString, "primUnpackString");
break;
}
}
-
-/*-------------------------------------------------------------------------*/
+#undef pFun
-#if 0
---## this stuff from 98
---##
---##
---## Void linkPreludeTC() { /* Hook to tycons and classes in */
---## if (isNull(typeBool)) { /* prelude when first loaded */
---## Int i;
---##
---## typeBool = findTycon(findText("Bool"));
---## typeChar = findTycon(findText("Char"));
---## typeString = findTycon(findText("String"));
---## typeInt = findTycon(findText("Int"));
---## typeInteger = findTycon(findText("Integer"));
---## typeDouble = findTycon(findText("Double"));
---## typeAddr = findTycon(findText("Addr"));
---## typeMaybe = findTycon(findText("Maybe"));
---## typeOrdering = findTycon(findText("Ordering"));
---## if (isNull(typeBool) || isNull(typeChar) || isNull(typeString) ||
---## isNull(typeInt) || isNull(typeDouble) || isNull(typeInteger) ||
---## isNull(typeAddr) || isNull(typeMaybe) || isNull(typeOrdering)) {
---## ERRMSG(0) "Prelude does not define standard types"
---## EEND;
---## }
---## stdDefaults = cons(typeInteger,cons(typeDouble,NIL));
---##
---## classEq = findClass(findText("Eq"));
---## classOrd = findClass(findText("Ord"));
---## classIx = findClass(findText("Ix"));
---## classEnum = findClass(findText("Enum"));
---## classShow = findClass(findText("Show"));
---## classRead = findClass(findText("Read"));
---## #if EVAL_INSTANCES
---## classEval = findClass(findText("Eval"));
---## #endif
---## classBounded = findClass(findText("Bounded"));
---## if (isNull(classEq) || isNull(classOrd) || isNull(classRead) ||
---## isNull(classShow) || isNull(classIx) || isNull(classEnum) ||
---## #if EVAL_INSTANCES
---## isNull(classEval) ||
---## #endif
---## isNull(classBounded)) {
---## ERRMSG(0) "Prelude does not define standard classes"
---## EEND;
---## }
---##
---## classReal = findClass(findText("Real"));
---## classIntegral = findClass(findText("Integral"));
---## classRealFrac = findClass(findText("RealFrac"));
---## classRealFloat = findClass(findText("RealFloat"));
---## classFractional = findClass(findText("Fractional"));
---## classFloating = findClass(findText("Floating"));
---## classNum = findClass(findText("Num"));
---## if (isNull(classReal) || isNull(classIntegral) ||
---## isNull(classRealFrac) || isNull(classRealFloat) ||
---## isNull(classFractional) || isNull(classFloating) ||
---## isNull(classNum)) {
---## ERRMSG(0) "Prelude does not define numeric classes"
---## EEND;
---## }
---## predNum = ap(classNum,aVar);
---## predFractional = ap(classFractional,aVar);
---## predIntegral = ap(classIntegral,aVar);
---##
---## classMonad = findClass(findText("Monad"));
---## if (isNull(classMonad)) {
---## ERRMSG(0) "Prelude does not define Monad class"
---## EEND;
---## }
---## predMonad = ap(classMonad,aVar);
---##
---## #if IO_MONAD
---## { Type typeIO = findTycon(findText("IO"));
---## if (isNull(typeIO)) {
---## ERRMSG(0) "Prelude does not define IO monad constructor"
---## EEND;
---## }
---## typeProgIO = ap(typeIO,aVar);
---## }
---## #endif
---##
---## /* The following primitives are referred to in derived instances and
---## * hence require types; the following types are a little more general
---## * than we might like, but they are the closest we can get without a
---## * special datatype class.
---## */
---## name(nameConCmp).type
---## = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
---## name(nameEnRange).type
---## = mkPolyType(starToStar,fn(boundPair,listof));
---## name(nameEnIndex).type
---## = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
---## name(nameEnInRng).type
---## = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
---## name(nameEnToEn).type
---## = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
---## name(nameEnFrEn).type
---## = mkPolyType(starToStar,fn(aVar,typeInt));
---## name(nameEnFrom).type
---## = mkPolyType(starToStar,fn(aVar,listof));
---## name(nameEnFrTo).type
---## = name(nameEnFrTh).type
---## = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
---##
---## #if EVAL_INSTANCES
---## addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for builtins */
---## addEvalInst(0,typeList,1,NIL);
---## addEvalInst(0,typeUnit,0,NIL);
---## #endif
---## for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
---## #if EVAL_INSTANCES
---## addEvalInst(0,mkTuple(i),i,NIL);
---## #endif
---## addTupInst(classEq,i);
---## addTupInst(classOrd,i);
---## addTupInst(classShow,i);
---## addTupInst(classRead,i);
---## addTupInst(classIx,i);
---## }
---## }
---## }
---##
---##
---## static Void linkPreludeCM() { /* Hook to cfuns and mfuns in */
---## if (isNull(nameFalse)) { /* prelude when first loaded */
---## nameFalse = findName(findText("False"));
---## nameTrue = findName(findText("True"));
---## nameJust = findName(findText("Just"));
---## nameNothing = findName(findText("Nothing"));
---## nameLeft = findName(findText("Left"));
---## nameRight = findName(findText("Right"));
---## nameLT = findName(findText("LT"));
---## nameEQ = findName(findText("EQ"));
---## nameGT = findName(findText("GT"));
---## if (isNull(nameFalse) || isNull(nameTrue) ||
---## isNull(nameJust) || isNull(nameNothing) ||
---## isNull(nameLeft) || isNull(nameRight) ||
---## isNull(nameLT) || isNull(nameEQ) || isNull(nameGT)) {
---## ERRMSG(0) "Prelude does not define standard constructors"
---## EEND;
---## }
---##
---## nameFromInt = findName(findText("fromInt"));
---## nameFromInteger = findName(findText("fromInteger"));
---## nameFromDouble = findName(findText("fromDouble"));
---## nameEq = findName(findText("=="));
---## nameCompare = findName(findText("compare"));
---## nameLe = findName(findText("<="));
---## nameGt = findName(findText(">"));
---## nameShowsPrec = findName(findText("showsPrec"));
---## nameReadsPrec = findName(findText("readsPrec"));
---## nameIndex = findName(findText("index"));
---## nameInRange = findName(findText("inRange"));
---## nameRange = findName(findText("range"));
---## nameMult = findName(findText("*"));
---## namePlus = findName(findText("+"));
---## nameMinBnd = findName(findText("minBound"));
---## nameMaxBnd = findName(findText("maxBound"));
---## #if EVAL_INSTANCES
---## nameStrict = findName(findText("strict"));
---## nameSeq = findName(findText("seq"));
---## #endif
---## nameReturn = findName(findText("return"));
---## nameBind = findName(findText(">>="));
---## nameMFail = findName(findText("fail"));
---## if (isNull(nameFromInt) || isNull(nameFromDouble) ||
---## isNull(nameEq) || isNull(nameCompare) ||
---## isNull(nameLe) || isNull(nameGt) ||
---## isNull(nameShowsPrec) || isNull(nameReadsPrec) ||
---## isNull(nameIndex) || isNull(nameInRange) ||
---## isNull(nameRange) || isNull(nameMult) ||
---## isNull(namePlus) || isNull(nameFromInteger) ||
---## isNull(nameMinBnd) || isNull(nameMaxBnd) ||
---## #if EVAL_INSTANCES
---## isNull(nameStrict) || isNull(nameSeq) ||
---## #endif
---## isNull(nameReturn) || isNull(nameBind) ||
---## isNull(nameMFail)) {
---## ERRMSG(0) "Prelude does not define standard members"
---## EEND;
---## }
---## }
---## }
---##
-#endif
+/*-------------------------------------------------------------------------*/
extern Type typeAddr;
#endif
#ifdef PROVIDE_ARRAY
-Type typePrimArray;
-Type typePrimByteArray;
-Type typeRef;
-Type typePrimMutableArray;
-Type typePrimMutableByteArray;
+extern Type typePrimArray;
+extern Type typePrimByteArray;
+extern Type typeRef;
+extern Type typePrimMutableArray;
+extern Type typePrimMutableByteArray;
#endif
extern Type typeFloat;
extern Type typeDouble;
extern Cell predIntegral; /* Integral (mkOffset(0)) */
extern Cell predMonad; /* Monad (mkOffset(0)) */
+
+extern Type arrow; /* mkOffset(0) -> mkOffset(1) */
+extern Type boundPair;; /* (mkOffset(0),mkOffset(0)) */
+extern Type listof;; /* [ mkOffset(0) ] */
+extern Type typeVarToVar;; /* mkOffset(0) -> mkOffset(0) */
+
+extern Cell predNum;; /* Num (mkOffset(0)) */
+extern Cell predFractional;; /* Fractional (mkOffset(0)) */
+extern Cell predIntegral;; /* Integral (mkOffset(0)) */
+extern Kind starToStar;; /* Type -> Type */
+extern Cell predMonad;; /* Monad (mkOffset(0)) */
* in the distribution for details.
*
* $RCSfile: machdep.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:32 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:49 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
#if HSCRIPT
static String local hscriptDir Args((Void));
#endif
-static String local RealPath Args((String));
+//static String local RealPath Args((String));
static int local pathCmp Args((String, String));
static String local normPath Args((String));
static Void local searchChr Args((Int));
}
#endif
-
+#if 0 /* apparently unused */
static String local RealPath(s) /* Find absolute pathname of file */
String s; {
#if HAVE__FULLPATH /* eg DOS */
#endif
return path;
}
+#endif
+
static int local pathCmp(p1,p2) /* Compare paths after normalisation */
String p1;
--- /dev/null
+
+/* This is a hack. I totally deny writing it. If this code breaks,
+ * you get to keep all the pieces. JRS, 23 feb 99.
+ */
+
+#include <stdio.h>
+#include <errno.h>
+#include <assert.h>
+#include <malloc.h>
+
+int nh_stdin ( void )
+{
+ errno = 0;
+ return (int)stdin;
+}
+
+int nh_stdout ( void )
+{
+ errno = 0;
+ return (int)stdout;
+}
+
+int nh_open ( char* fname, int wr )
+{
+ FILE* f;
+ errno = 0;
+ f = fopen ( fname, (wr==0) ? "r": ((wr==1) ? "w" : "a") );
+ return (int)f;
+}
+
+void nh_close ( FILE* f )
+{
+ errno = 0;
+ fflush ( f );
+ fclose ( f );
+}
+
+void nh_write ( FILE* f, int c )
+{
+ errno = 0;
+ fputc(c,f);
+ fflush(f);
+}
+
+int nh_read ( FILE* f )
+{
+ errno = 0;
+ return fgetc(f);
+}
+
+int nh_errno ( void )
+{
+ return errno;
+}
+
+int nh_malloc ( int n )
+{
+ char* p = malloc(n);
+ assert(p);
+ return (int)p;
+}
+
+void nh_free ( int n )
+{
+ free ( (char*)n );
+}
+
+void nh_assign ( int p, int offset, int ch )
+{
+ ((char*)p)[offset] = (char)ch;
+}
* in the distribution for details.
*
* $RCSfile: output.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:33 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:50 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "errors.h"
#include <ctype.h>
-/*#define DEBUG_SHOWSC*/ /* Must also be set in compiler.c */
-
#define DEPTH_LIMIT 15
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
-static Void local putChr Args((Int));
-static Void local putStr Args((String));
-static Void local putInt Args((Int));
-
static Void local put Args((Int,Cell));
static Void local putFlds Args((Cell,List));
static Void local putComp Args((Cell,List));
static Void local putSimpleAp Args((Cell,Int));
static Void local putTuple Args((Int,Cell));
static Int local unusedTups Args((Int,Cell));
-static Void local unlexVar Args((Text));
static Void local unlexOp Args((Text));
-static Void local unlexCharConst Args((Cell));
-static Void local unlexStrConst Args((Text));
static Void local putSigType Args((Cell));
static Void local putContext Args((List,List,Int));
* Basic output routines:
* ------------------------------------------------------------------------*/
-static FILE *outputStream; /* current output stream */
-#ifdef DEBUG_SHOWSC
-static Int outColumn = 0; /* current output column number */
-#endif
+FILE *outputStream; /* current output stream */
+Int outColumn = 0; /* current output column number */
#define OPEN(b) if (b) putChr('(');
#define CLOSE(b) if (b) putChr(')');
-static Void local putChr(c) /* print single character */
+Void putChr(c) /* print single character */
Int c; {
Putc(c,outputStream);
-#ifdef DEBUG_SHOWSC
outColumn++;
-#endif
}
-static Void local putStr(s) /* print string */
+Void putStr(s) /* print string */
String s; {
for (; *s; s++) {
Putc(*s,outputStream);
-#ifdef DEBUG_SHOWSC
outColumn++;
-#endif
}
}
-static Void local putInt(n) /* print integer */
+Void putInt(n) /* print integer */
Int n; {
static char intBuf[16];
sprintf(intBuf,"%d",n);
putStr(intBuf);
}
+Void putPtr(p) /* print pointer */
+Ptr p; {
+ static char intBuf[16];
+ sprintf(intBuf,"%p",p);
+ putStr(intBuf);
+}
+
/* --------------------------------------------------------------------------
* Precedence values (See Haskell 1.3 report, p.12):
* ------------------------------------------------------------------------*/
return ts;
}
-static Void local unlexVar(t) /* print text as a variable name */
+Void unlexVar(t) /* print text as a variable name */
Text t; { /* operator symbols must be enclosed*/
String s = textToStr(t); /* in parentheses... except [] ... */
- if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
+ if ((isascii((int)(s[0])) && isalpha((int)(s[0])))
+ || s[0]=='_' || s[0]=='[' || s[0]=='(')
putStr(s);
else {
putChr('(');
Text t; { /* alpha numeric symbols must be */
String s = textToStr(t); /* enclosed by backquotes */
- if (isascii(s[0]) && isalpha(s[0])) {
+ if (isascii((int)(s[0])) && isalpha((int)(s[0]))) {
putChr('`');
putStr(s);
putChr('`');
putStr(s);
}
-static Void local unlexCharConst(c)
+Void unlexCharConst(c)
Cell c; {
putChr('\'');
putStr(unlexChar(c,'\''));
putChr('\'');
}
-static Void local unlexStrConst(t)
+Void unlexStrConst(t)
Text t; {
String s = textToStr(t);
static Char SO = 14; /* ASCII code for '\SO' */
Char c = ' ';
if ((lastWasSO && *ch=='H') ||
- (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
+ (lastWasEsc && lastWasDigit
+ && isascii((int)(*ch)) && isdigit((int)(*ch))))
putStr("\\&");
lastWasEsc = (*ch=='\\');
* in the distribution for details.
*
* $RCSfile: preds.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:35 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:50 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
return TRUE;
}
deRef(tyv,t,o);
- if (tyv)
+ if (tyv) {
if (tyv->offs == FIXED_TYVAR) {
numFixedVars++;
return FALSE;
}
else
return TRUE;
+ }
else
return FALSE;
}
* in the distribution for details.
*
* $RCSfile: static.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:37 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:51 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
#include "backend.h"
#include "connect.h"
+#include "link.h"
#include "errors.h"
#include "subst.h"
static Type local depTypeExp Args((Int,List,Type));
static Type local depTypeVar Args((Int,List,Text));
static List local checkQuantVars Args((Int,List,List,Cell));
-static List local offsetTyvarsIn Args((Type,List));
static Void local kindConstr Args((Int,Int,Int,Constr));
static Kind local kindAtom Args((Int,Constr));
static Void local kindPred Args((Int,Int,Int,Cell));
static Void local tidyDerInst Args((Inst));
static Void local addDerivImp Args((Inst));
-static List local getDiVars Args((Int));
-static Cell local mkBind Args((String,List));
-static Cell local mkVarAlts Args((Int,Cell));
-
-static List local makeDPats2 Args((Cell,Int));
-
-static Bool local isEnumType Args((Tycon));
static Void local checkDefaultDefns Args((Void));
static Void local checkForeignImport Args((Name));
static Void local checkForeignExport Args((Name));
-static Name local addNewPrim Args((Int,Text,String,Cell));
-
static Cell local tidyInfix Args((Int,Cell));
static Pair local attachFixity Args((Int,Cell));
static Syntax local lookupSyntax Args((Text));
return a;
}
-static List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
- /* - used for deriving Show */
static List local addSels(line,c,fs,ss) /* Add fields to selector list */
Int line; /* line number of constructor */
List ns = NIL; /* List of names */
Int mno; /* Member function number */
+//printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) );
for (mno=0; mno<cclass(c).numSupers; mno++) {
ns = cons(newDSel(c,mno),ns);
}
mno = cclass(c).numSupers + cclass(c).numMembers;
cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL);
+ implementCfun(cclass(c).dcon,NIL); /* ADR addition */
+
if (mno==1) { /* Single entry dicts use newtype */
name(cclass(c).dcon).defn = nameId;
name(hd(cclass(c).members)).number = mfunNo(0);
name(m).arity = 1;
name(m).number = mfunNo(no);
name(m).type = t;
+//printf ( " [%d %d] %s :: ", m, m-NAMEMIN, textToStr ( name(m).text ) );
+//printType(stdout, t );
+//printf ( "\n" );
return m;
}
* A type Preds => type is ambiguous if not (TV(P) `subset` TV(type))
* ------------------------------------------------------------------------*/
-static List local offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
+List offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
Type t; /* to list vs */
List vs; {
switch (whatIs(t)) {
extractBindings(inst(in).implements));
inst(in).builder = newInstImp(in);
/*ToDo*/
-fprintf(stderr, "\npreludeLoaded query\n" );
+ //fprintf(stderr, "\npreludeLoaded query\n" );
if (/*!preludeLoaded &&*/ isNull(nameListMonad) && isAp(inst(in).head)
&& fun(inst(in).head)==classMonad && arg(inst(in).head)==typeList) {
nameListMonad = inst(in).builder;
Int i = 0;
setGoal("Dependency analysis",(Target)(length(bs)));
+
mapProc(addDepField,bs); /* add extra field for dependents */
for (xs=bs; nonNull(xs); xs=tl(xs)) {
+
+ //Printf("\n-----------------------------------------\n" ); print(hd(xs),1000); Printf("\n");
+
emptySubstitution();
depBinding(hd(xs));
soFar((Target)(i++));
List bs; { /* bindings, possibly containing */
for (; nonNull(bs); bs=tl(bs)) { /* NIL bindings ... */
if (nonNull(hd(bs))) { /* No need to add extra field for */
+
+ //Printf("\n=========================================\n" ); print(hd(bs),1000); Printf("\n");
+
mapProc(depAlt,snd(hd(bs)));/* dependency information... */
}
}
static Cell local depExpr(line,e) /* find dependents of expression */
Int line;
Cell e; {
+ // Printf( "\n\n"); print(e,100); Printf("\n");
+ //printExp(stdout,e);
switch (whatIs(e)) {
case VARIDCELL :
EEND;
#endif
- default : internal("depExpr");
+ default : fprintf(stderr,"whatIs(e) == %d\n",whatIs(e));internal("depExpr");
}
return e;
}
#endif
mapProc(allNoPrevDef,valDefns); /* check against previous defns */
+ linkPreludeNames();
+
mapProc(checkForeignImport,foreignImports); /* check foreign imports */
mapProc(checkForeignExport,foreignExports); /* check foreign exports */
foreignImports = NIL;
* Hugs version 1.4, December 1997
*
* $RCSfile: stg.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:39 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:53 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
return body;
} else {
if (whatIs(body) == LAMBDA) {
- return mkStgLambda(dupOnto(args,stgLambdaArgs(body)),
+ return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
stgLambdaBody(body));
} else {
return mkStgLambda(args,body);
Bool isStgVar(e)
StgRhs e; {
+ //printf("{%d %d %d} ", namePMFail, e, whatIs(e) );
switch (whatIs(e)) {
case STGVAR:
return TRUE;
* Hugs version 1.4, December 1997
*
* $RCSfile: stg.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:39 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:53 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* ------------------------------------------------------------------------*/
static Void local pIndent Args((Int));
-static Void local unlexVar Args((Text));
-static Void local unlexCharConst Args((Cell));
-static Void local unlexStrConst Args((Text));
static Void local putStgVar Args((StgVar));
static Void local putStgVars Args((List));
static Void local putStgPat Args((StgPat));
static Void local putStgPrimPat Args((StgPrimPat));
-/* --------------------------------------------------------------------------
- * Basic output routines:
- * ------------------------------------------------------------------------*/
-
-static FILE *outputStream; /* current output stream */
-static Int outColumn = 0; /* current output column number */
-
-static Void local putChr( Int c );
-static Void local putStr( String s );
-static Void local putInt( Int n );
-static Void local putPtr( Ptr p );
-
-static Void local putChr(c) /* print single character */
-Int c; {
- Putc(c,outputStream);
- outColumn++;
-}
-
-static Void local putStr(s) /* print string */
-String s; {
- for (; *s; s++) {
- Putc(*s,outputStream);
- outColumn++;
- }
-}
-
-static Void local putInt(n) /* print integer */
-Int n; {
- static char intBuf[16];
- sprintf(intBuf,"%d",n);
- putStr(intBuf);
-}
-
-static Void local putPtr(p) /* print pointer */
-Ptr p; {
- static char intBuf[16];
- sprintf(intBuf,"%p",p);
- putStr(intBuf);
-}
/* --------------------------------------------------------------------------
* Indentation and showing names/constants
}
}
-static Void local unlexVar(t) /* print text as a variable name */
-Text t; { /* operator symbols must be enclosed*/
- String s = textToStr(t); /* in parentheses... except [] ... */
-
- if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
- putStr(s);
- else {
- putChr('(');
- putStr(s);
- putChr(')');
- }
-}
-
-static Void local unlexCharConst(c)
-Cell c; {
- putChr('\'');
- putStr(unlexChar(c,'\''));
- putChr('\'');
-}
-
-static Void local unlexStrConst(t)
-Text t; {
- String s = textToStr(t);
- static Char SO = 14; /* ASCII code for '\SO' */
- Bool lastWasSO = FALSE;
- Bool lastWasDigit = FALSE;
- Bool lastWasEsc = FALSE;
-
- putChr('\"');
- for (; *s; s++) {
- String ch = unlexChar(*s,'\"');
- Char c = ' ';
-
- if ((lastWasSO && *ch=='H') ||
- (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
- putStr("\\&");
-
- lastWasEsc = (*ch=='\\');
- lastWasSO = (*s==SO);
- for (; *ch; c = *ch++)
- putChr(*ch);
- lastWasDigit = (isascii(c) && isdigit(c));
- }
- putChr('\"');
-}
/* --------------------------------------------------------------------------
* Pretty printer for stg code:
* ------------------------------------------------------------------------*/
static Void putStgAlts ( Int left, List alts );
-static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
+//static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
static Void local putStgVar(StgVar v)
{
static Void putStgAlts( Int left, List alts )
{
- if (length(alts) == 1) {
+ if (length(alts) == 1) {
StgCaseAlt alt = hd(alts);
putStr("{ ");
putStgPat(stgCaseAltPat(alt));
StgCaseAlt alt = hd(alts);
pIndent(left+2);
putStgPat(stgCaseAltPat(alt));
- putStr(" -> ");
+
+ //putStr(" -> ");
+ putStr(" ->\n");
+ pIndent(left+4);
+
putStgExpr(stgCaseAltBody(alt));
putStr("\n");
}
putStgVar(e);
break;
default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
- internal("putStgExpr");
+ //fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ //internal("putStgExpr");
+ //ToDo: rm this appalling hack
+ fprintf(stderr, " "); putStgAlts(3,e);
}
}
static void beginStgPP( FILE* fp )
{
outputStream = fp;
- putChr('\n');
+ //putChr('\n');
outColumn = 0;
}
endStgPP(fp);
}
-#if DEBUG_PRINTER
+#if 1 /*DEBUG_PRINTER*/
Void ppStg( StgVar v )
{
- if (debugCode) {
+ if ( 1 /*debugCode*/ ) {
printStg(stdout,v);
}
}
Void ppStgExpr( StgExpr e )
{
- if (debugCode) {
- beginStgPP(stdout);
+ if ( 1 /*debugCode*/ ) {
+ beginStgPP(stderr);
putStgExpr(e);
endStgPP(stdout);
}
Void ppStgRhs( StgRhs rhs )
{
- if (debugCode) {
+ if (1 /*debugCode*/ ) {
beginStgPP(stdout);
putStgRhs(rhs);
endStgPP(stdout);
* in the distribution for details.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:40 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:54 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#if !IGNORE_MODULES
static Module local findQualifier Args((Text));
#endif
-static Void local hashTycon Args((Tycon));
static List local insertTycon Args((Tycon,List));
-static Void local hashName Args((Name));
static List local insertName Args((Name,List));
static Void local patternError Args((String));
static Bool local stringMatch Args((String,String));
static Bool local typeInvolves Args((Type,Type));
static Cell local markCell Args((Cell));
static Void local markSnd Args((Cell));
-static Cell local indirectChain Args((Cell));
-static Bool local isMarked Args((Cell));
static Cell local lowLevelLastIn Args((Cell));
static Cell local lowLevelLastOut Args((Cell));
/* from STG */
* the most recent entry at the front of the list.
* ------------------------------------------------------------------------*/
-#define TYCONHSZ 256 /* Size of Tycon hash table*/
-#define tHash(x) ((x)%TYCONHSZ) /* Tycon hash function */
-static Tycon tyconHw; /* next unused Tycon */
-static Tycon DEFTABLE(tyconHash,TYCONHSZ); /* Hash table storage */
+ Tycon tyconHw; /* next unused Tycon */
struct strTycon DEFTABLE(tabTycon,NUM_TYCON); /* Tycon storage */
Tycon newTycon(t) /* add new tycon to tycon table */
Text t; {
- Int h = tHash(t);
-
if (tyconHw-TYCMIN >= NUM_TYCON) {
ERRMSG(0) "Type constructor storage space exhausted"
EEND;
tycon(tyconHw).kind = NIL;
tycon(tyconHw).defn = NIL;
tycon(tyconHw).what = NIL;
+ tycon(tyconHw).conToTag = NIL;
+ tycon(tyconHw).tagToCon = NIL;
#if !IGNORE_MODULES
tycon(tyconHw).mod = currentModule;
module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
#endif
- tycon(tyconHw).nextTyconHash = tyconHash[h];
- tyconHash[h] = tyconHw;
-
return tyconHw++;
}
-Tycon findTycon(t) /* locate Tycon in tycon table */
-Text t; {
- Tycon tc = tyconHash[tHash(t)];
-
- while (nonNull(tc) && tycon(tc).text!=t)
- tc = tycon(tc).nextTyconHash;
- return tc;
+Tycon findTycon ( Text t )
+{
+ int n;
+ for (n = TYCMIN; n < tyconHw; n++)
+ if (tycon(n).text == t) return n;
+ return NIL;
}
Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */
Tycon tc; {
Tycon oldtc = findTycon(tycon(tc).text);
if (isNull(oldtc)) {
- hashTycon(tc);
+ // hashTycon(tc);
#if !IGNORE_MODULES
module(currentModule).tycons=cons(tc,module(currentModule).tycons);
#endif
return oldtc;
}
-static Void local hashTycon(tc) /* Insert Tycon into hash table */
-Tycon tc; {
- Text t = tycon(tc).text;
- Int h = tHash(t);
- tycon(tc).nextTyconHash = tyconHash[h];
- tyconHash[h] = tc;
-}
-
Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
Cell id; {
if (!isPair(id)) internal("findQualTycon");
#define NAMEHSZ 256 /* Size of Name hash table */
#define nHash(x) ((x)%NAMEHSZ) /* hash fn :: Text->Int */
-static Name nameHw; /* next unused name */
+ Name nameHw; /* next unused name */
static Name DEFTABLE(nameHash,NAMEHSZ); /* Hash table storage */
struct strName DEFTABLE(tabName,NUM_NAME); /* Name table storage */
Name newName(t,parent) /* Add new name to name table */
Text t;
Cell parent; {
- Int h = nHash(t);
+ //Int h = nHash(t);
if (nameHw-NAMEMIN >= NUM_NAME) {
ERRMSG(0) "Name storage space exhausted"
name(nameHw).type = NIL;
name(nameHw).primop = 0;
name(nameHw).mod = currentModule;
- hashName(nameHw);
module(currentModule).names=cons(nameHw,module(currentModule).names);
- name(nameHw).nextNameHash = nameHash[h];
- nameHash[h] = nameHw;
return nameHw++;
}
-Name findName(t) /* Locate name in name table */
-Text t; {
- Name n = nameHash[nHash(t)];
-
- while (nonNull(n) && name(n).text!=t) {
- n = name(n).nextNameHash;
- }
- assert(isNull(n) || (isName(n) && n < nameHw));
- return n;
+Name findName ( Text t )
+{
+ int n;
+ for (n = NAMEMIN; n < nameHw; n++)
+ if (name(n).text == t) return n;
+ return NIL;
}
+
+
Name addName(nm) /* Insert Name in name table - if */
Name nm; { /* no clash is caused */
Name oldnm = findName(name(nm).text);
if (isNull(oldnm)) {
- hashName(nm);
+ // hashName(nm);
#if !IGNORE_MODULES
module(currentModule).names=cons(nm,module(currentModule).names);
#endif
return oldnm;
}
-static Void local hashName(nm) /* Insert Name into hash table */
-Name nm; {
- Text t = name(nm).text;
- Int h = nHash(t);
- name(nm).nextNameHash = nameHash[h];
- nameHash[h] = nm;
-}
-
Name findQualName(id) /* Locate (possibly qualified) name*/
Cell id; { /* in name table */
if (!isPair(id))
* Primitive functions:
* ------------------------------------------------------------------------*/
-Name addPrimCfun(t,arity,no,rep) /* add primitive constructor func */
-Text t;
+Name addPrimCfunREP(t,arity,no,rep) /* add primitive constructor func */
+Text t; /* sets rep, not type */
Int arity;
Int no;
Int rep; { /* Really AsmRep */
return n;
}
+
+Name addPrimCfun(t,arity,no,type) /* add primitive constructor func */
+Text t;
+Int arity;
+Int no;
+Cell type; {
+ Name n = newName(t,NIL);
+ name(n).arity = arity;
+ name(n).number = cfunNo(no);
+ name(n).type = type;
+ return n;
+}
+
+
Int sfunPos(s,c) /* Find position of field with */
Name s; /* selector s in constructor c. */
Name c; {
for (cs=classes; nonNull(cs); cs=tl(cs)) {
cl=hd(cs);
if (cclass(cl).text==t)
- return cl;
+ return cl;
}
return NIL;
}
static local Module findQualifier(t) /* locate Module in import list */
Text t; {
Module ms;
- if (t==module(modulePreludeHugs).text) {
+ ////if (t==module(modulePreludeHugs).text) {
+ if (t==module(modulePrelude).text) {
/* The Haskell report (rightly) forbids this.
* We added it to let the Prelude refer to itself
* without having to import itself.
*/
- return modulePreludeHugs;
+ ////return modulePreludeHugs;
+ return modulePrelude;
}
for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
if (textOf(fst(hd(ms)))==t)
Void setCurrModule(m) /* set lookup tables for current module */
Module m; {
- Int i;
+ //Int i;
if (m!=currentModule) {
currentModule = m; /* This is the only assignment to currentModule */
+#if 0
for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
mapProc(hashTycon,module(m).tycons);
for (i=0; i<NAMEHSZ; ++i)
nameHash[i] = NIL;
mapProc(hashName,module(m).names);
+#endif
classes = module(m).classes;
}
}
}
Bool isPreludeScript() { /* Test whether this is the Prelude*/
- return (scriptHw==0);
+ return (scriptHw==0
+ /*ToDo: jrs hack*/ || scriptHw==1
+ );
}
#if !IGNORE_MODULES
}
#else /* !IGNORE_MODULES */
currentModule=NIL;
+#if 0
for (i=0; i<TYCONHSZ; ++i) {
tyconHash[i] = NIL;
}
for (i=0; i<NAMEHSZ; ++i) {
nameHash[i] = NIL;
}
+#endif
#endif /* !IGNORE_MODULES */
for (i=CLASSMIN; i<classHw; i++) {
ma: t = c; /* Keep pointer to original pair */
c = snd(c);
-mb: if (!isPair(c))
+ if (!isPair(c))
return;
{ register int place = placeInSet(c);
register Int mask;
register Int place;
Int recovered;
+
jmp_buf regs; /* save registers on stack */
+printf("\n\n$$$$$$$$$$$ GARBAGE COLLECTION; aborting\n\n");
+exit(1);
setjmp(regs);
gcStarted();
static Cell local lowLevelLastIn(c) /* Duplicate expression tree (i.e. */
Cell c; { /* acyclic graph) for later recall */
- if (isPair(c)) /* Duplicating any text strings */
+ if (isPair(c)) { /* Duplicating any text strings */
if (isBoxTag(fst(c))) /* in case these are lost at some */
switch (fst(c)) { /* point before the expr is reused */
case VARIDCELL :
}
else
return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
+ }
#if TREX
else if (isExt(c))
return pair(EXTCOPY,saveText(extText(c)));
static Cell local lowLevelLastOut(c) /* As with lowLevelLastIn() above */
Cell c; { /* except that Cells refering to */
- if (isPair(c)) /* Text values are restored to */
+ if (isPair(c)) { /* Text values are restored to */
if (isBoxTag(fst(c))) /* appropriate values */
switch (fst(c)) {
case VARIDCELL :
}
else
return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
+ }
else
return c;
}
if (c<TUPMIN) return c;
if (c>=INTMIN) return INTCELL;
- if (c>=NAMEMIN) if (c>=CLASSMIN) if (c>=CHARMIN) return CHARCELL;
- else return CLASS;
+ if (c>=NAMEMIN){if (c>=CLASSMIN) {if (c>=CHARMIN) return CHARCELL;
+ else return CLASS;}
else if (c>=INSTMIN) return INSTANCE;
- else return NAME;
- else if (c>=MODMIN) if (c>=TYCMIN) return TYCON;
- else return MODULE;
+ else return NAME;}
+ else if (c>=MODMIN) {if (c>=TYCMIN) return TYCON;
+ else return MODULE;}
else if (c>=OFFMIN) return OFFSET;
#if TREX
else return (c>=EXTMIN) ?
return ys;
}
+List dupListOnto(xs,ys) /* Duplicate spine of list xs onto ys */
+List xs;
+List ys; {
+ return revOnto(dupOnto(xs,NIL),ys);
+}
+
List dupList(xs) /* Duplicate spine of list xs */
List xs; {
List ys = NIL;
#endif
tyconHw = TYCMIN;
+#if 0
for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
-
+#endif
#if GC_WEAKPTRS
finalizers = NIL;
liveWeakPtrs = NIL;
* in the distribution for details.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:41 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:55 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
#define STGPRIM 94 /* STGPRIM snd :: (PrimOp,[Arg]) */
#define STGCON 95 /* STGCON snd :: (StgCon,[Arg]) */
#define PRIMCASE 96 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
-
/* Last constructor tag must be less than SPECMIN */
/* --------------------------------------------------------------------------
Kind kind; /* kind (includes arity) of Tycon */
Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
Cell defn;
- Tycon nextTyconHash;
+ Name conToTag; /* used in derived code */
+ Name tagToCon;
+ //Tycon nextTyconHash;
};
extern struct strTycon DECTABLE(tabTycon);
Cell defn;
Cell stgVar; /* really StgVar */
const void* primop; /* really StgPrim* */
- Name nextNameHash;
+ //Name nextNameHash;
};
extern int numNames Args(( Void ));
#define mfunOf(n) ((-1)-name(n).number)
#define mfunNo(i) ((-1)-(i))
-extern Name newName Args((Text,Cell));
-extern Name findName Args((Text));
-extern Name addName Args((Name));
-extern Name findQualName Args((Cell));
-extern Name addPrimCfun Args((Text,Int,Int,Int));
-extern Int sfunPos Args((Name,Name));
+extern Name newName Args((Text,Cell));
+extern Name findName Args((Text));
+extern Name addName Args((Name));
+extern Name findQualName Args((Cell));
+extern Name addPrimCfun Args((Text,Int,Int,Cell));
+extern Name addPrimCfunREP Args((Text,Int,Int,Int));
+extern Int sfunPos Args((Name,Name));
/* --------------------------------------------------------------------------
* Type class values:
extern List dupList Args((List));
extern List revOnto Args((List, List)); /* destructive */
#define rev(xs) revOnto((xs),NIL) /* destructive */
+#define reverse(xs) revOnto(dupList(xs),NIL) /* non-destructive */
extern Cell cellIsMember Args((Cell,List));
extern Cell cellAssoc Args((Cell,List));
extern Cell cellRevAssoc Args((Cell,List));
extern List splitAt Args((Int,List)); /* non-destructive */
extern Cell nth Args((Int,List));
extern List removeCell Args((Cell,List)); /* destructive */
+extern List dupListOnto Args((List,List)); /* non-destructive */
/* The following macros provide `inline expansion' of some common ways of
* traversing, using and modifying lists:
* in the distribution for details.
*
* $RCSfile: subst.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:42 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:56 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
deRef(tyv1,t1,o1);
deRef(tyv2,t2,o2);
-un: if (tyv1)
+un: if (tyv1) {
if (tyv2)
return varToVarBind(tyv1,tyv2); /* t1, t2 variables */
else {
}
return varToTypeBind(tyv1,t2,o2);
}
+ }
else
if (tyv2) {
Cell h1 = getDerefHead(t1,o1); /* t2 variable, t1 not */
deRef(tyv1,t1,o1);
deRef(tyv2,t2,o2);
- if (tyv1) /* unify heads! */
+ if (tyv1) { /* unify heads! */
if (tyv2)
return varToVarBind(tyv1,tyv2);
else
return varToTypeBind(tyv1,t2,o2);
+ }
else if (tyv2)
return varToTypeBind(tyv2,t1,o1);
deRef(kyv1,k1,o1);
deRef(kyv2,k2,o2);
- if (kyv1)
+ if (kyv1) {
if (kyv2)
return kvarToVarBind(kyv1,kyv2); /* k1, k2 variables */
else
return kvarToTypeBind(kyv1,k2,o2); /* k1 variable, k2 not */
+ }
else
if (kyv2)
return kvarToTypeBind(kyv2,k1,o1); /* k2 variable, k1 not */
* Hugs version 1.4, December 1997
*
* $RCSfile: translate.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/02/03 17:08:44 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/01 14:46:57 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
/* ---------------------------------------------------------------- */
-/* Association list storing globals assigned to dictionaries, tuples, etc */
+/* Association list storing globals assigned to */
+/* dictionaries, tuples, etc */
List stgGlobals = NIL;
static StgVar local getSTGTupleVar Args((Cell));
}
case GUARDED:
{
- List guards = rev(snd(e));
+ List guards = reverse(snd(e));
e = failExpr;
for(; nonNull(guards); guards=tl(guards)) {
Cell g = hd(guards);
} else if (isChar(fst(hd(alts)))) {
Cell alt = hd(alts);
StgDiscr d = fst(alt);
- StgVar c = mkStgVar(mkStgCon(nameMkC,singleton(d)),NIL);
+ StgVar c = mkStgVar(
+ mkStgCon(nameMkC,singleton(d)),NIL);
StgExpr test = nameEqChar;
/* duplicates scrut but it should be atomic */
- return makeStgIf(makeStgLet(singleton(c),makeStgApp(test,doubleton(scrut,c))),
- stgExpr(snd(alt),co,sc,failExpr),
- stgExpr(ap(CASE,pair(fst(snd(e)),tl(alts))),co,sc,failExpr));
+ return makeStgIf(
+ makeStgLet(singleton(c),
+ makeStgApp(test,doubleton(scrut,c))),
+ stgExpr(snd(alt),co,sc,failExpr),
+ stgExpr(ap(CASE,pair(fst(snd(e)),
+ tl(alts))),co,sc,failExpr));
} else {
List as = NIL;
for(; nonNull(alts); alts=tl(alts)) {
as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
}
- return mkStgCase(scrut, revOnto(as, singleton(mkStgDefault(mkStgVar(NIL,NIL),failExpr))));
+ return mkStgCase(
+ scrut,
+ revOnto(
+ as,
+ singleton(mkStgDefault(mkStgVar(NIL,NIL),
+ failExpr))));
}
}
case NUMCASE:
binds = cons(n,binds);
/* coerce number to right type (using Integral dict) */
- n = mkStgVar(mkStgApp(namePmFromInteger,doubleton(dIntegral,n)),NIL);
+ n = mkStgVar(mkStgApp(
+ namePmFromInteger,doubleton(dIntegral,n)),NIL);
binds = cons(n,binds);
++co;
- v = mkStgVar(mkStgApp(namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
- return mkStgLet(binds,
- makeStgIf(mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
- mkStgLet(singleton(v),
- stgExpr(r,
- co,
- cons(pair(mkOffset(co),v),sc),
- failExpr)),
- failExpr));
+ v = mkStgVar(mkStgApp(
+ namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
+ return
+ mkStgLet(
+ binds,
+ makeStgIf(
+ mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
+ mkStgLet(singleton(v),
+ stgExpr(r,
+ co,
+ cons(pair(mkOffset(co),v),sc),
+ failExpr)),
+ failExpr));
}
#endif /* NPLUSK */
Cell dict = arg(fun(discr));
StgExpr d = NIL;
List binds = NIL;
- StgExpr m = NIL;
+ //StgExpr m = NIL;
Name box
= h == nameFromInt ? nameMkI
: h == nameFromInteger ? nameMkBignum
n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
binds = cons(n,binds);
- return makeStgIf(mkStgLet(binds,
- mkStgApp(testFun,tripleton(d,n,scrut))),
- stgExpr(r,co+da,altsc,failExpr),
- failExpr);
+ return
+ makeStgIf(
+ mkStgLet(binds,
+ mkStgApp(testFun,tripleton(d,n,scrut))),
+ stgExpr(r,co+da,altsc,failExpr),
+ failExpr
+ );
}
}
#else /* ! OVERLOADED_CONSTANTS */
as = cons(v,as);
funsc = cons(pair(mkOffset(co+i),v),funsc);
}
- stgVarBody(nv) = mkStgLambda(as,stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
+ stgVarBody(nv)
+ = mkStgLambda(
+ as,
+ stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
}
/* transform expressions */
for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
Cell nv = mkStgVar(NIL,NIL);
vs=cons(nv,vs);
}
- return mkStgCase(v,
- doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
- mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
+ return
+ mkStgCase(v,
+ doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
+ mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
}
/* Arguments must be StgAtoms */
}
}
-static Void ppExp( Name n, Int arity, Cell e );
+#if 0 /* apparently not used */
static Void ppExp( Name n, Int arity, Cell e )
{
#if DEBUG_CODE
}
#endif
}
+#endif
+
Void stgDefn( Name n, Int arity, Cell e )
{
List vs = NIL;
List sc = NIL;
Int i;
-//printf("\nBEGIN --------------- stgDefn-ppExp ----------------\n" );
-// ppExp(n,arity,e);
-//printf("\nEND ----------------- stgDefn-ppExp ----------------\n" );
+ // ppExp(n,arity,e);
for (i = 1; i <= arity; ++i) {
Cell nv = mkStgVar(NIL,NIL);
vs = cons(nv,vs);
sc = cons(pair(mkOffset(i),nv),sc);
}
- stgVarBody(name(n).stgVar) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
-//printf("\nBEGIN --------------- stgDefn-ppStg ----------------\n" );
-// ppStg(name(n).stgVar);
-//printf("\nEND ----------------- stgDefn-ppStg ----------------\n" );
+ stgVarBody(name(n).stgVar)
+ = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
+ //ppStg(name(n).stgVar);
+ //printStg(stdout, name(n).stgVar);
}
static StgExpr forceArgs( List is, List args, StgExpr e );
return e;
}
-#if 0
-ToDo: reinstate eventually
-/* \ v -> case v of { ...; Ci _ _ -> i; ... } */
-Void implementConToTag(t)
-Tycon t; {
- if (isNull(tycon(t).conToTag)) {
- List cs = tycon(t).defn;
- Name nm = newName(inventText());
- StgVar v = mkStgVar(NIL,NIL);
- List alts = NIL; /* can't fail */
-
- assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
- for (; hasCfun(cs); cs=tl(cs)) {
- Name c = hd(cs);
- Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
- StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),NIL);
- StgExpr tag = mkStgLet(singleton(r),r);
- List vs = NIL;
- Int i;
- for(i=0; i < name(c).arity; ++i) {
- vs = cons(mkStgVar(NIL,NIL),vs);
- }
- alts = cons(mkStgCaseAlt(c,vs,tag),alts);
- }
-
- name(nm).line = tycon(t).line;
- name(nm).type = conToTagType(t);
- name(nm).arity = 1;
- name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),NIL);
- tycon(t).conToTag = nm;
- /* hack to make it print out */
- stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
- }
-}
-
-/* \ v -> case v of { ...; i -> Ci; ... } */
-Void implementTagToCon(t)
-Tycon t; {
- if (isNull(tycon(t).tagToCon)) {
- String etxt;
- String tyconname;
- List cs;
- Name nm;
- StgVar v1;
- StgVar v2;
- Cell txt0;
- StgVar bind1;
- StgVar bind2;
- StgVar bind3;
- List alts;
-
- assert(nameMkA);
- assert(nameUnpackString);
- assert(nameError);
- assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
-
- tyconname = textToStr(tycon(t).text);
- etxt = malloc(100+strlen(tyconname));
- assert(etxt);
- sprintf(etxt,
- "out-of-range arg for `toEnum' in (derived) `instance Enum %s'",
- tyconname);
-
- cs = tycon(t).defn;
- nm = newName(inventText());
- v1 = mkStgVar(NIL,NIL);
- v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
-
- txt0 = mkStr(findText(etxt));
- bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
- bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)), NIL);
- bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)), NIL);
-
- alts = singleton(
- mkStgPrimAlt(
- singleton(
- mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
- ),
- makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
- )
- );
-
- for (; hasCfun(cs); cs=tl(cs)) {
- Name c = hd(cs);
- Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
- StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
- assert(name(c).arity==0);
- alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
- }
-
- name(nm).line = tycon(t).line;
- name(nm).type = tagToConType(t);
- name(nm).arity = 1;
- name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v1),
- mkStgCase(v1,singleton(mkStgCaseAlt(nameMkI,singleton(v2),
- mkStgPrimCase(v2,alts))))),NIL);
- tycon(t).tagToCon = nm;
- /* hack to make it print out */
- stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
- if (etxt) free(etxt);
- }
-}
-#endif
Void implementCfun(c,scs) /* Build implementation for constr */
Name c; /* fun c. scs lists integers (1..)*/
List scs; { /* in incr order of strict comps. */
Int a = name(c).arity;
+ //printf ( "implementCfun %s\n", textToStr(name(c).text) );
if (name(c).arity > 0) {
List args = makeArgs(a);
StgVar tv = mkStgVar(mkStgCon(c,args),NIL);
else if (t == typeFloat) return mkChar(FLOAT_REP);
else if (t == typeDouble) return mkChar(DOUBLE_REP);
#ifdef PROVIDE_FOREIGN
- else if (t == typeForeign)return mkChar(FOREIGN_REP); /* ToDo: argty only! */
+ else if (t == typeForeign)return mkChar(FOREIGN_REP);
+ /* ToDo: argty only! */
#endif
#ifdef PROVIDE_ARRAY
- else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */
+ else if (t == typePrimByteArray) return mkChar(BARR_REP);
+ /* ToDo: argty only! */
else if (whatIs(t) == AP) {
Type h = getHead(t);
- if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */
+ if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
+ /* ToDo: argty only! */
}
#endif
/* ToDo: decent line numbers! */
if (nonNull(b_args)) {
StgVar b_arg = hd(b_args); /* boxed arg */
StgVar u_arg = hd(u_args); /* unboxed arg */
- StgRep k = mkStgRep(*reps);
+ //StgRep k = mkStgRep(*reps);
Name box = repToBox(*reps);
e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
if (isNull(box)) {
/* box results */
if (strcmp(r_reps,"B") == 0) {
- StgPrimAlt altF = mkStgPrimAlt(singleton(
- mkStgPrimVar(mkInt(0),
- mkStgRep(INT_REP),NIL)
- ),
- nameFalse);
- StgPrimAlt altT = mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
- nameTrue);
+ StgPrimAlt altF
+ = mkStgPrimAlt(singleton(
+ mkStgPrimVar(mkInt(0),
+ mkStgRep(INT_REP),NIL)
+ ),
+ nameFalse);
+ StgPrimAlt altT
+ = mkStgPrimAlt(
+ singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
+ nameTrue);
alts = doubleton(altF,altT);
assert(nonNull(nameTrue));
assert(!addState);
b_args = mkBoxedVars(a_reps);
u_args = mkUnboxedVars(a_reps);
if (addState) {
- List actual_args = appendOnto(extra_args,dupOnto(u_args,singleton(s0)));
- StgRhs rhs = makeStgLambda(singleton(s0),
- unboxVars(a_reps,b_args,u_args,
- mkStgPrimCase(mkStgPrim(op,actual_args),
- alts)));
+ List actual_args
+ = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
+ StgRhs rhs
+ = makeStgLambda(singleton(s0),
+ unboxVars(a_reps,b_args,u_args,
+ mkStgPrimCase(mkStgPrim(op,actual_args),
+ alts)));
StgVar m = mkStgVar(rhs,NIL);
return makeStgLambda(b_args,
mkStgLet(singleton(m),
mkStgApp(nameMkIO,singleton(m))));
} else {
List actual_args = appendOnto(extra_args,u_args);
- return makeStgLambda(b_args,
- unboxVars(a_reps,b_args,u_args,mkStgPrimCase(mkStgPrim(op,actual_args),alts)));
+ return makeStgLambda(
+ b_args,
+ unboxVars(a_reps,b_args,u_args,
+ mkStgPrimCase(mkStgPrim(op,actual_args),alts))
+ );
}
}
* }}})
* in primMkIO m
* ::
- * Addr -> (Int -> Float -> IO (Char,Addr)
+ * Addr -> (Int -> Float -> IO (Char,Addr))
*/
Void implementForeignImport( Name n )
{
} else {
resultTys = singleton(resultTys);
}
- mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
- mapOver(foreignResultTy,resultTys);/* doesn't */
+ mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
+ mapOver(foreignResultTy,resultTys); /* doesn't */
descriptor = mkDescriptor(charListToString(argTys),
charListToString(resultTys));
name(n).primop = addState ? &ccall_IO : &ccall_Id;
void* funPtr = getDLLSymbol(textToStr(textOf(fst(extName))),
textToStr(textOf(snd(extName))));
List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
- StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,descriptor->result_tys);
+ StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,
+ descriptor->result_tys);
StgVar v = mkStgVar(rhs,NIL);
if (funPtr == 0) {
ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
textToStr(textOf(fst(extName)))
EEND;
}
- ppStg(v);
+ //ppStg(v);
name(n).defn = NIL;
name(n).stgVar = v;
- stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
+ stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */
}
}
stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
} else {
StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
- stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* so we can see it */
+ stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
}
}
* in the distribution for details.
*
* $RCSfile: type.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:44 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:46:57 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
#include "backend.h"
#include "connect.h"
+#include "link.h"
#include "errors.h"
#include "subst.h"
#include "Assembler.h" /* for AsmCTypes */
Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */
/* types produce error */
-#if 1
-//ToDo: perhaps this should be somewhere else (link.c?)
-//all this stuff came with 98, and not STG
-Type typeArrow, typeList; /* Important primitive types */
-Type typeUnit;
-
-Module modulePrelude;
-
-static Type typeInt, typeDouble;
-static Type typeInteger, typeAddr;
-static Type typeString, typeChar;
-static Type typeBool, typeMaybe;
-static Type typeOrdering;
-
-Class classEq, classOrd; /* `standard' classes */
-Class classIx, classEnum;
-Class classShow, classRead;
-#if EVAL_INSTANCES
-Class classEval;
-#endif
-Class classBounded;
-
-Class classReal, classIntegral; /* `numeric' classes */
-Class classRealFrac, classRealFloat;
-Class classFractional, classFloating;
-Class classNum;
-
-List stdDefaults; /* standard default values */
-
-Name nameFromInt, nameFromDouble; /* coercion of numerics */
-Name nameFromInteger;
-Name nameEq, nameCompare; /* derivable names */
-Name nameLe;
-Name nameShowsPrec;
-Name nameReadsPrec;
-Name nameMinBnd, nameMaxBnd;
-Name nameIndex, nameInRange;
-Name nameRange;
-Name nameMult, namePlus;
-Name nameTrue, nameFalse; /* primitive boolean constructors */
-Name nameNil, nameCons; /* primitive list constructors */
-Name nameJust, nameNothing; /* primitive Maybe constructors */
-Name nameLeft, nameRight; /* primitive Either constructors */
-Name nameUnit; /* primitive Unit type constructor */
-Name nameLT, nameEQ; /* Ordering constructors */
-Name nameGT;
-Class classMonad; /* Monads */
-Name nameReturn, nameBind; /* for translating monad comps */
-Name nameMFail;
-Name nameGt; /* for readsPrec */
-#if EVAL_INSTANCES
-Name nameStrict, nameSeq; /* Members of class Eval */
-#endif
-
-#if IO_MONAD
-Type typeProgIO; /* For the IO monad, IO () */
-Name nameUserErr; /* loosely coupled IOError cfuns */
-Name nameNameErr, nameSearchErr;
-#endif
-#if IO_HANDLES
-Name nameWriteErr, nameIllegal;
-Name nameEOFErr;
-#endif
-
-#if TREX
-Type typeNoRow; /* Empty row */
-Type typeRec; /* Record formation */
-Name nameNoRec; /* Empty record */
-#endif
-
-//end ToDo
-#endif
/* --------------------------------------------------------------------------
* Local function prototypes:
static Void local typeDefnGroup Args((List));
static Pair local typeSel Args((Name));
-static List offsetTyvarsIn Args((Type,List));
-static Type conToTagType Args((Tycon));
-static Type tagToConType Args((Tycon));
-
-
-/* --------------------------------------------------------------------------
- * Frequently used type skeletons:
- * ------------------------------------------------------------------------*/
-
-/* ToDo: move these to link.c and call them 'typeXXXX' */
- Type arrow; /* mkOffset(0) -> mkOffset(1) */
-static Type boundPair; /* (mkOffset(0),mkOffset(0)) */
- Type listof; /* [ mkOffset(0) ] */
-static Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
- Cell predNum; /* Num (mkOffset(0)) */
- Cell predFractional; /* Fractional (mkOffset(0)) */
- Cell predIntegral; /* Integral (mkOffset(0)) */
-static Kind starToStar; /* Type -> Type */
- Cell predMonad; /* Monad (mkOffset(0)) */
/* --------------------------------------------------------------------------
* Assumptions:
static String aspat = "as (@) pattern";
static String typeSig = "type annotation";
static String lambda = "lambda expression";
-
+ //printf("\n\n+++++++++++++++++++++++++++++++\n");
+ //print(e,1000);
+ //printf("\n\n");
switch (whatIs(e)) {
/* The following cases can occur in either pattern or expr. mode */
Cell p = NIL;
Cell a = e;
Int i;
+ //print(h,1000);
+ //printf("\n");
switch (whatIs(h)) {
case NAME : typeIs = name(h).type;
break;
}
- if (isNull(typeIs))
+ if (isNull(typeIs)) {
+ //printf("\n NAME " );
+ //print(h,1000);
+ //printf(" TYPE " ); print(typeIs,1000);
internal("typeAp1");
+ }
instantiate(typeIs); /* Deal with polymorphism ... */
if (nonNull(predsAre)) { /* ... and with qualified types. */
assumeEvid(hd(predsAre),typeOff);
if (whatIs(typeIs)==RANK2) {
- ERRMSG(line) "Sorry, record update syntax cannot currently be used for datatypes with polymorphic components"
+ ERRMSG(line) "Sorry, record update syntax cannot currently be "
+ "used for datatypes with polymorphic components"
EEND;
}
List locs = NIL;
Cell l = mkInt(cclass(c).line);
List ps;
-
+//printf("\ntypeClassDefn %s\n", textToStr(cclass(c).text));
for (ps=params; nonNull(ps); ps=tl(ps)) {
Cell v = thd3(hd(ps));
body = ap(body,v);
for (; nonNull(mems); mems=tl(mems)) {
Cell v = inventVar(); /* Pick a name for component */
Cell imp = NIL;
-
+//printf(" defaulti %s\n", textToStr(name(hd(mems)).text));
if (nonNull(defs)) { /* Look for default implementation */
imp = hd(defs);
defs = tl(defs);
args = tl(args);
genDefns = cons(hd(mems),genDefns);
}
+//printf("done\n" );
}
static Void local typeInstDefn(in) /* Type check implementations of */
Type rt;
#ifdef DEBUG_TYPES
- Printf("Type check member: ");
+ Printf("\nType check member: ");
printExp(stdout,mem);
Printf(" :: ");
printType(stdout,name(mem).type);
- Printf("\nfor the instance: ");
+ Printf("\n for the instance: ");
printPred(stdout,head);
Printf("\n");
#endif
ps = copyPreds(ps);
t = generalize(ps,liftRank2(t,o,m));
#ifdef DEBUG_TYPES
- Printf("Inferred type is: ");
+ Printf(" Inferred type is: ");
printType(stdout,t);
Printf("\n");
#endif
tooGeneral(line,mem,rt,t);
if (nonNull(preds))
cantEstablish(line,wh,mem,t,ps);
+//printf("done\n" );
}
/* --------------------------------------------------------------------------
static Void local typeDefnGroup(bs) /* type check group of value defns */
List bs; { /* (one top level scc) */
List as;
+// printf("\n\n+++ DefnGroup ++++++++++++++++++++++++++++\n");
+//{ List qq; for (qq=bs;nonNull(qq);qq=tl(qq)){
+// print(hd(qq),4);
+// printf("\n");
+//}}
emptySubstitution();
hd(defnBounds) = NIL;
static Type local basicType Args((Char));
-/* --------------------------------------------------------------------------
- *
- * ------------------------------------------------------------------------*/
-
-static List offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
-Type t; /* to list vs */
-List vs; {
- switch (whatIs(t)) {
- case AP : return offsetTyvarsIn(fun(t),
- offsetTyvarsIn(arg(t),vs));
-
- case OFFSET : if (cellIsMember(t,vs)) {
- return vs;
- } else {
- return cons(t,vs);
- }
- case QUAL : return offsetTyvarsIn(snd(t),vs);
-
- case POLYTYPE : return offsetTyvarsIn(monotypeOf(t),vs);
- /* slightly inaccurate, but won't matter here */
-
- case EXIST :
- case RANK2 : return offsetTyvarsIn(snd(snd(t)),vs);
-
- default : return vs;
- }
-}
-static Type stateVar = NIL;
-static Type alphaVar = NIL;
-static Type betaVar = NIL;
-static Type gammaVar = NIL;
-static Int nextVar = 0;
+static Type stateVar = BOGUS(600); //NIL;
+static Type alphaVar = BOGUS(601); //NIL;
+static Type betaVar = BOGUS(602); //NIL;
+static Type gammaVar = BOGUS(603); //NIL;
+static Int nextVar = BOGUS(604); //0;
static Void clearTyVars( void )
{
case BETA_REP:
return mkBetaVar(); /* polymorphic */
case GAMMA_REP:
- return mkGammaVar(); /* polymorphic */
+ return mkGammaVar(); /* polymorphic */
default:
printf("Kind: '%c'\n",k);
internal("basicType");
}
/* forall a1 .. am. TC a1 ... am -> Int */
-static Type conToTagType(t)
+Type conToTagType(t)
Tycon t; {
Type ty = t;
List tvars = NIL;
}
/* forall a1 .. am. Int -> TC a1 ... am */
-static Type tagToConType(t)
+Type tagToConType(t)
Tycon t; {
Type ty = t;
List tvars = NIL;
dummyVar = inventVar();
#if !IGNORE_MODULES
- modulePrelude = newModule(textPrelude);
setCurrModule(modulePrelude);
#endif
#if MAJOR_RELEASE
#define HUGS_VERSION "January 1998 "
#else
-#define HUGS_VERSION "STG prototype"
+#define HUGS_VERSION "STG-98 proto "
#endif
-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
- * $Id: Assembler.c,v 1.4 1999/02/05 16:02:34 simonm Exp $
+ * Bytecode assembler
*
- * Copyright (c) The GHC Team 1994-1998.
+ * Copyright (c) 1994-1998.
*
- * Bytecode assembler
+ * $RCSfile: Assembler.c,v $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/01 14:47:02 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
struct AsmBCO_ {
struct AsmObject_ object; /* must be first in struct */
-
+
+ int /*StgExpr*/ stgexpr;
Instrs is;
NonPtrs nps;
/* todo: free the queues */
/* we don't print until all ptrs are resolved */
- IF_DEBUG(codegen,printObj(obj->closure));
+ IF_DEBUG(codegen,printObj(obj->closure);printf("\n\n"));
}
}
obj->closure = c;
mapQueue(Ptrs, AsmObject, obj->ptrs, asmAddRef(x,obj,i));
mapQueue(Refs, AsmRef, obj->refs, asmResolveRef(x.ref,x.i,c));
+#if 0
if (obj->num_unresolved == 0) {
/* todo: free the queues */
/* we don't print until all ptrs are resolved */
+ IF_DEBUG(codegen,
+ if (obj->num_unresolved > 0)
+ fprintf(stderr, "{{%d unresolved}} ", obj->num_unresolved);
+ )
IF_DEBUG(codegen,printObj(obj->closure));
}
+ //printf( "unresolved %d\n", obj->num_unresolved);
+ //printObj(obj->closure);
+#endif
}
int asmObjectHasClosure ( AsmObject obj )
asmEndObject(&caf->object,c);
}
-AsmBCO asmBeginBCO( void )
+AsmBCO asmBeginBCO( int /*StgExpr*/ e )
{
AsmBCO bco = malloc(sizeof(struct AsmBCO_));
if (bco == NULL) {
initInstrs(&bco->is);
initNonPtrs(&bco->nps);
+ bco->stgexpr = e;
bco->max_sp = bco->sp = 0;
bco->max_hp = bco->hp = 0;
return bco;
o->n_ptrs = p;
o->n_words = np;
o->n_instrs = is;
+ o->stgexpr = bco->stgexpr;
mapQueue(Ptrs, AsmObject, bco->object.ptrs, bcoConstCPtr(o,i) = NULL);
mapQueue(NonPtrs, StgWord, bco->nps, bcoConstWord(o,i) = x);
{
{ \
union { ty a; AsmWord b[sizeofW(ty)]; } p; \
nat i; \
+ if (sizeof(ty) < sizeof(AsmWord)) p.b[0]=0; \
p.a = x; \
for( i = 0; i < sizeofW(ty); i++ ) { \
asmWord(bco,p.b[i]); \
case DOUBLE_REP:
asmInstr(bco,i_UNPACK_DOUBLE);
break;
+#ifdef PROVIDE_STABLE
case STABLE_REP:
asmInstr(bco,i_UNPACK_STABLE);
break;
-
+#endif
default:
barf("asmUnbox %d",rep);
}
return bco->sp;
}
-AsmBCO asmBeginContinuation ( AsmSp sp )
+AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts )
{
- AsmBCO bco = asmBeginBCO();
+ AsmBCO bco = asmBeginBCO(alts);
bco->sp = sp;
return bco;
}
asmEndBCO(bco);
}
+
/* --------------------------------------------------------------------------
* Branches
* ------------------------------------------------------------------------*/
, { "primOrInt", "II", "I", MONAD_Id, i_PRIMOP1, i_orInt }
, { "primXorInt", "II", "I", MONAD_Id, i_PRIMOP1, i_xorInt }
, { "primNotInt", "I", "I", MONAD_Id, i_PRIMOP1, i_notInt }
- , { "primShiftLInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftLInt }
- , { "primShiftRAInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftRAInt }
- , { "primShiftRLInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftRLInt }
+ , { "primShiftLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftLInt }
+ , { "primShiftRAInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRAInt }
+ , { "primShiftRLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRLInt }
#ifdef PROVIDE_INT64
/* Int64# operations */
#ifdef PROVIDE_INT64
, { "primIndexInt64OffAddr", "AI", "z", MONAD_Id, i_PRIMOP1, i_indexInt64OffAddr }
#endif
+#ifdef PROVIDE_WORD
, { "primIndexWordOffAddr", "AI", "W", MONAD_Id, i_PRIMOP1, i_indexWordOffAddr }
+#endif
, { "primIndexAddrOffAddr", "AI", "A", MONAD_Id, i_PRIMOP1, i_indexAddrOffAddr }
, { "primIndexFloatOffAddr", "AI", "F", MONAD_Id, i_PRIMOP1, i_indexFloatOffAddr }
, { "primIndexDoubleOffAddr", "AI", "D", MONAD_Id, i_PRIMOP1, i_indexDoubleOffAddr }
#ifdef PROVIDE_INT64
, { "primReadInt64OffAddr", "AI", "z", MONAD_ST, i_PRIMOP1, i_readInt64OffAddr }
#endif
+#ifdef PROVIDE_WORD
, { "primReadWordOffAddr", "AI", "W", MONAD_ST, i_PRIMOP1, i_readWordOffAddr }
+#endif
, { "primReadAddrOffAddr", "AI", "A", MONAD_ST, i_PRIMOP1, i_readAddrOffAddr }
, { "primReadFloatOffAddr", "AI", "F", MONAD_ST, i_PRIMOP1, i_readFloatOffAddr }
, { "primReadDoubleOffAddr", "AI", "D", MONAD_ST, i_PRIMOP1, i_readDoubleOffAddr }
#ifdef PROVIDE_INT64
, { "primWriteInt64OffAddr", "AIz", "", MONAD_ST, i_PRIMOP1, i_writeInt64OffAddr }
#endif
+#ifdef PROVIDE_WORD
, { "primWriteWordOffAddr", "AIW", "", MONAD_ST, i_PRIMOP1, i_writeWordOffAddr }
+#endif
, { "primWriteAddrOffAddr", "AIA", "", MONAD_ST, i_PRIMOP1, i_writeAddrOffAddr }
, { "primWriteFloatOffAddr", "AIF", "", MONAD_ST, i_PRIMOP1, i_writeFloatOffAddr }
, { "primWriteDoubleOffAddr", "AID", "", MONAD_ST, i_PRIMOP1, i_writeDoubleOffAddr }
, { "primDivModInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_divModInteger }
, { "primIntegerToInt", "Z", "I", MONAD_Id, i_PRIMOP1, i_integerToInt }
, { "primIntToInteger", "I", "Z", MONAD_Id, i_PRIMOP1, i_intToInteger }
+#ifdef PROVIDE_INT64
, { "primIntegerToInt64", "Z", "z", MONAD_Id, i_PRIMOP1, i_integerToInt64 }
, { "primInt64ToInteger", "z", "Z", MONAD_Id, i_PRIMOP1, i_int64ToInteger }
+#endif
#ifdef PROVIDE_WORD
, { "primIntegerToWord", "Z", "W", MONAD_Id, i_PRIMOP1, i_integerToWord }
, { "primWordToInteger", "W", "Z", MONAD_Id, i_PRIMOP1, i_wordToInteger }
/* Polymorphic force :: a -> (# #) */
- , { "primForce", "a", "", MONAD_Id, i_PRIMOP2, i_force }
+ /* , { "primForce", "a", "", MONAD_Id, i_PRIMOP2, i_force } */
/* Error operations - not in IO monad! */
- , { "primRaise", "E", "a", MONAD_Id, i_PRIMOP2, i_raise }
- , { "primCatch'", "aH", "a", MONAD_Id, i_PRIMOP2, i_catch }
+ //, { "primRaise", "E", "a", MONAD_Id, i_PRIMOP2, i_raise }
+ //, { "primCatch'", "aH", "a", MONAD_Id, i_PRIMOP2, i_catch }
#ifdef PROVIDE_ARRAY
/* Ref operations */
const AsmPrim ccall_Id = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_Id };
const AsmPrim ccall_IO = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_IO };
+
const AsmPrim* asmFindPrim( char* s )
{
int i;
}
/* --------------------------------------------------------------------------
+ * Handwritten primops
+ * ------------------------------------------------------------------------*/
+
+AsmBCO asm_BCO_catch ( void )
+{
+ AsmBCO bco = asmBeginBCO(0 /*NIL*/);
+ asmInstr(bco,i_ARG_CHECK); asmInstr(bco,2);
+ asmInstr(bco,i_PRIMOP1); asmInstr(bco,i_pushcatchframe);
+ bco->sp += (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame);
+ asmInstr(bco,i_ENTER);
+ asmEndBCO(bco);
+ return bco;
+}
+
+AsmBCO asm_BCO_raise ( void )
+{
+ AsmBCO bco = asmBeginBCO(0 /*NIL*/);
+ asmInstr(bco,i_ARG_CHECK); asmInstr(bco,1);
+ asmInstr(bco,i_PRIMOP2); asmInstr(bco,i_raise);
+ asmEndBCO(bco);
+ return bco;
+}
+
+AsmBCO asm_BCO_seq ( void )
+{
+ AsmBCO eval, cont;
+
+ cont = asmBeginBCO(0 /*NIL*/);
+ asmInstr(cont,i_ARG_CHECK); asmInstr(cont,2);
+ asmInstr(cont,i_VAR); asmInstr(cont,1);
+ asmInstr(cont,i_SLIDE); asmInstr(cont,1); asmInstr(cont,2);
+ asmInstr(cont,i_ENTER);
+ cont->sp += 3*sizeofW(StgPtr);
+ asmEndBCO(cont);
+
+ eval = asmBeginBCO(0 /*NIL*/);
+ asmInstr(eval,i_ARG_CHECK); asmInstr(eval,2);
+ asmInstr(eval,i_RETADDR);
+ asmInstr(eval,eval->object.ptrs.len);
+ asmPtr(eval,&(cont->object));
+ asmInstr(eval,i_VAR); asmInstr(eval,2);
+ asmInstr(eval,i_SLIDE); asmInstr(eval,3); asmInstr(eval,1);
+ asmInstr(eval,i_PRIMOP1); asmInstr(eval,i_pushseqframe);
+ asmInstr(eval,i_ENTER);
+ eval->sp += sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr);
+ asmEndBCO(eval);
+
+ return eval;
+}
+
+/* --------------------------------------------------------------------------
* Heap manipulation
* ------------------------------------------------------------------------*/
void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info )
{
nat size = bco->sp - start;
- ASSERT(bco->sp >= start);
- ASSERT(start >= v);
+ assert(bco->sp >= start);
+ assert(start >= v);
/* only reason to include info is for this assertion */
- ASSERT(info->layout.payload.ptrs == size);
+ assert(info->layout.payload.ptrs == size);
asmInstr(bco,i_PACK);
asmInstr(bco,bco->sp - v);
bco->sp = start;
-/* -*- mode: hugs-c; -*- */
+
/* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.3 1999/02/05 16:02:36 simonm Exp $
+ * $Id: Bytecodes.h,v 1.4 1999/03/01 14:47:07 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
*
* Notes:
* o INTERNAL_ERROR is never generated by the compiler and usually
- * indicates as error in the heap.
+ * indicates an error in the heap.
* PANIC is generated by the compiler whenever it tests an "irrefutable"
* pattern which fails. If we don't see too many of these, we could
* optimise out the redundant test.
, i_RETADDR
, i_VOID
-
, i_RETURN_GENERIC
, i_VAR_INT
typedef enum
{ i_INTERNAL_ERROR1 /* Instruction 0 raises an internal error */
+ , i_pushseqframe
+ , i_pushcatchframe
+
/* Char# operations */
, i_gtChar
, i_geChar
{ i_INTERNAL_ERROR2 /* Instruction 0 raises an internal error */
, i_raise
- , i_catch
- , i_force
#ifdef PROVIDE_ARRAY
/* Ref operations */
-/* -*- mode: hugs-c; -*- */
+
/* -----------------------------------------------------------------------------
- * $Id: Disassembler.c,v 1.3 1999/02/05 16:02:37 simonm Exp $
- *
- * Copyright (c) The GHC Team 1994-1999.
- *
* Bytecode disassembler
*
+ * Copyright (c) 1994-1998.
+ *
+ * $RCSfile: Disassembler.c,v $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/01 14:47:05 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
static InstrPtr disConstChar ( StgBCO *bco, InstrPtr pc, char* i )
{
StgChar x = bcoConstChar(bco,bcoInstr(bco,pc++));
- fprintf(stderr,"%s '%c'",i,x);
+ if (isprint((int)x))
+ fprintf(stderr,"%s '%c'",i,x); else
+ fprintf(stderr,"%s 0x%x",i,(int)x);
return pc;
}
case i_VOID:
return disNone(bco,pc,"VOID");
-
case i_RETURN_GENERIC:
return disNone(bco,pc,"RETURN_GENERIC");
switch (op) {
case i_INTERNAL_ERROR1:
return disNone(bco,pc,"INTERNAL_ERROR1");
+ case i_pushseqframe:
+ return disNone(bco,pc,"i_pushseqframe");
+ case i_pushcatchframe:
+ return disNone(bco,pc,"i_pushcatchframe");
default:
{
const AsmPrim* p = asmFindPrimop(i_PRIMOP1,op);
return disNone(bco,pc,"ccall_Id");
case i_ccall_IO:
return disNone(bco,pc,"ccall_IO");
+ case i_raise:
+ return disNone(bco,pc,"primRaise");
default:
{
const AsmPrim* p = asmFindPrimop(i_PRIMOP2,op);
pc = disInstr(bco,pc);
fprintf(stderr,"\n");
}
+ if (bco->stgexpr) {
+ ppStgExpr(bco->stgexpr);
+ fprintf(stderr, "\n");
+ }
+ else
+ fprintf(stderr, "\t(handwritten bytecode)\n" );
}
#endif /* INTERPRETER */
/* -----------------------------------------------------------------------------
- * $Id: Evaluator.c,v 1.9 1999/02/11 17:40:24 simonm Exp $
- *
- * Copyright (c) The GHC Team 1994-1999.
- *
* Bytecode evaluator
*
+ * Copyright (c) 1994-1998.
+ *
+ * $RCSfile: Evaluator.c,v $
+ * $Revision: 1.10 $
+ * $Date: 1999/03/01 14:47:03 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#ifdef PROVIDE_INTEGER
static /*inline*/ mpz_ptr mpz_alloc ( void );
-static /*inline*/ void mpz_free ( mpz_ptr );
+//static /*inline*/ void mpz_free ( mpz_ptr );
static /*inline*/ mpz_ptr mpz_alloc ( void )
{
return r;
}
+#if 0 /* apparently unused */
static /*inline*/ void mpz_free ( mpz_ptr a )
{
mpz_clear(a);
free(a);
}
#endif
+#endif
/* --------------------------------------------------------------------------
*
* ------------------------------------------------------------------------*/
-static /*inline*/ void PushTag ( StackTag t );
-static /*inline*/ void PushPtr ( StgPtr x );
-static /*inline*/ void PushCPtr ( StgClosure* x );
-static /*inline*/ void PushInt ( StgInt x );
-static /*inline*/ void PushWord ( StgWord x );
+/*static*/ /*inline*/ void PushTag ( StackTag t );
+/*static*/ /*inline*/ void PushPtr ( StgPtr x );
+/*static*/ /*inline*/ void PushCPtr ( StgClosure* x );
+/*static*/ /*inline*/ void PushInt ( StgInt x );
+/*static*/ /*inline*/ void PushWord ( StgWord x );
-static /*inline*/ void PushTag ( StackTag t ) { *(--Sp) = t; }
-static /*inline*/ void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; }
-static /*inline*/ void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; }
-static /*inline*/ void PushInt ( StgInt x ) { *(--stgCast(StgInt*,Sp)) = x; }
-static /*inline*/ void PushWord ( StgWord x ) { *(--stgCast(StgWord*,Sp)) = x; }
+/*static*/ /*inline*/ void PushTag ( StackTag t ) { *(--Sp) = t; }
+/*static*/ /*inline*/ void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; }
+/*static*/ /*inline*/ void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; }
+/*static*/ /*inline*/ void PushInt ( StgInt x ) { *(--stgCast(StgInt*,Sp)) = x; }
+/*static*/ /*inline*/ void PushWord ( StgWord x ) { *(--stgCast(StgWord*,Sp)) = x; }
-static /*inline*/ void checkTag ( StackTag t1, StackTag t2 );
-static /*inline*/ void PopTag ( StackTag t );
-static /*inline*/ StgPtr PopPtr ( void );
-static /*inline*/ StgClosure* PopCPtr ( void );
-static /*inline*/ StgInt PopInt ( void );
-static /*inline*/ StgWord PopWord ( void );
+/*static*/ /*inline*/ void checkTag ( StackTag t1, StackTag t2 );
+/*static*/ /*inline*/ void PopTag ( StackTag t );
+/*static*/ /*inline*/ StgPtr PopPtr ( void );
+/*static*/ /*inline*/ StgClosure* PopCPtr ( void );
+/*static*/ /*inline*/ StgInt PopInt ( void );
+/*static*/ /*inline*/ StgWord PopWord ( void );
-static /*inline*/ void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);}
-static /*inline*/ void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); }
-static /*inline*/ StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; }
-static /*inline*/ StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; }
-static /*inline*/ StgInt PopInt ( void ) { return *stgCast(StgInt*,Sp)++; }
-static /*inline*/ StgWord PopWord ( void ) { return *stgCast(StgWord*,Sp)++; }
-
-static /*inline*/ StgPtr stackPtr ( StgStackOffset i );
-static /*inline*/ StgInt stackInt ( StgStackOffset i );
-static /*inline*/ StgWord stackWord ( StgStackOffset i );
-
-static /*inline*/ StgPtr stackPtr ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); }
-static /*inline*/ StgInt stackInt ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); }
-static /*inline*/ StgWord stackWord ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); }
+/*static*/ /*inline*/ void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);}
+/*static*/ /*inline*/ void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); }
+/*static*/ /*inline*/ StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; }
+/*static*/ /*inline*/ StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; }
+/*static*/ /*inline*/ StgInt PopInt ( void ) { return *stgCast(StgInt*,Sp)++; }
+/*static*/ /*inline*/ StgWord PopWord ( void ) { return *stgCast(StgWord*,Sp)++; }
+
+/*static*/ /*inline*/ StgPtr stackPtr ( StgStackOffset i );
+/*static*/ /*inline*/ StgInt stackInt ( StgStackOffset i );
+/*static*/ /*inline*/ StgWord stackWord ( StgStackOffset i );
+
+/*static*/ /*inline*/ StgPtr stackPtr ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); }
+/*static*/ /*inline*/ StgInt stackInt ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); }
+/*static*/ /*inline*/ StgWord stackWord ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); }
-static /*inline*/ void setStackWord ( StgStackOffset i, StgWord w );
+/*static*/ /*inline*/ void setStackWord ( StgStackOffset i, StgWord w );
-static /*inline*/ void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
+/*static*/ /*inline*/ void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
-static /*inline*/ void PushTaggedRealWorld( void );
-static /*inline*/ void PushTaggedInt ( StgInt x );
+/*static*/ /*inline*/ void PushTaggedRealWorld( void );
+/*static*/ /*inline*/ void PushTaggedInt ( StgInt x );
#ifdef PROVIDE_INT64
-static /*inline*/ void PushTaggedInt64 ( StgInt64 x );
+/*static*/ /*inline*/ void PushTaggedInt64 ( StgInt64 x );
#endif
#ifdef PROVIDE_INTEGER
-static /*inline*/ void PushTaggedInteger ( mpz_ptr x );
+/*static*/ /*inline*/ void PushTaggedInteger ( mpz_ptr x );
#endif
#ifdef PROVIDE_WORD
-static /*inline*/ void PushTaggedWord ( StgWord x );
+/*static*/ /*inline*/ void PushTaggedWord ( StgWord x );
#endif
#ifdef PROVIDE_ADDR
-static /*inline*/ void PushTaggedAddr ( StgAddr x );
+/*static*/ /*inline*/ void PushTaggedAddr ( StgAddr x );
#endif
-static /*inline*/ void PushTaggedChar ( StgChar x );
-static /*inline*/ void PushTaggedFloat ( StgFloat x );
-static /*inline*/ void PushTaggedDouble ( StgDouble x );
-static /*inline*/ void PushTaggedStablePtr ( StgStablePtr x );
-static /*inline*/ void PushTaggedBool ( int x );
+/*static*/ /*inline*/ void PushTaggedChar ( StgChar x );
+/*static*/ /*inline*/ void PushTaggedFloat ( StgFloat x );
+/*static*/ /*inline*/ void PushTaggedDouble ( StgDouble x );
+/*static*/ /*inline*/ void PushTaggedStablePtr ( StgStablePtr x );
+/*static*/ /*inline*/ void PushTaggedBool ( int x );
-static /*inline*/ void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); }
-static /*inline*/ void PushTaggedInt ( StgInt x ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
+/*static*/ /*inline*/ void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); }
+/*static*/ /*inline*/ void PushTaggedInt ( StgInt x ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
#ifdef PROVIDE_INT64
-static /*inline*/ void PushTaggedInt64 ( StgInt64 x ) { Sp -= sizeofW(StgInt64); ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); }
+/*static*/ /*inline*/ void PushTaggedInt64 ( StgInt64 x ) { Sp -= sizeofW(StgInt64); ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); }
#endif
#ifdef PROVIDE_INTEGER
-static /*inline*/ void PushTaggedInteger ( mpz_ptr x )
+/*static*/ /*inline*/ void PushTaggedInteger ( mpz_ptr x )
{
StgForeignObj *result;
- StgWeak *w;
+ //StgWeak *w;
result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
SET_HDR(result,&FOREIGN_info,CCCS);
SET_HDR(w, &WEAK_info, CCCS);
w->key = stgCast(StgClosure*,result);
w->value = stgCast(StgClosure*,result); /* or any other closure you have handy */
- w->finalizer = funPtrToIO(mpz_free);
+ w->finaliser = funPtrToIO(mpz_free);
w->link = weak_ptr_list;
weak_ptr_list = w;
IF_DEBUG(weak, fprintf(stderr,"New weak pointer watching Foreign MPZ at %p\n",w));
}
#endif
#ifdef PROVIDE_WORD
-static /*inline*/ void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
+/*static*/ /*inline*/ void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
#endif
#ifdef PROVIDE_ADDR
-static /*inline*/ void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
+/*static*/ /*inline*/ void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
#endif
-static /*inline*/ void PushTaggedChar ( StgChar x ) { Sp -= sizeofW(StgChar); *Sp = x; PushTag(CHAR_TAG); }
-static /*inline*/ void PushTaggedFloat ( StgFloat x ) { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
-static /*inline*/ void PushTaggedDouble ( StgDouble x ) { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
-static /*inline*/ void PushTaggedStablePtr ( StgStablePtr x ) { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
-static /*inline*/ void PushTaggedBool ( int x ) { PushTaggedInt(x); }
+/*static*/ /*inline*/ void PushTaggedChar ( StgChar x )
+{ Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
+
+/*static*/ /*inline*/ void PushTaggedFloat ( StgFloat x ) { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
+/*static*/ /*inline*/ void PushTaggedDouble ( StgDouble x ) { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
+/*static*/ /*inline*/ void PushTaggedStablePtr ( StgStablePtr x ) { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
+/*static*/ /*inline*/ void PushTaggedBool ( int x ) { PushTaggedInt(x); }
-static /*inline*/ void PopTaggedRealWorld ( void );
-static /*inline*/ StgInt PopTaggedInt ( void );
+/*static*/ /*inline*/ void PopTaggedRealWorld ( void );
+/*static*/ /*inline*/ StgInt PopTaggedInt ( void );
#ifdef PROVIDE_INT64
-static /*inline*/ StgInt64 PopTaggedInt64 ( void );
+/*static*/ /*inline*/ StgInt64 PopTaggedInt64 ( void );
#endif
#ifdef PROVIDE_INTEGER
-static /*inline*/ mpz_ptr PopTaggedInteger ( void );
+/*static*/ /*inline*/ mpz_ptr PopTaggedInteger ( void );
#endif
#ifdef PROVIDE_WORD
-static /*inline*/ StgWord PopTaggedWord ( void );
+/*static*/ /*inline*/ StgWord PopTaggedWord ( void );
#endif
#ifdef PROVIDE_ADDR
-static /*inline*/ StgAddr PopTaggedAddr ( void );
+/*static*/ /*inline*/ StgAddr PopTaggedAddr ( void );
#endif
-static /*inline*/ StgChar PopTaggedChar ( void );
-static /*inline*/ StgFloat PopTaggedFloat ( void );
-static /*inline*/ StgDouble PopTaggedDouble ( void );
-static /*inline*/ StgStablePtr PopTaggedStablePtr ( void );
+/*static*/ /*inline*/ StgChar PopTaggedChar ( void );
+/*static*/ /*inline*/ StgFloat PopTaggedFloat ( void );
+/*static*/ /*inline*/ StgDouble PopTaggedDouble ( void );
+/*static*/ /*inline*/ StgStablePtr PopTaggedStablePtr ( void );
-static /*inline*/ void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); }
-static /*inline*/ StgInt PopTaggedInt ( void ) { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); Sp += sizeofW(StgInt); return r;}
+/*static*/ /*inline*/ void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); }
+/*static*/ /*inline*/ StgInt PopTaggedInt ( void ) { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); Sp += sizeofW(StgInt); return r;}
#ifdef PROVIDE_INT64
-static /*inline*/ StgInt64 PopTaggedInt64 ( void ) { StgInt64 r; PopTag(INT64_TAG); r = PK_Int64(Sp); Sp += sizeofW(StgInt64); return r;}
+/*static*/ /*inline*/ StgInt64 PopTaggedInt64 ( void ) { StgInt64 r; PopTag(INT64_TAG); r = PK_Int64(Sp); Sp += sizeofW(StgInt64); return r;}
#endif
#ifdef PROVIDE_INTEGER
-static /*inline*/ mpz_ptr PopTaggedInteger ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);}
+/*static*/ /*inline*/ mpz_ptr PopTaggedInteger ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);}
#endif
#ifdef PROVIDE_WORD
-static /*inline*/ StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;}
+/*static*/ /*inline*/ StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;}
#endif
#ifdef PROVIDE_ADDR
-static /*inline*/ StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;}
+/*static*/ /*inline*/ StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;}
#endif
-static /*inline*/ StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = *stgCast(StgChar*, Sp); Sp += sizeofW(StgChar); return r;}
-static /*inline*/ StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;}
-static /*inline*/ StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;}
-static /*inline*/ StgStablePtr PopTaggedStablePtr ( void ) { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr); return r;}
+/*static*/ /*inline*/ StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); Sp += sizeofW(StgChar); return r;}
+/*static*/ /*inline*/ StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;}
+/*static*/ /*inline*/ StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;}
+/*static*/ /*inline*/ StgStablePtr PopTaggedStablePtr ( void ) { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr); return r;}
-static /*inline*/ StgInt taggedStackInt ( StgStackOffset i );
+/*static*/ /*inline*/ StgInt taggedStackInt ( StgStackOffset i );
#ifdef PROVIDE_INT64
-static /*inline*/ StgInt64 taggedStackInt64 ( StgStackOffset i );
+/*static*/ /*inline*/ StgInt64 taggedStackInt64 ( StgStackOffset i );
#endif
#ifdef PROVIDE_WORD
-static /*inline*/ StgWord taggedStackWord ( StgStackOffset i );
+/*static*/ /*inline*/ StgWord taggedStackWord ( StgStackOffset i );
#endif
#ifdef PROVIDE_ADDR
-static /*inline*/ StgAddr taggedStackAddr ( StgStackOffset i );
+/*static*/ /*inline*/ StgAddr taggedStackAddr ( StgStackOffset i );
#endif
-static /*inline*/ StgChar taggedStackChar ( StgStackOffset i );
-static /*inline*/ StgFloat taggedStackFloat ( StgStackOffset i );
-static /*inline*/ StgDouble taggedStackDouble ( StgStackOffset i );
-static /*inline*/ StgStablePtr taggedStackStable ( StgStackOffset i );
+/*static*/ /*inline*/ StgChar taggedStackChar ( StgStackOffset i );
+/*static*/ /*inline*/ StgFloat taggedStackFloat ( StgStackOffset i );
+/*static*/ /*inline*/ StgDouble taggedStackDouble ( StgStackOffset i );
+/*static*/ /*inline*/ StgStablePtr taggedStackStable ( StgStackOffset i );
-static /*inline*/ StgInt taggedStackInt ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
+/*static*/ /*inline*/ StgInt taggedStackInt ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
#ifdef PROVIDE_INT64
-static /*inline*/ StgInt64 taggedStackInt64 ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]); return PK_Int64(Sp+1+i); }
+/*static*/ /*inline*/ StgInt64 taggedStackInt64 ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]); return PK_Int64(Sp+1+i); }
#endif
#ifdef PROVIDE_WORD
-static /*inline*/ StgWord taggedStackWord ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
+/*static*/ /*inline*/ StgWord taggedStackWord ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
#endif
#ifdef PROVIDE_ADDR
-static /*inline*/ StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
+/*static*/ /*inline*/ StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
#endif
-static /*inline*/ StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return *stgCast(StgChar*, Sp+1+i); }
-static /*inline*/ StgFloat taggedStackFloat ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
-static /*inline*/ StgDouble taggedStackDouble ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
-static /*inline*/ StgStablePtr taggedStackStable ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
+
+/*static*/ /*inline*/ StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
+
+
+/*static*/ /*inline*/ StgFloat taggedStackFloat ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
+/*static*/ /*inline*/ StgDouble taggedStackDouble ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
+/*static*/ /*inline*/ StgStablePtr taggedStackStable ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
/* --------------------------------------------------------------------------
printPtr(stgCast(StgPtr,Su->updatee));
fprintf(stderr, " with ");
printObj(obj);
- fprintf(stderr,"\nSp = %p\tSu = %p\n", Sp, Su);
+ fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su);
);
#ifndef LAZY_BLACKHOLING
ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
{
StgCatchFrame* fp;
/* ToDo: stack check! */
- Sp -= sizeofW(StgCatchFrame*); /* ToDo: this can't be right */
+ Sp -= sizeofW(StgCatchFrame);
fp = stgCast(StgCatchFrame*,Sp);
SET_HDR(fp,&catch_frame_info,CCCS);
fp->handler = handler;
{
StgSeqFrame* fp;
/* ToDo: stack check! */
- Sp -= sizeofW(StgSeqFrame*); /* ToDo: this can't be right */
+ Sp -= sizeofW(StgSeqFrame);
fp = stgCast(StgSeqFrame*,Sp);
SET_HDR(fp,&seq_frame_info,CCCS);
fp->link = Su;
StgClosure *raise_closure;
/* This closure represents the expression 'raise# E' where E
- * is the exception raise. It is used to overwrite all the
+ * is the exception raised. It is used to overwrite all the
* thunks which are currently under evaluataion.
*/
raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
Sp += sizeofW(StgCatchFrame); /* Pop */
PushCPtr(errObj);
return handler;
- }
+ }
case STOP_FRAME:
- barf("raiseError: STOP_FRAME");
+ barf("raiseError: uncaught exception: STOP_FRAME");
default:
barf("raiseError: weird activation record");
}
StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size));
SET_INFO(errObj,&raise_info);
errObj->payload[0] = errObj;
-
+fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg);
#if 0
belch(msg);
#else
* iterations.
*/
char enterCount = 0;
+ int enterCountI = 0;
enterLoop:
/* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */
ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su));
-#if 0
+#if DEBUG
IF_DEBUG(evaluator,
+ fprintf(stderr,
+ "\n---------------------------------------------------------------\n");
+ fprintf(stderr,"(%d) Entering: ",enterCountI++); printObj(obj);
fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);
+ fprintf(stderr, "\n" );
printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
- fprintf(stderr,"Entering: "); printObj(obj);
- );
+ fprintf(stderr, "\n\n");
+ );
#endif
#if 0
IF_DEBUG(sanity,
#endif
while (1) {
ASSERT(pc < bco->n_instrs);
+ if (0 /*enterCountI > 2*/ ) {
+ fprintf(stderr, "\n\n-----------------\n" );
+ printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
+ fprintf(stderr, "\n");
+ }
IF_DEBUG(evaluator,
fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc);
disInstr(bco,pc);
}
/* now deal with "update frame" */
- /* as an optimisation, we process all on top of stack instead of just the top one */
+ /* as an optimisation, we process all on top of stack */
+ /* instead of just the top one */
ASSERT(Sp==(P_)Su);
do {
switch (get_itbl(Su)->type) {
case CATCH_FRAME:
PopCatchFrame();
+ ASSERT(Sp != (P_)Su);
+ /* We hit a CATCH frame during an arg satisfaction
+ * check. So now return to bco_info which is under
+ * the CATCH frame. The following code is copied
+ * from a case RET_BCO further down.
+ * (The reason why we're here is that something of
+ * functional type has been evaluated as a possibly
+ * exception-throwing computation, but has not thrown
+ * any exception, and is now returning to the
+ * algebraic-case-continuation which forced the
+ * evaluation in the first place.)
+ */
+ {
+ StgClosure* ret;
+ PopPtr();
+ ret = PopCPtr();
+ PushPtr((P_)obj);
+ obj = ret;
+ goto enterLoop;
+ }
+ break;
+
break;
case UPDATE_FRAME:
PopUpdateFrame(obj);
return ThreadFinished;
case SEQ_FRAME:
PopSeqFrame();
+ ASSERT(Sp != (P_)Su);
+ /* We hit a SEQ frame during an arg satisfaction check.
+ * So now return to bco_info which is under the
+ * SEQ frame. The following code is copied from a
+ * case RET_BCO further down. (The reason why we're
+ * here is that something of functional type has
+ * been seq-d on, and we're now returning to the
+ * algebraic-case-continuation which forced the
+ * evaluation in the first place.)
+ */
+ {
+ StgClosure* ret;
+ PopPtr();
+ ret = PopCPtr();
+ PushPtr((P_)obj);
+ obj = ret;
+ goto enterLoop;
+ }
break;
default:
barf("Invalid update frame during argcheck");
case i_INTERNAL_ERROR1:
barf("INTERNAL_ERROR1 at %p:%d",bco,pc-1);
+ case i_pushseqframe:
+ {
+ StgClosure* c = PopCPtr();
+ PushSeqFrame();
+ PushCPtr(c);
+ break;
+ }
+ case i_pushcatchframe:
+ {
+ StgClosure* e = PopCPtr();
+ StgClosure* h = PopCPtr();
+ PushCatchFrame(h);
+ PushCPtr(e);
+ break;
+ }
+
case i_gtChar: OP_CC_B(x>y); break;
case i_geChar: OP_CC_B(x>=y); break;
case i_eqChar: OP_CC_B(x==y); break;
case i_orInt: OP_II_I(x|y); break;
case i_xorInt: OP_II_I(x^y); break;
case i_notInt: OP_I_I(~x); break;
- case i_shiftLInt: OP_IW_I(x<<y); break;
- case i_shiftRAInt: OP_IW_I(x>>y); break; /* ToDo */
- case i_shiftRLInt: OP_IW_I(x>>y); break; /* ToDo */
+ case i_shiftLInt: OP_II_I(x<<y); break;
+ case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
+ case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
#ifdef PROVIDE_INT64
case i_gtInt64: OP_zz_B(x>y); break;
switch (bcoInstr(bco,pc++)) {
case i_INTERNAL_ERROR2:
barf("INTERNAL_ERROR2 at %p:%d",bco,pc-1);
- case i_catch: /* catch#{e,h} */
- {
- StgClosure* h;
- obj = PopCPtr();
- h = PopCPtr();
-
- /* catch suffers the same problem as takeMVar:
- * it tries to do control flow even if it isn't
- * the last instruction in the BCO.
- * This can leave a mess on the stack if the
- * last instructions are anything important
- * like SLIDE. Our vile hack depends on the
- * fact that with the current code generator,
- * we know exactly that i_catch is followed
- * by code that drops 2 variables off the
- * stack.
- * What a vile hack!
- */
- Sp += 2;
- PushCatchFrame(h);
- goto enterLoop;
- }
case i_raise: /* raise#{err} */
{
StgClosure* err = PopCPtr();
obj = raiseAnError(err);
goto enterLoop;
}
- case i_force: /* force#{x} (evaluate x, primreturn nothing) */
- {
- StgClosure* x;
- obj = PopCPtr();
-
- /* force suffers the same problem as takeMVar:
- * it tries to do control flow even if it isn't
- * the last instruction in the BCO.
- * This can leave a mess on the stack if the
- * last instructions are anything important
- * like SLIDE. Our vile hack depends on the
- * fact that with the current code generator,
- * we know exactly that i_force is followed
- * by code that drops 1 variable off the stack.
- * What a vile hack!
- */
- Sp += 1;
-
- PushSeqFrame();
- goto enterLoop;
- }
#ifdef PROVIDE_ARRAY
case i_newRef:
{
SET_HDR(w, &WEAK_info, CCCS);
w->key = PopCPtr();
w->value = PopCPtr();
- w->finalizer = PopCPtr();
+ w->finaliser = PopCPtr();
w->link = weak_ptr_list;
weak_ptr_list = w;
IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
PushTaggedAddr(*((void**)arg));
return ARG_SIZE(ADDR_TAG);
#endif
+#ifdef PROVIDE_STABLE
case STABLE_REP:
PushTaggedStablePtr(*((StgStablePtr*)arg));
return ARG_SIZE(STABLE_TAG);
+#endif
case FOREIGN_REP:
/* Not allowed in this direction - you have to
* call makeForeignPtr explicitly
*((void**)res) = PopTaggedAddr();
return ARG_SIZE(ADDR_TAG);
#endif
+#ifdef PROVIDE_STABLE
case STABLE_REP:
*((StgStablePtr*)res) = PopTaggedStablePtr();
return ARG_SIZE(STABLE_TAG);
+#endif
case FOREIGN_REP:
{
StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
-/* -*- mode: hugs-c; -*- */
+
/* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.3 1999/02/05 16:02:40 simonm Exp $
+ * $Id: ForeignCall.c,v 1.4 1999/03/01 14:47:06 sewardj Exp $
*
* (c) The GHC Team 1994-1999.
*
#endif
}
+#if 0
/* By experiment on an x86 box, we found that gcc's
* __builtin_apply(fun,as,size) expects *as to look like this:
* as[0] = &first arg = &as[1]
}
}
}
+#endif
+
+
+
+
+#if 1
+/* HACK alert (red alert) */
+extern StgInt PopTaggedInt ( void ) ;
+extern void PushTaggedInt ( StgInt );
+extern StgPtr PopPtr ( void );
+
+int seqNr = 0;
+#define IF(sss) if (strcmp(sss,cdesc)==0)
+void ccall( CFunDescriptor* d, void (*fun)(void) )
+{
+ int i;
+ char cdesc[100];
+ strcpy(cdesc, d->result_tys);
+ strcat(cdesc, ":");
+ strcat(cdesc, d->arg_tys);
+ for (i = 0; cdesc[i] != 0; i++) {
+ switch (cdesc[i]) {
+ case 'x': cdesc[i] = 'A'; break;
+ default: break;
+ }
+ }
+
+ //fprintf(stderr, "ccall: %d cdesc = `%s'\n", seqNr++, cdesc);
+
+ IF(":") { ((void(*)(void))(fun))(); return; };
+ IF(":I") { int a1=PopTaggedInt(); ((void(*)(int))(fun))(a1); return;};
+ IF("I:") { int r= ((int(*)(void))(fun))(); PushTaggedInt(r); return;};
+ IF(":II") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
+ ((void(*)(int,int))(fun))(a1,a2); return; };
+ IF("I:I") { int a1=PopTaggedInt();
+ int r=((int(*)(int))(fun))(a1); PushTaggedInt(r); return; };
+ IF("I:II") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
+ int r=((int(*)(int,int))(fun))(a1,a2); PushTaggedInt(r); return; };
+ IF("I:III") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); int a3=PopTaggedInt();
+ int r=((int(*)(int,int,int))(fun))(a1,a2,a3); PushTaggedInt(r); return; };
+
+ //IF("I:AI") { void* a1=(void*)PopPtr(); int a2=PopTaggedInt();
+ // int r=((int(*)(void*,int))(fun))(a1,a2); PushTaggedInt(r); return; };
+
+fprintf(stderr,"panic: ccall cdesc `%s' not implemented\n", cdesc );
+ exit(1);
+
+
+fprintf(stderr,
+ "ccall: arg_tys %s arg_size %d result_tys %s result_size %d\n",
+ d->arg_tys, d->arg_size, d->result_tys, d->result_size );
+}
+#undef IF
+#endif
+
+
+
+
+
CFunDescriptor* mkDescriptor( char* as, char* rs )
{
-/* -*- mode: hugs-c; -*- */
+
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.6 1999/02/05 16:02:46 simonm Exp $
+ * $Id: Printer.c,v 1.7 1999/03/01 14:47:06 sewardj Exp $
*
* Copyright (c) 1994-1999.
*
* Printer
* ------------------------------------------------------------------------*/
+
+extern void* itblNames[];
+extern int nItblNames;
+char* lookupHugsItblName ( void* v )
+{
+ int i;
+ for (i = 0; i < nItblNames; i += 2)
+ if (itblNames[i] == v) return itblNames[i+1];
+ return NULL;
+}
+
extern void printPtr( StgPtr p )
{
+ char* str;
const char *raw;
if (lookupGHCName( p, &raw )) {
printZcoded(raw);
} else if ((raw = lookupHugsName(p)) != 0) {
fprintf(stderr, "%s", raw);
#endif
+ } else if ((str = lookupHugsItblName(p)) != 0) {
+ fprintf(stderr, "%p=%s", p, str);
} else {
fprintf(stderr, "%p", p);
}
break;
}
default:
- barf("printClosure %d",get_itbl(obj)->type);
+ //barf("printClosure %d",get_itbl(obj)->type);
+ fprintf(stderr, "*** printClosure: unknown type %d ****\n",get_itbl(obj)->type );
return;
}
}
#endif
} else {
+ StgClosure* c = (StgClosure*)(*sp);
printPtr((StgPtr)*sp);
- fprintf(stderr,"\n");
+ if (c == &ret_bco_info) {
+ fprintf(stderr, "\t\t");
+ fprintf(stderr, "ret_bco_info\n" );
+ } else
+ if (IS_HUGS_CONSTR_INFO(GET_INFO(c))) {
+ fprintf(stderr, "\t\t\t");
+ fprintf(stderr, "ConstrInfoTable\n" );
+ } else
+ if (get_itbl(c)->type == BCO) {
+ fprintf(stderr, "\t\t\t");
+ fprintf(stderr, "BCO(...)\n");
+ }
+ else {
+ fprintf(stderr, "\t\t\t");
+ printClosure ( (StgClosure*)(*sp));
+ }
sp += 1;
}
return sp;
projects / ghc-hetmet.git / commitdiff