* included in the distribution.
*
* $RCSfile: link.c,v $
- * $Revision: 1.31 $
- * $Date: 2000/01/10 17:19:33 $
+ * $Revision: 1.45 $
+ * $Date: 2000/02/29 12:27:35 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
Name nameZero; /* for monads with a zero */
Name nameId;
+Name nameShow;
+Name namePutStr;
Name nameRunIO_toplevel;
Name namePrint;
*/
name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
- 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);
+ 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);
+ }
}
}
}
nameEq = linkName("==");
nameFromInt = linkName("fromInt");
nameFromInteger = linkName("fromInteger");
- nameFromDouble = linkName("fromDouble");
nameReturn = linkName("return");
nameBind = linkName(">>=");
nameLe = linkName("<=");
nameInRange = linkName("inRange");
nameMinus = linkName("-");
/* These come before calls to implementPrim */
- for(i=0; i<NUM_TUPLES; ++i) {
- implementTuple(i);
+ if (!combined) {
+ for(i=0; i<NUM_TUPLES; ++i) {
+ if (i != 1) implementTuple(i);
+ }
}
}
}
/* primops */
nameMkIO = linkName("hugsprimMkIO");
- for (i=0; asmPrimOps[i].name; ++i) {
- Text t = findText(asmPrimOps[i].name);
- Name n = findName(t);
- if (isNull(n)) {
- n = newName(t,NIL);
- }
- name(n).line = 0;
- name(n).defn = NIL;
- name(n).type = primType(asmPrimOps[i].monad,
- asmPrimOps[i].args,
- asmPrimOps[i].results);
- name(n).arity = strlen(asmPrimOps[i].args);
- name(n).primop = &(asmPrimOps[i]);
- implementPrim(n);
- }
+ if (!combined) {
+ for (i=0; asmPrimOps[i].name; ++i) {
+ Text t = findText(asmPrimOps[i].name);
+ Name n = findName(t);
+ if (isNull(n)) {
+ n = newName(t,NIL);
+ }
+ name(n).line = 0;
+ name(n).defn = NIL;
+ name(n).type = primType(asmPrimOps[i].monad,
+ asmPrimOps[i].args,
+ asmPrimOps[i].results);
+ name(n).arity = strlen(asmPrimOps[i].args);
+ name(n).primop = &(asmPrimOps[i]);
+ implementPrim(n);
+ }
+ }
/* static(tidyInfix) */
nameNegate = linkName("negate");
/* user interface */
nameRunIO_toplevel = linkName("hugsprimRunIO_toplevel");
+ nameShow = linkName("show");
+ namePutStr = linkName("putStr");
namePrint = linkName("print");
/* desugar */
nameOtherwise = linkName("otherwise");
namePmSub = linkName("hugsprimPmSub");
# endif
/* translator */
- nameEqChar = linkName("primEqChar");
+ nameEqChar = linkName("hugsprimEqChar");
nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk");
namePmInt = linkName("hugsprimPmInt");
namePmInteger = linkName("hugsprimPmInteger");
- namePmDouble = linkName("primPmDouble");
-
+ namePmDouble = linkName("hugsprimPmDouble");
+
+ nameFromDouble = linkName("fromDouble");
namePmFromInteger = linkName("hugsprimPmFromInteger");
+
namePmSubtract = linkName("hugsprimPmSubtract");
namePmLe = linkName("hugsprimPmLe");
- implementCfun ( nameCons, NIL );
- implementCfun ( nameNil, NIL );
- implementCfun ( nameUnit, NIL );
+ if (!combined) {
+ implementCfun ( nameCons, NIL );
+ implementCfun ( nameNil, NIL );
+ implementCfun ( nameUnit, NIL );
+ }
}
}
Int what; {
Int i;
switch (what) {
+ //case EXIT : fooble();break;
case RESET :
case MARK :
break;
- case POSTPREL:
-#if 1
- fprintf(stderr, "linkControl(POSTPREL)\n");
-#if 1
- setCurrModule(modulePrelude);
- linkPreludeTC();
- linkPreludeCM();
- linkPreludeNames();
-#endif
-#endif
- break;
+ case POSTPREL: {
+ Name nm;
+ Module modulePrelBase = findModule(findText("PrelBase"));
+ assert(nonNull(modulePrelBase));
+ fprintf(stderr, "linkControl(POSTPREL)\n");
+ setCurrModule(modulePrelude);
+ linkPreludeTC();
+ linkPreludeCM();
+ linkPreludeNames();
+
+ 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);
module(modulePrelude).objectExtraNames
= singleton(findText("libHS_cbits"));
- nameMkC = addWiredInBoxingTycon("PrelBase","Char", "C#",1,0,CHAR_REP );
- nameMkI = addWiredInBoxingTycon("PrelBase","Int", "I#",1,0,INT_REP );
- nameMkW = addWiredInBoxingTycon("PrelAddr","Word", "W#",1,0,WORD_REP );
- nameMkA = addWiredInBoxingTycon("PrelAddr","Addr", "A#",1,0,ADDR_REP );
- nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",1,0,FLOAT_REP );
- nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",1,0,DOUBLE_REP);
+ 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#",1,0,0);
+ = addWiredInBoxingTycon("PrelNum","Integer","Integer#",0 ,STAR );
nameMkPrimByteArray
- = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",1,0,0);
+ = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",0 ,STAR );
for (i=0; i<NUM_TUPLES; ++i) {
- addTupleTycon(i);
+ if (i != 1) addTupleTycon(i);
}
addWiredInEnumTycon("PrelBase","Bool",
doubleton(findText("False"),findText("True")));
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"));
+ setCurrModule(modulePrelBase);
+ pFun(nameId, "id");
+ setCurrModule(modulePrelude);
+
} else {
modulePrelude = newModule(textPrelude);
setCurrModule(modulePrelude);
for (i=0; i<NUM_TUPLES; ++i) {
- addTupleTycon(i);
+ if (i != 1) addTupleTycon(i);
}
setCurrModule(modulePrelude);
/* deriving */
pFun(nameApp, "++");
- pFun(nameReadField, "readField");
+ pFun(nameReadField, "hugsprimReadField");
pFun(nameReadParen, "readParen");
- pFun(nameShowField, "showField");
+ pFun(nameShowField, "hugsprimShowField");
pFun(nameShowParen, "showParen");
pFun(nameLex, "lex");
pFun(nameComp, ".");
pFun(nameAnd, "&&");
- pFun(nameCompAux, "primCompAux");
+ pFun(nameCompAux, "hugsprimCompAux");
pFun(nameMap, "map");
/* implementTagToCon */
- pFun(namePMFail, "primPmFail");
+ pFun(namePMFail, "hugsprimPmFail");
pFun(nameError, "error");
- pFun(nameUnpackString, "primUnpackString");
+ pFun(nameUnpackString, "hugsprimUnpackString");
/* hooks for handwritten bytecode */
pFun(namePrimSeq, "primSeq");
}
#undef pFun
-
+//#include "fooble.c"
/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff