- case INSTALL : linkControl(RESET);
-
- modulePrelude = newModule(textPrelude);
- setCurrModule(modulePrelude);
-
- for(i=0; i<NUM_TUPLES; ++i) {
- allocTupleTycon(i);
- }
-
- typeArrow = addPrimTycon(findText("(->)"),
- 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(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");
- 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;
+ 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<NUM_TUPLES; ++i) {
+ if (i != 1) addTupleTycon(i);
+ }
+ addWiredInEnumTycon("PrelBase","Bool",
+ doubleton(findText("False"),
+ findText("True")));
+
+ //nameMkThreadId
+ // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
+ // ,1,0,THREADID_REP);
+
+ setCurrModule(modulePrelude);
+
+ typeArrow = addPrimTycon(findText("(->)"),
+ 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<NUM_TUPLES; ++i) {
+ if (i != 1) addTupleTycon(i);
+ }
+ setCurrModule(modulePrelPrim);
+
+ typeArrow = addPrimTycon(findText("(->)"),
+ 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;