X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=inline;f=ghc%2Finterpreter%2Flink.c;h=7e405d039cacd99969b6857da818c36f4bf93ebb;hb=f0901617344ad6cb35b10eeaf7093f0e4f23dce9;hp=79d2bc6132e1d1b0d07b97d08d3c8aa4e27bb365;hpb=57131ad0203977941eb50d60550fa82e88614496;p=ghc-hetmet.git diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 79d2bc6..7e405d0 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -2,64 +2,49 @@ /* -------------------------------------------------------------------------- * Load symbols required from the Prelude * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 + * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the + * Yale Haskell Group, and the Oregon Graduate Institute of Science and + * Technology, 1994-1999, All rights reserved. It is distributed as + * free software under the license in the file "License", which is + * included in the distribution. * * $RCSfile: link.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/02/03 17:08:31 $ + * $Revision: 1.60 $ + * $Date: 2000/04/27 16:35:29 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "backend.h" #include "connect.h" #include "errors.h" -#include "Assembler.h" /* for asmPrimOps and AsmReps */ +#include "Rts.h" /* to make Prelude.h palatable */ +#include "Assembler.h" /* for asmPrimOps and AsmReps */ +#include "Prelude.h" /* for fixupRTStoPreludeRefs */ -#include "link.h" - -Module modulePreludeHugs; Type typeArrow; /* Function spaces */ Type typeChar; Type typeInt; -#ifdef PROVIDE_INT64 -Type typeInt64; -#endif -#ifdef PROVIDE_INTEGER Type typeInteger; -#endif -#ifdef PROVIDE_WORD Type typeWord; -#endif -#ifdef PROVIDE_ADDR Type typeAddr; -#endif -#ifdef PROVIDE_ARRAY Type typePrimArray; Type typePrimByteArray; Type typeRef; Type typePrimMutableArray; Type typePrimMutableByteArray; -#endif Type typeFloat; Type typeDouble; -#ifdef PROVIDE_STABLE Type typeStable; -#endif +Type typeThreadId; +Type typeMVar; #ifdef PROVIDE_WEAK Type typeWeak; #endif #ifdef PROVIDE_FOREIGN Type typeForeign; #endif -#ifdef PROVIDE_CONCURRENT -Type typeThreadId; -Type typeMVar; -#endif Type typeList; Type typeUnit; @@ -76,9 +61,6 @@ Class classRead; Class classIx; Class classEnum; Class classBounded; -#if EVAL_INSTANCES -Class classEval; -#endif Class classReal; /* `numeric' classes */ Class classIntegral; @@ -87,42 +69,35 @@ 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 nameTrue; +Name nameFalse; /* primitive boolean constructors */ +Name nameNil; +Name nameCons; /* primitive list constructors */ Name nameUnit; /* primitive Unit type constructor */ Name nameEq; -Name nameFromInt, nameFromDouble; /* coercion of numerics */ +Name nameFromInt; +Name nameFromDouble; /* coercion of numerics */ Name nameFromInteger; -Name nameReturn, nameBind; /* for translating monad comps */ +Name nameReturn; +Name nameBind; /* for translating monad comps */ Name nameZero; /* for monads with a zero */ -#if EVAL_INSTANCES -Name nameStrict; /* Members of class Eval */ -Name nameSeq; -#endif Name nameId; -Name nameRunIO; +Name nameShow; +Name namePutStr; +Name nameRunIO_toplevel; Name namePrint; Name nameOtherwise; Name nameUndefined; /* generic undefined value */ -#if NPLUSK Name namePmSub; -#endif Name namePMFail; Name nameEqChar; -Name nameEqInt; -#if !OVERLOADED_CONSTANTS -Name nameEqInteger; -#endif -Name nameEqDouble; Name namePmInt; Name namePmInteger; Name namePmDouble; @@ -133,21 +108,10 @@ Name nameMkIO; Name nameUnpackString; Name nameError; Name nameInd; - -Name nameForce; +Name nameCreateAdjThunk; 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; @@ -157,12 +121,29 @@ Name nameReadParen; Name nameLex; Name nameReadField; Name nameFlip; + +Name namePrimSeq; +Name namePrimCatch; +Name namePrimRaise; +Name namePrimTakeMVar; + Name nameFromTo; Name nameFromThen; Name nameFrom; Name nameFromThenTo; Name nameNegate; +Name nameAssert; +Name nameAssertError; +Name nameTangleMessage; +Name nameIrrefutPatError; +Name nameNoMethodBindingError; +Name nameNonExhaustiveGuardsError; +Name namePatError; +Name nameRecSelError; +Name nameRecConError; +Name nameRecUpdError; + /* these names are required before we've had a chance to do the right thing */ Name nameSel; Name nameUnsafeUnpackCString; @@ -170,40 +151,64 @@ Name nameUnsafeUnpackCString; /* constructors used during translation and codegen */ Name nameMkC; /* Char# -> Char */ Name nameMkI; /* Int# -> Int */ -#ifdef PROVIDE_INT64 -Name nameMkInt64; /* Int64# -> Int64 */ -#endif -#ifdef PROVIDE_INTEGER Name nameMkInteger; /* Integer# -> Integer */ -#endif -#ifdef PROVIDE_WORD Name nameMkW; /* Word# -> Word */ -#endif -#ifdef PROVIDE_ADDR Name nameMkA; /* Addr# -> Addr */ -#endif Name nameMkF; /* Float# -> Float */ Name nameMkD; /* Double# -> Double */ -#ifdef PROVIDE_ARRAY Name nameMkPrimArray; Name nameMkPrimByteArray; Name nameMkRef; Name nameMkPrimMutableArray; Name nameMkPrimMutableByteArray; -#endif -#ifdef PROVIDE_STABLE Name nameMkStable; /* StablePtr# a -> StablePtr a */ -#endif +Name nameMkThreadId; /* ThreadId# -> ThreadId */ +Name nameMkPrimMVar; /* MVar# a -> MVar a */ #ifdef PROVIDE_WEAK Name nameMkWeak; /* Weak# a -> Weak a */ #endif #ifdef PROVIDE_FOREIGN Name nameMkForeign; /* ForeignObj# -> ForeignObj */ #endif -#ifdef PROVIDE_CONCURRENT -Name nameMkThreadId; /* ThreadId# -> ThreadId */ -Name nameMkMVar; /* MVar# -> MVar */ -#endif + + + +Name nameMinBnd; +Name nameMaxBnd; +Name nameCompare; +Name nameShowsPrec; +Name nameIndex; +Name nameReadsPrec; +Name nameRange; +Name nameEQ; +Name nameInRange; +Name nameGt; +Name nameLe; +Name namePlus; +Name nameMult; +Name nameMFail; +Type typeOrdering; +Module modulePrelPrim; +Module modulePrelude; +Name nameMap; +Name nameMinus; + +/* -------------------------------------------------------------------------- + * Frequently used type skeletons: + * ------------------------------------------------------------------------*/ + +Type arrow; /* mkOffset(0) -> mkOffset(1) */ +Type boundPair; /* (mkOffset(0),mkOffset(0)) */ +Type listof; /* [ mkOffset(0) ] */ +Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */ + +Cell predNum; /* Num (mkOffset(0)) */ +Cell predFractional; /* Fractional (mkOffset(0)) */ +Cell predIntegral; /* Integral (mkOffset(0)) */ +Kind starToStar; /* Type -> Type */ +Cell predMonad; /* Monad (mkOffset(0)) */ +Type typeProgIO; /* IO a */ + /* -------------------------------------------------------------------------- * @@ -212,15 +217,19 @@ Name nameMkMVar; /* MVar# -> MVar */ static Tycon linkTycon ( String s ); static Tycon linkClass ( String s ); static Name linkName ( String s ); -static Void mkTypes (); +static Name predefinePrim ( String s ); static Tycon linkTycon( String s ) { Tycon tc = findTycon(findText(s)); - if (nonNull(tc)) { - return tc; + if (nonNull(tc)) return tc; + if (combined) { + tc = findTyconInAnyModule(findText(s)); + if (nonNull(tc)) return tc; } +FPrintf(stderr, "frambozenvla! unknown tycon %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard type \"%s\"", s EEND; } @@ -228,9 +237,13 @@ static Tycon linkTycon( String s ) static Class linkClass( String s ) { Class cc = findClass(findText(s)); - if (nonNull(cc)) { - return cc; - } + if (nonNull(cc)) return cc; + if (combined) { + cc = findClassInAnyModule(findText(s)); + if (nonNull(cc)) return cc; + } +FPrintf(stderr, "frambozenvla! unknown class %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard class \"%s\"", s EEND; } @@ -238,494 +251,563 @@ static Class linkClass( String s ) static Name linkName( String s ) { Name n = findName(findText(s)); - if (nonNull(n)) { - return n; - } + if (nonNull(n)) return n; + if (combined) { + n = findNameInAnyModule(findText(s)); + if (nonNull(n)) return n; + } +FPrintf(stderr, "frambozenvla! unknown name %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard name \"%s\"", s EEND; } -/* ToDo: kill this! */ -static Name predefinePrim ( String s ); -static Name predefinePrim ( String s ) +static Name predefinePrim ( String s ) { - Name nm = newName(findText(s),NIL); - name(nm).defn=PREDEFINED; + Name nm; + Text t = findText(s); + nm = findName(t); + if (nonNull(nm)) { + //fprintf(stderr, "predefinePrim: %s already exists\n", s ); + } else { + nm = newName(t,NIL); + name(nm).defn=PREDEFINED; + } return nm; } -Void linkPreludeTC() { /* Hook to tycons and classes in */ + +/* -------------------------------------------------------------------------- + * + * ------------------------------------------------------------------------*/ + +/* In standalone mode, linkPreludeTC, linkPreludeCM and linkPrimNames + are called, in that order, during static analysis of Prelude.hs. + In combined mode such an analysis does not happen. Instead these + calls will be made as a result of a call link(POSTPREL). + + linkPreludeTC, linkPreludeCM and linkPreludeNames are needed in both + standalone and combined modes. +*/ + + +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); - - typeChar = linkTycon("Char"); - typeInt = linkTycon("Int"); -#ifdef PROVIDE_INT64 - typeInt64 = linkTycon("Int64"); -#endif -#ifdef PROVIDE_INTEGER - typeInteger = linkTycon("Integer"); -#endif -#ifdef PROVIDE_WORD - typeWord = linkTycon("Word"); -#endif -#ifdef PROVIDE_ADDR - typeAddr = linkTycon("Addr"); -#endif -#ifdef PROVIDE_ARRAY + if (combined) { + setCurrModule(modulePrelude); + } else { + setCurrModule(modulePrelPrim); + } + + typeChar = linkTycon("Char"); + typeInt = linkTycon("Int"); + typeInteger = linkTycon("Integer"); + typeWord = linkTycon("Word"); + typeAddr = linkTycon("Addr"); typePrimArray = linkTycon("PrimArray"); typePrimByteArray = linkTycon("PrimByteArray"); - typeRef = linkTycon("Ref"); + typeRef = linkTycon("STRef"); typePrimMutableArray = linkTycon("PrimMutableArray"); typePrimMutableByteArray = linkTycon("PrimMutableByteArray"); -#endif - typeFloat = linkTycon("Float"); - typeDouble = linkTycon("Double"); -#ifdef PROVIDE_STABLE - typeStable = linkTycon("StablePtr"); -#endif -#ifdef PROVIDE_WEAK - typeWeak = linkTycon("Weak"); -#endif -#ifdef PROVIDE_FOREIGN - 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"); -#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");*/ - - stdDefaults = NIL; - stdDefaults = cons(typeDouble,stdDefaults); -#if DEFAULT_BIGNUM - stdDefaults = cons(typeBignum,stdDefaults); -#else - stdDefaults = cons(typeInt,stdDefaults); -#endif - mkTypes(); - - nameMkC = addPrimCfun(findText("C#"),1,0,CHAR_REP); - nameMkI = addPrimCfun(findText("I#"),1,0,INT_REP); -#ifdef PROVIDE_INT64 - nameMkInt64 = addPrimCfun(findText("Int64#"),1,0,INT64_REP); -#endif -#ifdef PROVIDE_WORD - nameMkW = addPrimCfun(findText("W#"),1,0,WORD_REP); -#endif -#ifdef PROVIDE_ADDR - nameMkA = addPrimCfun(findText("A#"),1,0,ADDR_REP); -#endif - nameMkF = addPrimCfun(findText("F#"),1,0,FLOAT_REP); - nameMkD = addPrimCfun(findText("D#"),1,0,DOUBLE_REP); -#ifdef PROVIDE_STABLE - nameMkStable = addPrimCfun(findText("Stable#"),1,0,STABLE_REP); -#endif - -#ifdef PROVIDE_INTEGER - nameMkInteger = addPrimCfun(findText("Integer#"),1,0,0); -#endif -#ifdef PROVIDE_FOREIGN - nameMkForeign = addPrimCfun(findText("Foreign#"),1,0,0); -#endif -#ifdef PROVIDE_WEAK - nameMkWeak = addPrimCfun(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); -#endif -#ifdef PROVIDE_CONCURRENT - nameMkThreadId = addPrimCfun(findText("ThreadId#"),1,0,0); - nameMkMVar = addPrimCfun(findText("MVar#"),1,0,0); -#endif - -#if EVAL_INSTANCES - addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->) */ -#endif + typeFloat = linkTycon("Float"); + typeDouble = linkTycon("Double"); + typeStable = linkTycon("StablePtr"); +# ifdef PROVIDE_WEAK + typeWeak = linkTycon("Weak"); +# endif +# ifdef PROVIDE_FOREIGN + typeForeign = linkTycon("ForeignObj"); +# endif + typeThreadId = linkTycon("ThreadId"); + typeMVar = linkTycon("MVar"); + typeBool = linkTycon("Bool"); + typeST = linkTycon("ST"); + typeIO = linkTycon("IO"); + typeException = linkTycon("Exception"); + typeString = linkTycon("String"); + typeOrdering = linkTycon("Ordering"); + + classEq = linkClass("Eq"); + classOrd = linkClass("Ord"); + classIx = linkClass("Ix"); + classEnum = linkClass("Enum"); + classShow = linkClass("Show"); + classRead = linkClass("Read"); + classBounded = linkClass("Bounded"); + classReal = linkClass("Real"); + classIntegral = linkClass("Integral"); + classRealFrac = linkClass("RealFrac"); + classRealFloat = linkClass("RealFloat"); + classFractional = linkClass("Fractional"); + classFloating = linkClass("Floating"); + classNum = linkClass("Num"); + classMonad = linkClass("Monad"); + + stdDefaults = NIL; + stdDefaults = cons(typeDouble,stdDefaults); + stdDefaults = cons(typeInteger,stdDefaults); + + predNum = ap(classNum,aVar); + predFractional = ap(classFractional,aVar); + predIntegral = ap(classIntegral,aVar); + predMonad = ap(classMonad,aVar); + typeProgIO = ap(typeIO,aVar); + + nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP); + nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP); + nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP); + nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP); + nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); + nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); + nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); + nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP); + +# ifdef PROVIDE_FOREIGN + nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0); +# endif +# ifdef PROVIDE_WEAK + nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0); +# endif + nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0); + nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0); + nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0); + nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); + nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0); + nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0); + nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); + + if (!combined) { + name(namePrimSeq).type = primType(MONAD_Id, "ab", "b"); + name(namePrimCatch).type = primType(MONAD_Id, "aH", "a"); + name(namePrimRaise).type = primType(MONAD_Id, "E", "a"); + + /* This is a lie. For a more accurate type of primTakeMVar + see ghc/interpreter/lib/Prelude.hs. + */ + name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d"); + } - for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */ -#if EVAL_INSTANCES - addEvalInst(0,mkTuple(i),i,NIL); -#endif -#if DERIVE_EQ - addTupInst(classEq,i); -#endif -#if DERIVE_ORD - addTupInst(classOrd,i); -#endif -#if DERIVE_IX - addTupInst(classIx,i); -#endif -#if DERIVE_SHOW - addTupInst(classShow,i); -#endif -#if DERIVE_READ - addTupInst(classRead,i); -#endif -#if DERIVE_BOUNDED - addTupInst(classBounded,i); -#endif + if (!combined) { + for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */ + addTupInst(classEq,i); + addTupInst(classOrd,i); + addTupInst(classIx,i); + addTupInst(classShow,i); + addTupInst(classRead,i); + addTupInst(classBounded,i); + } } } } -static Void mkTypes() -{ - 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);*/ -} - -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); + + if (combined) { + setCurrModule(modulePrelude); + } else { + setCurrModule(modulePrelPrim); + } + /* constructors */ - nameFalse = linkName("False"); - nameTrue = linkName("True"); - nameNil = linkName("[]"); - nameCons = linkName(":"); - nameUnit = linkName("()"); - /* members */ - nameEq = linkName("=="); - nameFromInt = linkName("fromInt"); - nameFromInteger = linkName("fromInteger"); - nameFromDouble = linkName("fromDouble"); -#if EVAL_INSTANCES - nameStrict = linkName("strict"); - nameSeq = linkName("seq"); -#endif - nameReturn = linkName("return"); - nameBind = linkName(">>="); - nameZero = linkName("zero"); + nameFalse = linkName("False"); + nameTrue = linkName("True"); + /* members */ + nameEq = linkName("=="); + nameFromInt = linkName("fromInt"); + nameFromInteger = linkName("fromInteger"); + nameReturn = linkName("return"); + nameBind = linkName(">>="); + nameMFail = linkName("fail"); + nameLe = linkName("<="); + nameGt = linkName(">"); + nameShowsPrec = linkName("showsPrec"); + nameReadsPrec = linkName("readsPrec"); + nameEQ = linkName("EQ"); + nameCompare = linkName("compare"); + nameMinBnd = linkName("minBound"); + nameMaxBnd = linkName("maxBound"); + nameRange = linkName("range"); + nameIndex = linkName("index"); + namePlus = linkName("+"); + nameMult = linkName("*"); + nameRangeSize = linkName("rangeSize"); + nameInRange = linkName("inRange"); + nameMinus = linkName("-"); /* 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"); - /* desugaring */ - pFun(nameInd, "_indirect","error"); - name(nameInd).number = DFUNNAME; - /* pmc */ - pFun(nameSel, "_SEL", "sel"); - /* strict constructors */ - pFun(nameForce, "primForce","id"); - /* implementTagToCon */ - pFun(namePMFail, "primPmFail","primPmFail"); - pFun(nameError, "error","error"); - pFun(nameUnpackString, "primUnpackString", "primUnpackString"); -#undef pFun - - break; + case POSTPREL: { + Name nm; + Module modulePrelBase = findModule(findText("PrelBase")); + assert(nonNull(modulePrelBase)); + /* fprintf(stderr, "linkControl(POSTPREL)\n"); */ + setCurrModule(modulePrelude); + linkPreludeTC(); + linkPreludeCM(); + linkPrimNames(); + fixupRTStoPreludeRefs ( lookupObjName ); + + nameUnpackString = linkName("hugsprimUnpackString"); + namePMFail = linkName("hugsprimPmFail"); +assert(nonNull(namePMFail)); +#define xyzzy(aaa,bbb) aaa = linkName(bbb) + + + /* pmc */ + pFun(nameSel, "_SEL"); + + /* strict constructors */ + xyzzy(nameFlip, "flip" ); + + /* parser */ + xyzzy(nameFromTo, "enumFromTo"); + xyzzy(nameFromThenTo, "enumFromThenTo"); + xyzzy(nameFrom, "enumFrom"); + xyzzy(nameFromThen, "enumFromThen"); + + /* deriving */ + xyzzy(nameApp, "++"); + xyzzy(nameReadField, "hugsprimReadField"); + xyzzy(nameReadParen, "readParen"); + xyzzy(nameShowField, "hugsprimShowField"); + xyzzy(nameShowParen, "showParen"); + xyzzy(nameLex, "lex"); + xyzzy(nameComp, "."); + xyzzy(nameAnd, "&&"); + xyzzy(nameCompAux, "hugsprimCompAux"); + xyzzy(nameMap, "map"); + + /* implementTagToCon */ + xyzzy(nameError, "hugsprimError"); + + + typeStable = linkTycon("Stable"); + typeRef = linkTycon("IORef"); + // {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ? + + ifLinkConstrItbl ( nameFalse ); + ifLinkConstrItbl ( nameTrue ); + ifLinkConstrItbl ( nameNil ); + ifLinkConstrItbl ( nameCons ); + + /* PrelErr.hi doesn't give a type for error, alas. + So error never appears in any symbol table. + So we fake it by copying the table entry for + hugsprimError -- which is just a call to error. + Although we put it on the Prelude export list, we + have to claim internally that it lives in PrelErr, + so that the correct symbol (PrelErr_error_closure) + is referred to. + Big Big Sigh. + */ + nm = newName ( findText("error"), NIL ); + name(nm) = name(nameError); + name(nm).mod = findModule(findText("PrelErr")); + name(nm).text = findText("error"); + setCurrModule(modulePrelude); + module(modulePrelude).exports + = cons ( nm, module(modulePrelude).exports ); + + /* The GHC prelude doesn't seem to export Addr. Add it to the + export list for the sake of compatibility with standalone mode. + */ + module(modulePrelude).exports + = cons ( pair(typeAddr,DOTDOT), + module(modulePrelude).exports ); + addTycon(typeAddr); + + /* Make nameListMonad be the builder fn for instance Monad []. + Standalone hugs does this with a disgusting hack in + checkInstDefn() in static.c. We have a slightly different + disgusting hack for the combined case. + */ + { + Class cm; /* :: Class */ + List is; /* :: [Inst] */ + cm = findClassInAnyModule(findText("Monad")); + assert(nonNull(cm)); + is = cclass(cm).instances; + assert(nonNull(is)); + while (nonNull(is) && snd(inst(hd(is)).head) != typeList) + is = tl(is); + assert(nonNull(is)); + nameListMonad = inst(hd(is)).builder; + assert(nonNull(nameListMonad)); + } + + break; + } + case PREPREL : + + if (combined) { + Module modulePrelBase; + + modulePrelude = findFakeModule(textPrelude); + + nameMkC = addWiredInBoxingTycon("PrelBase", "Char", "C#", + CHAR_REP, STAR ); + nameMkI = addWiredInBoxingTycon("PrelBase", "Int", "I#", + INT_REP, STAR ); + nameMkW = addWiredInBoxingTycon("PrelAddr", "Word", "W#", + WORD_REP, STAR ); + nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr", "A#", + ADDR_REP, STAR ); + nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#", + FLOAT_REP, STAR ); + nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#", + DOUBLE_REP, STAR ); + nameMkInteger + = addWiredInBoxingTycon("PrelNum","Integer","Integer#", + 0 ,STAR ); + nameMkPrimByteArray + = addWiredInBoxingTycon("PrelGHC","ByteArray", + "PrimByteArray#",0 ,STAR ); + + for (i=0; i)"), + pair(STAR,pair(STAR,STAR)), + 2,DATATYPE,NIL); + + /* desugaring */ + pFun(nameInd, "_indirect"); + name(nameInd).number = DFUNNAME; + + /* newtype and USE_NEWTYPE_FOR_DICTS */ + /* make a name entry for PrelBase.id _before_ loading Prelude + since ifSetClassDefaultsAndDCon() may need to refer to + nameId. + */ + modulePrelBase = findModule(findText("PrelBase")); + module(modulePrelBase).objectExtraNames + = singleton(findText("libHSstd_cbits")); + + setCurrModule(modulePrelBase); + pFun(nameId, "id"); + setCurrModule(modulePrelude); + + } else { + fixupRTStoPreludeRefs(NULL); + + modulePrelPrim = findFakeModule(textPrelPrim); + modulePrelude = findFakeModule(textPrelude); + setCurrModule(modulePrelPrim); + + for (i=0; i)"), + pair(STAR,pair(STAR,STAR)), + 2,DATATYPE,NIL); + + /* newtype and USE_NEWTYPE_FOR_DICTS */ + pFun(nameId, "id"); + + /* desugaring */ + pFun(nameInd, "_indirect"); + name(nameInd).number = DFUNNAME; + + /* pmc */ + pFun(nameSel, "_SEL"); + + /* strict constructors */ + pFun(nameFlip, "flip" ); + + /* parser */ + pFun(nameFromTo, "enumFromTo"); + pFun(nameFromThenTo, "enumFromThenTo"); + pFun(nameFrom, "enumFrom"); + pFun(nameFromThen, "enumFromThen"); + + /* deriving */ + pFun(nameApp, "++"); + pFun(nameReadField, "hugsprimReadField"); + pFun(nameReadParen, "readParen"); + pFun(nameShowField, "hugsprimShowField"); + pFun(nameShowParen, "showParen"); + pFun(nameLex, "lex"); + pFun(nameComp, "."); + pFun(nameAnd, "&&"); + pFun(nameCompAux, "hugsprimCompAux"); + pFun(nameMap, "map"); + + /* implementTagToCon */ + pFun(namePMFail, "hugsprimPmFail"); + pFun(nameError, "error"); + pFun(nameUnpackString, "hugsprimUnpackString"); + + /* assertion and exception issues */ + pFun(nameAssert, "assert"); + pFun(nameAssertError, "assertError"); + pFun(nameTangleMessage, "tangleMessager"); + pFun(nameIrrefutPatError, + "irrefutPatError"); + pFun(nameNoMethodBindingError, + "noMethodBindingError"); + pFun(nameNonExhaustiveGuardsError, + "nonExhaustiveGuardsError"); + pFun(namePatError, "patError"); + pFun(nameRecSelError, "recSelError"); + pFun(nameRecConError, "recConError"); + pFun(nameRecUpdError, "recUpdError"); + + /* hooks for handwritten bytecode */ + pFun(namePrimSeq, "primSeq"); + pFun(namePrimCatch, "primCatch"); + pFun(namePrimRaise, "primRaise"); + pFun(namePrimTakeMVar, "primTakeMVar"); + { + Name n = namePrimSeq; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + name(n).closure = mkCPtr ( asm_BCO_seq() ); + addToCodeList ( modulePrelPrim, n ); + } + { + Name n = namePrimCatch; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + name(n).closure = mkCPtr ( asm_BCO_catch() ); + addToCodeList ( modulePrelPrim, n ); + } + { + Name n = namePrimRaise; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + name(n).closure = mkCPtr ( asm_BCO_raise() ); + addToCodeList ( modulePrelPrim, n ); + } + { + Name n = namePrimTakeMVar; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + name(n).closure = mkCPtr ( asm_BCO_takeMVar() ); + addToCodeList ( modulePrelPrim, n ); + } + } + 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