X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Flink.c;h=8027770873bcc99c4ffe896eeac398afbbe540b6;hb=a634bc4711b13d878ce4a5fe9a45ae5c7468255c;hp=3ac5f76020468152ec3e7a79b4f4fb50ab65a1a0;hpb=8aaa69d48f3d866727620c7d7e3a663dde3fb02a;p=ghc-hetmet.git diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 3ac5f76..8027770 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -9,18 +9,17 @@ * included in the distribution. * * $RCSfile: link.c,v $ - * $Revision: 1.12 $ - * $Date: 1999/11/12 17:32:40 $ + * $Revision: 1.56 $ + * $Date: 2000/04/04 15:41:56 $ * ------------------------------------------------------------------------*/ -#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 "link.h" +#include "Assembler.h" /* for asmPrimOps and AsmReps */ +#include "Rts.h" /* to make Prelude.h palatable */ +#include "Prelude.h" /* for fixupRTStoPreludeRefs */ Type typeArrow; /* Function spaces */ @@ -38,16 +37,14 @@ Type typePrimMutableByteArray; Type typeFloat; Type typeDouble; Type typeStable; +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; @@ -91,18 +88,16 @@ Name nameBind; /* for translating monad comps */ Name nameZero; /* for monads with a zero */ 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; -Name nameEqDouble; Name namePmInt; Name namePmInteger; Name namePmDouble; @@ -110,23 +105,13 @@ Name namePmLe; Name namePmSubtract; Name namePmFromInteger; Name nameMkIO; -Name nameRunST; Name nameUnpackString; Name nameError; Name nameInd; Name nameCreateAdjThunk; Name nameAnd; -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; @@ -140,6 +125,7 @@ Name nameFlip; Name namePrimSeq; Name namePrimCatch; Name namePrimRaise; +Name namePrimTakeMVar; Name nameFromTo; Name nameFromThen; @@ -147,6 +133,17 @@ 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; @@ -165,16 +162,14 @@ Name nameMkRef; Name nameMkPrimMutableArray; Name nameMkPrimMutableByteArray; Name nameMkStable; /* StablePtr# a -> StablePtr a */ +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 @@ -193,11 +188,11 @@ Name namePlus; Name nameMult; Name nameMFail; Type typeOrdering; +Module modulePrimPrel; Module modulePrelude; Name nameMap; Name nameMinus; - /* -------------------------------------------------------------------------- * Frequently used type skeletons: * ------------------------------------------------------------------------*/ @@ -212,6 +207,8 @@ Cell predFractional; /* Fractional (mkOffset(0)) */ Cell predIntegral; /* Integral (mkOffset(0)) */ Kind starToStar; /* Type -> Type */ Cell predMonad; /* Monad (mkOffset(0)) */ +Type typeProgIO; /* IO a */ + /* -------------------------------------------------------------------------- * @@ -220,16 +217,19 @@ Cell predMonad; /* Monad (mkOffset(0)) */ static Tycon linkTycon ( String s ); static Tycon linkClass ( String s ); static Name linkName ( String s ); -static Void mkTypes ( void ); 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; } @@ -237,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; } @@ -247,9 +251,13 @@ 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; } @@ -268,139 +276,131 @@ static Name predefinePrim ( String s ) return nm; } + +/* -------------------------------------------------------------------------- + * + * ------------------------------------------------------------------------*/ + +/* 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(modulePrelude); - - typeChar = linkTycon("Char"); - typeInt = linkTycon("Int"); - typeInteger = linkTycon("Integer"); - typeWord = linkTycon("Word"); - typeAddr = linkTycon("Addr"); + if (combined) { + setCurrModule(modulePrelude); + } else { + setCurrModule(modulePrimPrel); + } + + 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"); - typeFloat = linkTycon("Float"); - typeDouble = linkTycon("Double"); - typeStable = linkTycon("StablePtr"); -#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"); - 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); -#if DEFAULT_BIGNUM - stdDefaults = cons(typeInteger,stdDefaults); -#else - stdDefaults = cons(typeInt,stdDefaults); -#endif - mkTypes(); - - 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); - nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); -#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("Ref#"),1,0,0); - nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); + 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); -#ifdef PROVIDE_CONCURRENT - nameMkThreadId = addPrimCfun(findTextREP("ThreadId#"),1,0,0); - nameMkMVar = addPrimCfun(findTextREP("MVar#"),1,0,0); -#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))); - - name(namePrimSeq).type - = primType(MONAD_Id, "ab", "b"); - name(namePrimCatch).type - = primType(MONAD_Id, "aH", "a"); - name(namePrimRaise).type - = primType(MONAD_Id, "E", "a"); - - 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); + 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"); } - } -} -static Void mkTypes ( void ) -{ - predNum = ap(classNum,aVar); - predFractional = ap(classFractional,aVar); - predIntegral = ap(classIntegral,aVar); - predMonad = ap(classMonad,aVar); + 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); + } + } + } } Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ @@ -409,7 +409,11 @@ Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ Int i; initialised = TRUE; - setCurrModule(modulePrelude); + if (combined) { + setCurrModule(modulePrelude); + } else { + setCurrModule(modulePrimPrel); + } /* constructors */ nameFalse = linkName("False"); @@ -419,9 +423,9 @@ Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ nameEq = linkName("=="); nameFromInt = linkName("fromInt"); nameFromInteger = linkName("fromInteger"); - nameFromDouble = linkName("fromDouble"); nameReturn = linkName("return"); nameBind = linkName(">>="); + nameMFail = linkName("fail"); nameLe = linkName("<="); nameGt = linkName(">"); nameShowsPrec = linkName("showsPrec"); @@ -438,169 +442,383 @@ Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ nameInRange = linkName("inRange"); nameMinus = linkName("-"); /* These come before calls to implementPrim */ - 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, "readField"); - pFun(nameReadParen, "readParen"); - pFun(nameShowField, "showField"); - 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"); - pFun(nameMap, "map"); - - /* implementTagToCon */ - pFun(namePMFail, "primPmFail"); - pFun(nameError, "error"); - pFun(nameUnpackString, "primUnpackString"); - - /* hooks for handwritten bytecode */ - pFun(namePrimSeq, "primSeq"); - pFun(namePrimCatch, "primCatch"); - pFun(namePrimRaise, "primRaise"); - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimSeq; - name(n).line = 0; - name(n).arity = 1; - name(n).type = NIL; - vv = mkStgVar(NIL,NIL); - stgVarInfo(vv) = mkPtr ( asm_BCO_seq() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - namePrimSeq = n; - } - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimCatch; - name(n).line = 0; - name(n).arity = 2; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_catch() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - } - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimRaise; - name(n).line = 0; - name(n).arity = 1; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_raise() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - } - - 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("libHS_cbits")); + + setCurrModule(modulePrelBase); + pFun(nameId, "id"); + setCurrModule(modulePrelude); + + } else { + fixupRTStoPreludeRefs(NULL); + + modulePrimPrel = findFakeModule(textPrimPrel); + modulePrelude = findFakeModule(textPrelude); + setCurrModule(modulePrimPrel); + + 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"); + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimSeq; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + vv = mkStgVar(NIL,NIL); + stgVarInfo(vv) = mkPtr ( asm_BCO_seq() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + namePrimSeq = n; + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimCatch; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_catch() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimRaise; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_raise() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimTakeMVar; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + } + break; } } #undef pFun - +//#include "fooble.c" /*-------------------------------------------------------------------------*/