From: sewardj Date: Mon, 1 Mar 1999 14:47:09 +0000 (+0000) Subject: [project @ 1999-03-01 14:46:42 by sewardj] X-Git-Tag: Approximately_9120_patches~6482 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8931116063aaf06ed2759e2b2ca2e554cfa7124f;p=ghc-hetmet.git [project @ 1999-03-01 14:46:42 by sewardj] Mods to make STG-hugs able to compile and run small examples. This commit also includes proper implementations of seq, raise and catch. --- diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h index 98c1479..1d50fac 100644 --- a/ghc/includes/Assembler.h +++ b/ghc/includes/Assembler.h @@ -1,6 +1,6 @@ -/* -*- 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. * @@ -139,10 +139,10 @@ typedef enum { * 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 ); @@ -180,7 +180,7 @@ extern void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ); 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 ); @@ -233,6 +233,11 @@ extern const AsmPrim* asmFindPrimop ( AsmInstr prefix, AsmInstr op ); 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 * ------------------------------------------------------------------------*/ diff --git a/ghc/includes/options.h b/ghc/includes/options.h index ee54649..e640dec 100644 --- a/ghc/includes/options.h +++ b/ghc/includes/options.h @@ -13,8 +13,8 @@ * 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 $ * ------------------------------------------------------------------------*/ @@ -104,7 +104,7 @@ #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 @@ -124,7 +124,7 @@ #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 @@ -189,16 +189,16 @@ */ #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 @@ -229,12 +229,12 @@ /* 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 @@ -250,13 +250,13 @@ /* 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. diff --git a/ghc/interpreter/backend.h b/ghc/interpreter/backend.h index 1b4a6e2..b314382 100644 --- a/ghc/interpreter/backend.h +++ b/ghc/interpreter/backend.h @@ -7,8 +7,8 @@ * 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 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -20,8 +20,8 @@ * * 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,[]) diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index f396cdd..5ef8e28 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -7,8 +7,8 @@ * 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" @@ -19,6 +19,8 @@ #include "Assembler.h" #include "link.h" +#include "Rts.h" /* IF_DEBUG */ +#include "RtsFlags.h" /* -------------------------------------------------------------------------- * Local function prototypes: @@ -40,7 +42,7 @@ static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e ); 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 ); @@ -103,7 +105,11 @@ static void cgBind( AsmBCO bco, 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)) { @@ -169,14 +175,14 @@ static Void pushAtom( AsmBCO bco, StgAtom e ) 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); @@ -191,7 +197,7 @@ static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts ) 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); @@ -223,19 +229,22 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e ) } } +#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); */ @@ -247,7 +256,7 @@ static AsmBCO cgLambda( StgExpr e ) static AsmBCO cgRhs( StgRhs rhs ) { - AsmBCO bco = asmBeginBCO( ); + AsmBCO bco = asmBeginBCO(rhs ); AsmSp root = asmBeginArgCheck(bco); asmEndArgCheck(bco,root); @@ -259,8 +268,10 @@ static AsmBCO cgRhs( StgRhs rhs ) return bco; } + static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) { + //printf("cgExpr:");ppStgExpr(e);printf("\n"); switch (whatIs(e)) { case LETREC: { @@ -294,7 +305,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) /* 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)) { @@ -302,7 +313,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) 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); } @@ -341,7 +352,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) 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; @@ -376,7 +387,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) 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(); */ @@ -388,6 +399,9 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) } } +void* itblNames[1000]; +int nItblNames = 0; + /* allocate space for top level variable * any change requires a corresponding change in 'build'. */ @@ -404,7 +418,23 @@ static Void alloc( AsmBCO bco, StgVar v ) 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; } @@ -424,6 +454,7 @@ static Void build( AsmBCO bco, StgVar v ) { StgRhs rhs = stgVarBody(v); assert(isStgVar(v)); + switch (whatIs(rhs)) { case STGCON: { @@ -433,7 +464,7 @@ static Void build( AsmBCO bco, StgVar v ) 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; @@ -449,12 +480,12 @@ static Void build( AsmBCO bco, StgVar v ) && 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); } @@ -498,6 +529,7 @@ static Void build( AsmBCO bco, StgVar v ) * 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)) { @@ -506,6 +538,8 @@ static void cgAddVar( AsmObject obj, StgAtom v ) assert(isStgVar(v)); asmAddPtr(obj,getObj(v)); } +#endif + /* allocate AsmObject for top level variables * any change requires a corresponding change in endTop @@ -518,12 +552,12 @@ static void beginTop( StgVar v ) 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()); @@ -534,7 +568,7 @@ static void beginTop( StgVar v ) static void endTop( StgVar v ) { StgRhs rhs = stgVarBody(v); - ppStgRhs(rhs); + //ppStgRhs(rhs); switch (whatIs(rhs)) { case STGCON: { @@ -573,7 +607,7 @@ static void endTop( StgVar v ) /* 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)); @@ -592,16 +626,48 @@ static void endTop( StgVar v ) 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); } /* -------------------------------------------------------------------------- diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index cc9b536..a0481f0 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -10,8 +10,8 @@ * 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" @@ -24,8 +24,6 @@ #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 @@ -80,26 +78,9 @@ static Bool local isExtDiscr Args((Cell)); 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 @@ -1487,14 +1468,15 @@ Void evalExp() { /* compile and run input expression */ * 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? */ @@ -1535,7 +1517,7 @@ static List local addStgVar( List binds, Pair bind ) 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*/ @@ -1548,8 +1530,17 @@ static List local addStgVar( List binds, Pair bind ) 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; @@ -1593,6 +1584,7 @@ Void compileDefns() { /* compile script definitions */ binds = addGlobals(binds); #if USE_HUGS_OPTIMIZER mapProc(optimiseBind,binds); +#error optimiser #endif stgCGBinds(binds); @@ -1605,6 +1597,20 @@ Pair bind; { 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))); } @@ -1614,6 +1620,19 @@ Name n; { /* generated function */ 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); @@ -1634,32 +1653,6 @@ Pair p; { /* Should be merged with genDefns, */ } -#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: * ------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 2f3ccc6..0f59e3c 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -7,8 +7,8 @@ * 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 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -17,7 +17,7 @@ extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/ extern Module modulePrelude; -extern Module modulePreludeHugs; +//extern Module modulePreludeHugs; /* -------------------------------------------------------------------------- * Primitive constructor functions @@ -319,7 +319,7 @@ extern Int InstrAt Args((Addr)); 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)); @@ -532,3 +532,30 @@ extern Void linkControl 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]) */ diff --git a/ghc/interpreter/derive.c b/ghc/interpreter/derive.c index e6698c2..cb2c925 100644 --- a/ghc/interpreter/derive.c +++ b/ghc/interpreter/derive.c @@ -7,8 +7,8 @@ * 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" @@ -16,6 +16,8 @@ #include "backend.h" #include "connect.h" #include "errors.h" +#include "Assembler.h" +#include "link.h" static Cell varTrue; static Cell varFalse; @@ -30,9 +32,9 @@ static Cell varInRange; 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 @@ -131,6 +133,46 @@ Cell r; { 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 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")); @@ -888,16 +1104,16 @@ Int what; { 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")); @@ -954,9 +1170,9 @@ Int what; { mark(varRange); mark(varIndex); mark(varMult); - mark(varPlus); + mark(qvarPlus); mark(varMap); - mark(varMinus); + mark(qvarMinus); mark(varError); #endif #if DERIVE_ENUM diff --git a/ghc/interpreter/dynamic.c b/ghc/interpreter/dynamic.c index 843aa92..57653d5 100644 --- a/ghc/interpreter/dynamic.c +++ b/ghc/interpreter/dynamic.c @@ -7,8 +7,8 @@ * 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" @@ -21,6 +21,7 @@ #include #include +#if 0 /* apparently unused */ ObjectFile loadLibrary(fn) String fn; { return dlopen(fn,RTLD_NOW | RTLD_GLOBAL); @@ -31,6 +32,7 @@ ObjectFile file; String symbol; { return dlsym(file,symbol); } +#endif void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */ String dll; diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index f456db3..08dfe07 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -8,8 +8,8 @@ * 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 @@ -105,7 +105,6 @@ static Bool printing = FALSE; /* TRUE => currently printing value*/ 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 */ @@ -124,7 +123,7 @@ static String currProject = 0; /* Name of current project file */ 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 */ @@ -145,7 +144,6 @@ Main main Args((Int, String [])); /* now every func has a prototype */ Main main(argc,argv) int argc; char *argv[]; { - #ifdef HAVE_CONSOLE_H /* Macintosh port */ _ftype = 'TEXT'; _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */ @@ -179,6 +177,7 @@ char *argv[]; { interpreter(argc,argv); Printf("[Leaving Hugs]\n"); everybody(EXIT); + shutdownHaskell(); FlushStdout(); fflush(stderr); exit(0); @@ -219,7 +218,10 @@ String argv[]; { #endif /* USE_REGISTRY */ readOptions(fromEnv("HUGSFLAGS","")); - for (i=1; i (MAXPOSINT/1000)) { @@ -956,7 +954,7 @@ static Void local find() { /* edit file containing definition */ } 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); } @@ -966,7 +964,7 @@ Int line; { if (lastEdit) free(lastEdit); lastEdit = strCopy(fname); - lastLine = line; + lastEdLine = line; #if HUGS_FOR_WINDOWS DrawStatusLine(hWndMain); /* Redo status line */ #endif @@ -995,7 +993,6 @@ static Module local findEvalModule() { /*Module in which to eval expressions*/ static Void local evaluator() { /* evaluate expr and print value */ Type type, bd; Kinds ks = NIL; - Cell temp = NIL; setCurrModule(findEvalModule()); scriptFile = 0; @@ -1030,6 +1027,8 @@ static Void local evaluator() { /* evaluate expr and print value */ #ifdef WANT_TIMER updateTimers(); #endif + +#if 1 if (typeMatches(type,ap(typeIO,typeUnit))) { inputExpr = ap(nameRunIO,inputExpr); evalExp(); @@ -1043,15 +1042,30 @@ static Void local evaluator() { /* evaluate expr and print value */ 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,*/ @@ -1170,7 +1184,7 @@ Text t; { 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; @@ -1331,7 +1345,7 @@ Name nm; { 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); @@ -1745,9 +1759,9 @@ HugsStream *stream; { /* ----------------------------------------------------------------------- */ -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) @@ -1756,7 +1770,7 @@ Bool f; { } String hugsClearOutputBuffer() { - return bufferClear(&outputStream); + return bufferClear(&outputStreamH); } #ifdef HAVE_STDARG_H @@ -1766,7 +1780,7 @@ Void hugsPrintf(const char *fmt, ...) { if (!disableOutput) { vprintf(fmt, ap); } else { - vBufferedPrintf(&outputStream, fmt, ap); + vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); /* clean up */ } @@ -1779,7 +1793,7 @@ va_dcl { if (!disableOutput) { vprintf(fmt, ap); } else { - vBufferedPrintf(&outputStream, fmt, ap); + vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); /* clean up */ } @@ -1790,7 +1804,7 @@ int c; { if (!disableOutput) { putchar(c); } else { - bufferedPutchar(&outputStream, c); + bufferedPutchar(&outputStreamH, c); } } @@ -1814,7 +1828,7 @@ Void hugsFPrintf(FILE *fp, const char* fmt, ...) { if (!disableOutput) { vfprintf(fp, fmt, ap); } else { - vBufferedPrintf(&outputStream, fmt, ap); + vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); } @@ -1828,7 +1842,7 @@ va_dcl { if (!disableOutput) { vfprintf(fp, fmt, ap); } else { - vBufferedPrintf(&outputStream, fmt, ap); + vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); } @@ -1840,7 +1854,7 @@ FILE* fp; { if (!disableOutput) { putc(c,fp); } else { - bufferedPutchar(&outputStream, c); + bufferedPutchar(&outputStreamH, c); } } diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index 5294b35..3d8c30c 100644 --- a/ghc/interpreter/input.c +++ b/ghc/interpreter/input.c @@ -8,8 +8,8 @@ * 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" @@ -118,7 +118,7 @@ static Text textWildcard; 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 */ @@ -767,11 +767,6 @@ static Cell local readNumber() { /* read numeric constant */ } endToken(); -#ifndef HAVE_LIBM - ERRMSG(row) "No floating point numbers in this implementation" - EEND; -#endif - return mkFloat(stringToFloat(tokenStr)); } diff --git a/ghc/interpreter/lift.c b/ghc/interpreter/lift.c index 4649901..ce2bb73 100644 --- a/ghc/interpreter/lift.c +++ b/ghc/interpreter/lift.c @@ -10,8 +10,8 @@ * 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" @@ -63,6 +63,7 @@ static inline Bool isTopLevel( StgVar v ) 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: @@ -106,6 +107,7 @@ static List liftLetBinds( List binds ) case STGCON: case STGAPP: #if LIFT_CONSTANTS +#error lift constants if (isNull(fvs)) { StgVar v = mkStgVar(rhs,NONE); stgVarBody(bind) = mkStgLet(singleton(v),v); @@ -128,6 +130,7 @@ static List liftLetBinds( List binds ) 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); diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 79d2bc6..97dc222 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -7,8 +7,8 @@ * 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" @@ -20,191 +20,232 @@ #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)) */ + /* -------------------------------------------------------------------------- * * ------------------------------------------------------------------------*/ @@ -212,7 +253,7 @@ Name nameMkMVar; /* MVar# -> MVar */ 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 ) @@ -254,77 +295,78 @@ static Name predefinePrim ( 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); @@ -335,44 +377,67 @@ Void linkPreludeTC() { /* Hook to tycons and classes in */ #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 @@ -403,42 +468,55 @@ Void linkPreludeTC() { /* Hook to tycons and classes in */ } } -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)"), 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 +/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/link.h b/ghc/interpreter/link.h index 228e5b4..b5f0415 100644 --- a/ghc/interpreter/link.h +++ b/ghc/interpreter/link.h @@ -73,11 +73,11 @@ extern Type typeWord; 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; @@ -149,3 +149,14 @@ extern Cell predFractional; /* Fractional (mkOffset(0)) */ 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)) */ diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c index 7b5bbb2..146998a 100644 --- a/ghc/interpreter/machdep.c +++ b/ghc/interpreter/machdep.c @@ -12,8 +12,8 @@ * 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 @@ -233,7 +233,7 @@ static String local hugsdir Args((Void)); #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)); @@ -309,7 +309,7 @@ static String local hscriptDir() { /* directory containing ?? what Daan? */ } #endif - +#if 0 /* apparently unused */ static String local RealPath(s) /* Find absolute pathname of file */ String s; { #if HAVE__FULLPATH /* eg DOS */ @@ -324,6 +324,8 @@ String s; { #endif return path; } +#endif + static int local pathCmp(p1,p2) /* Compare paths after normalisation */ String p1; diff --git a/ghc/interpreter/nHandle.c b/ghc/interpreter/nHandle.c new file mode 100644 index 0000000..1e601b9 --- /dev/null +++ b/ghc/interpreter/nHandle.c @@ -0,0 +1,71 @@ + +/* 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 +#include +#include +#include + +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; +} diff --git a/ghc/interpreter/output.c b/ghc/interpreter/output.c index b5ced32..8cf7aa9 100644 --- a/ghc/interpreter/output.c +++ b/ghc/interpreter/output.c @@ -9,8 +9,8 @@ * 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" @@ -19,18 +19,12 @@ #include "errors.h" #include -/*#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)); @@ -43,10 +37,7 @@ static Void local putInfix Args((Int,Text,Syntax,Cell,Cell)); 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)); @@ -63,39 +54,40 @@ static Void local putKinds Args((Kinds)); * 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): * ------------------------------------------------------------------------*/ @@ -557,11 +549,12 @@ Cell e; { /* args not yet printed ... */ 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('('); @@ -574,7 +567,7 @@ static Void local unlexOp(t) /* print text as operator name */ 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('`'); @@ -583,14 +576,14 @@ Text t; { /* alpha numeric symbols must be */ 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' */ @@ -604,7 +597,8 @@ Text t; { Char c = ' '; if ((lastWasSO && *ch=='H') || - (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch))) + (lastWasEsc && lastWasDigit + && isascii((int)(*ch)) && isdigit((int)(*ch)))) putStr("\\&"); lastWasEsc = (*ch=='\\'); diff --git a/ghc/interpreter/preds.c b/ghc/interpreter/preds.c index fc5eaa1..43d2f81 100644 --- a/ghc/interpreter/preds.c +++ b/ghc/interpreter/preds.c @@ -8,8 +8,8 @@ * 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 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -478,13 +478,14 @@ Int o; { return TRUE; } deRef(tyv,t,o); - if (tyv) + if (tyv) { if (tyv->offs == FIXED_TYVAR) { numFixedVars++; return FALSE; } else return TRUE; + } else return FALSE; } diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 2cf01cd..afc4696 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -8,14 +8,15 @@ * 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" @@ -80,7 +81,6 @@ static Type local depCompType Args((Int,List,Type)); 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)); @@ -107,21 +107,12 @@ static Cell local copyAdj Args((Cell,Int,Int)); 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)); @@ -1060,8 +1051,6 @@ Name c; { /* CDICTS parameters */ 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 */ @@ -1554,6 +1543,7 @@ Class c; { /* and other parts of class struct.*/ List ns = NIL; /* List of names */ Int mno; /* Member function number */ +//printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) ); for (mno=0; mno 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)) { @@ -2467,7 +2462,7 @@ Inst in; { 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; @@ -4102,8 +4097,12 @@ List bs; { /* top level, reporting on progress*/ 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++)); @@ -4246,6 +4245,9 @@ static Void local depClassBindings(bs) /* dependency analysis on list of */ 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... */ } } @@ -4295,6 +4297,8 @@ Cell g; { /* expression */ 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 : @@ -4396,7 +4400,7 @@ Cell e; { EEND; #endif - default : internal("depExpr"); + default : fprintf(stderr,"whatIs(e) == %d\n",whatIs(e));internal("depExpr"); } return e; } @@ -4826,6 +4830,8 @@ Void checkDefns() { /* Top level static analysis */ #endif mapProc(allNoPrevDef,valDefns); /* check against previous defns */ + linkPreludeNames(); + mapProc(checkForeignImport,foreignImports); /* check foreign imports */ mapProc(checkForeignExport,foreignExports); /* check foreign exports */ foreignImports = NIL; diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c index 032e014..54f00f6 100644 --- a/ghc/interpreter/stg.c +++ b/ghc/interpreter/stg.c @@ -7,8 +7,8 @@ * 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" @@ -79,7 +79,7 @@ StgExpr makeStgLambda( List args, StgExpr body ) 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); @@ -119,6 +119,7 @@ StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 ) Bool isStgVar(e) StgRhs e; { + //printf("{%d %d %d} ", namePMFail, e, whatIs(e) ); switch (whatIs(e)) { case STGVAR: return TRUE; @@ -159,8 +160,8 @@ StgVar mkStgVar( StgRhs rhs, Cell info ) * 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 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -168,9 +169,6 @@ StgVar mkStgVar( StgRhs rhs, Cell info ) * ------------------------------------------------------------------------*/ 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)); @@ -182,45 +180,6 @@ static Void local putStgRhs Args((StgRhs)); 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 @@ -234,58 +193,13 @@ Int n; { } } -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) { @@ -433,7 +347,7 @@ List binds; { static Void putStgAlts( Int left, List alts ) { - if (length(alts) == 1) { + if (length(alts) == 1) { StgCaseAlt alt = hd(alts); putStr("{ "); putStgPat(stgCaseAltPat(alt)); @@ -447,7 +361,11 @@ static Void putStgAlts( Int left, List alts ) StgCaseAlt alt = hd(alts); pIndent(left+2); putStgPat(stgCaseAltPat(alt)); - putStr(" -> "); + + //putStr(" -> "); + putStr(" ->\n"); + pIndent(left+4); + putStgExpr(stgCaseAltBody(alt)); putStr("\n"); } @@ -532,8 +450,10 @@ Void putStgExpr( StgExpr e ) /* pretty print expr */ 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); } } @@ -564,7 +484,7 @@ static void endStgPP( FILE* fp ); static void beginStgPP( FILE* fp ) { outputStream = fp; - putChr('\n'); + //putChr('\n'); outColumn = 0; } @@ -585,18 +505,18 @@ StgVar b; 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); } @@ -604,7 +524,7 @@ Void ppStgExpr( StgExpr e ) Void ppStgRhs( StgRhs rhs ) { - if (debugCode) { + if (1 /*debugCode*/ ) { beginStgPP(stdout); putStgRhs(rhs); endStgPP(stdout); diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 4f84aa1..5893263 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -8,8 +8,8 @@ * 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" @@ -30,17 +30,13 @@ static Int local saveText Args((Text)); #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 */ @@ -260,16 +256,11 @@ Text t; { * 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; @@ -278,30 +269,28 @@ Text t; { 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 @@ -310,14 +299,6 @@ Tycon tc; { 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"); @@ -408,14 +389,14 @@ List ts; { /* Null pattern matches every tycon*/ #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" @@ -432,29 +413,25 @@ Cell parent; { 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 @@ -463,14 +440,6 @@ Name nm; { /* no clash is caused */ 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)) @@ -527,8 +496,8 @@ Cell id; { /* in name table */ * 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 */ @@ -540,6 +509,20 @@ 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; { @@ -708,7 +691,7 @@ Text t; { for (cs=classes; nonNull(cs); cs=tl(cs)) { cl=hd(cs); if (cclass(cl).text==t) - return cl; + return cl; } return NIL; } @@ -922,12 +905,14 @@ Cell c; { 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) @@ -942,15 +927,17 @@ Text 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=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) ? @@ -2076,6 +2072,12 @@ List ys; { 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; @@ -2793,9 +2795,10 @@ Int what; { #endif tyconHw = TYCMIN; +#if 0 for (i=0; i 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); @@ -651,13 +571,16 @@ static Cell foreignResultTy( Type t ) 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! */ @@ -783,7 +706,7 @@ static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e ) 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)) { @@ -823,13 +746,16 @@ String r_reps; { /* 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); @@ -839,19 +765,24 @@ String r_reps; { 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)) + ); } } @@ -883,7 +814,7 @@ Name n; { * }}}) * in primMkIO m * :: - * Addr -> (Int -> Float -> IO (Char,Addr) + * Addr -> (Int -> Float -> IO (Char,Addr)) */ Void implementForeignImport( Name n ) { @@ -916,8 +847,8 @@ 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; @@ -926,7 +857,8 @@ Void implementForeignImport( Name n ) 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\"", @@ -934,10 +866,10 @@ Void implementForeignImport( Name n ) 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 */ } } @@ -957,7 +889,7 @@ Int size; { 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 */ } } diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index 40b7c03..a50db82 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -8,14 +8,15 @@ * 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 */ @@ -31,78 +32,6 @@ 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: @@ -177,26 +106,7 @@ static Bool local equalTypes Args((Type,Type)); 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: @@ -650,7 +560,9 @@ Cell e; { 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 */ @@ -817,6 +729,8 @@ Cell e; { /* requires polymorphism, qualified*/ Cell p = NIL; Cell a = e; Int i; + //print(h,1000); + //printf("\n"); switch (whatIs(h)) { case NAME : typeIs = name(h).type; @@ -847,8 +761,12 @@ Cell e; { /* requires polymorphism, qualified*/ 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. */ @@ -1311,7 +1229,8 @@ Cell e; { /* bizarre manner for the benefit */ 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; } @@ -1740,7 +1659,7 @@ Class c; { /* defaults for class c */ 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); @@ -1754,7 +1673,7 @@ Class c; { /* defaults for class c */ 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); @@ -1815,6 +1734,7 @@ Class c; { /* defaults for class c */ args = tl(args); genDefns = cons(hd(mems),genDefns); } +//printf("done\n" ); } static Void local typeInstDefn(in) /* Type check implementations of */ @@ -1956,11 +1876,11 @@ Int beta; { 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 @@ -2011,7 +1931,7 @@ Int beta; { 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 @@ -2019,6 +1939,7 @@ Int beta; { tooGeneral(line,mem,rt,t); if (nonNull(preds)) cantEstablish(line,wh,mem,t,ps); +//printf("done\n" ); } /* -------------------------------------------------------------------------- @@ -2330,6 +2251,11 @@ Void typeCheckDefns() { /* Type check top level bindings */ 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; @@ -2484,39 +2410,12 @@ Name s; { /* particular selector, s. */ 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 ) { @@ -2624,7 +2523,7 @@ Char k; { case BETA_REP: return mkBetaVar(); /* polymorphic */ case GAMMA_REP: - return mkGammaVar(); /* polymorphic */ + return mkGammaVar(); /* polymorphic */ default: printf("Kind: '%c'\n",k); internal("basicType"); @@ -2689,7 +2588,7 @@ Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds ) } /* forall a1 .. am. TC a1 ... am -> Int */ -static Type conToTagType(t) +Type conToTagType(t) Tycon t; { Type ty = t; List tvars = NIL; @@ -2707,7 +2606,7 @@ Tycon t; { } /* forall a1 .. am. Int -> TC a1 ... am */ -static Type tagToConType(t) +Type tagToConType(t) Tycon t; { Type ty = t; List tvars = NIL; @@ -2765,7 +2664,6 @@ Int what; { dummyVar = inventVar(); #if !IGNORE_MODULES - modulePrelude = newModule(textPrelude); setCurrModule(modulePrelude); #endif diff --git a/ghc/interpreter/version.h b/ghc/interpreter/version.h index e87c1e2..5345d73 100644 --- a/ghc/interpreter/version.h +++ b/ghc/interpreter/version.h @@ -13,6 +13,6 @@ #if MAJOR_RELEASE #define HUGS_VERSION "January 1998 " #else -#define HUGS_VERSION "STG prototype" +#define HUGS_VERSION "STG-98 proto " #endif diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index f1e71a1..db7b4b1 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -1,10 +1,12 @@ -/* -*- 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. @@ -143,7 +145,8 @@ struct AsmCAF_ { struct AsmBCO_ { struct AsmObject_ object; /* must be first in struct */ - + + int /*StgExpr*/ stgexpr; Instrs is; NonPtrs nps; @@ -201,7 +204,7 @@ static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference ) /* 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")); } } @@ -234,11 +237,19 @@ static void asmEndObject( AsmObject obj, StgClosure* c ) 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 ) @@ -357,7 +368,7 @@ void asmEndCAF( AsmCAF caf, AsmBCO body ) asmEndObject(&caf->object,c); } -AsmBCO asmBeginBCO( void ) +AsmBCO asmBeginBCO( int /*StgExpr*/ e ) { AsmBCO bco = malloc(sizeof(struct AsmBCO_)); if (bco == NULL) { @@ -367,6 +378,7 @@ AsmBCO asmBeginBCO( void ) initInstrs(&bco->is); initNonPtrs(&bco->nps); + bco->stgexpr = e; bco->max_sp = bco->sp = 0; bco->max_hp = bco->hp = 0; return bco; @@ -388,6 +400,7 @@ void asmEndBCO( AsmBCO 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); { @@ -430,6 +443,7 @@ static void asmWord( AsmBCO bco, StgWord i ) { \ 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]); \ @@ -712,10 +726,11 @@ AsmVar asmUnbox( AsmBCO bco, AsmRep rep ) 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); } @@ -889,9 +904,9 @@ AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr ) 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; } @@ -901,6 +916,7 @@ void asmEndContinuation ( AsmBCO bco ) asmEndBCO(bco); } + /* -------------------------------------------------------------------------- * Branches * ------------------------------------------------------------------------*/ @@ -1005,9 +1021,9 @@ const AsmPrim asmPrimOps[] = { , { "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 */ @@ -1093,7 +1109,9 @@ const AsmPrim asmPrimOps[] = { #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 } @@ -1107,7 +1125,9 @@ const AsmPrim asmPrimOps[] = { #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 } @@ -1121,7 +1141,9 @@ const AsmPrim asmPrimOps[] = { #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 } @@ -1142,8 +1164,10 @@ const AsmPrim asmPrimOps[] = { , { "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 } @@ -1252,11 +1276,11 @@ const AsmPrim asmPrimOps[] = { /* 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 */ @@ -1367,6 +1391,7 @@ const AsmPrim asmPrimOps[] = { 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; @@ -1390,6 +1415,57 @@ const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) } /* -------------------------------------------------------------------------- + * 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 * ------------------------------------------------------------------------*/ @@ -1412,10 +1488,10 @@ AsmSp asmBeginPack( AsmBCO bco ) 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; diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index daf3a9e..dea89e0 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ -/* -*- 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 * @@ -13,7 +13,7 @@ * * 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. @@ -53,7 +53,6 @@ typedef enum , i_RETADDR , i_VOID - , i_RETURN_GENERIC , i_VAR_INT @@ -121,6 +120,9 @@ typedef enum typedef enum { i_INTERNAL_ERROR1 /* Instruction 0 raises an internal error */ + , i_pushseqframe + , i_pushcatchframe + /* Char# operations */ , i_gtChar , i_geChar @@ -415,8 +417,6 @@ typedef enum { i_INTERNAL_ERROR2 /* Instruction 0 raises an internal error */ , i_raise - , i_catch - , i_force #ifdef PROVIDE_ARRAY /* Ref operations */ diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index 65ef9f4..63de39d 100644 --- a/ghc/rts/Disassembler.c +++ b/ghc/rts/Disassembler.c @@ -1,11 +1,12 @@ -/* -*- 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" @@ -115,7 +116,9 @@ static InstrPtr disConstAddr ( StgBCO *bco, InstrPtr pc, char* i ) 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; } @@ -180,7 +183,6 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) case i_VOID: return disNone(bco,pc,"VOID"); - case i_RETURN_GENERIC: return disNone(bco,pc,"RETURN_GENERIC"); @@ -287,6 +289,10 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) 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); @@ -307,6 +313,8 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) 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); @@ -332,6 +340,12 @@ void disassemble( StgBCO *bco, char* prefix ) 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 */ diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index a6d9bc0..822b52d 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -1,11 +1,12 @@ /* ----------------------------------------------------------------------------- - * $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" @@ -104,7 +105,7 @@ void defaultsHook (void) #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 ) { @@ -113,85 +114,87 @@ 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); @@ -202,7 +205,7 @@ static /*inline*/ void PushTaggedInteger ( mpz_ptr x ) 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)); @@ -212,84 +215,89 @@ static /*inline*/ void PushTaggedInteger ( mpz_ptr x ) } #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); } /* -------------------------------------------------------------------------- @@ -340,7 +348,7 @@ static /*inline*/ void PopUpdateFrame( StgClosure* obj ) 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 @@ -365,7 +373,7 @@ static /*inline*/ void PushCatchFrame( StgClosure* handler ) { 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; @@ -385,7 +393,7 @@ static /*inline*/ void PushSeqFrame( void ) { 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; @@ -404,7 +412,7 @@ static /*inline*/ StgClosure* raiseAnError( StgClosure* errObj ) 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); @@ -429,9 +437,9 @@ static /*inline*/ StgClosure* raiseAnError( StgClosure* errObj ) 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"); } @@ -449,7 +457,7 @@ static StgClosure* raisePrim(char* msg) 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 @@ -1048,15 +1056,20 @@ StgThreadReturnCode enter( StgClosure* obj ) * 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, @@ -1097,6 +1110,11 @@ enterLoop: #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); @@ -1161,12 +1179,35 @@ enterLoop: } /* 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); @@ -1176,6 +1217,24 @@ enterLoop: 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"); @@ -1629,6 +1688,22 @@ enterLoop: 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; @@ -1692,9 +1767,9 @@ enterLoop: 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; /* ToDo */ - case i_shiftRLInt: OP_IW_I(x>>y); break; /* ToDo */ + case i_shiftLInt: 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; @@ -2096,56 +2171,13 @@ enterLoop: 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: { @@ -2330,7 +2362,7 @@ enterLoop: 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)); @@ -2753,9 +2785,11 @@ nat marshall(char arg_ty, void* arg) 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 @@ -2814,9 +2848,11 @@ nat unmarshall(char res_ty, void* res) *((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()); diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c index ff78cb9..2f0509e 100644 --- a/ghc/rts/ForeignCall.c +++ b/ghc/rts/ForeignCall.c @@ -1,6 +1,6 @@ -/* -*- 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. * @@ -33,6 +33,7 @@ void hcall( HFunDescriptor* d, StablePtr fun, void* as, void* rs) #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] @@ -111,6 +112,65 @@ void ccall( CFunDescriptor* d, void (*fun)(void) ) } } } +#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 ) { diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c index c314151..cf0e06c 100644 --- a/ghc/rts/Printer.c +++ b/ghc/rts/Printer.c @@ -1,6 +1,6 @@ -/* -*- 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. * @@ -39,8 +39,20 @@ static void printZcoded ( const char *raw ); * 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); @@ -48,6 +60,8 @@ extern void printPtr( StgPtr p ) } 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); } @@ -273,7 +287,8 @@ void printClosure( StgClosure *obj ) 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; } } @@ -331,8 +346,24 @@ StgPtr printStackObj( StgPtr sp ) #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;