/* --------------------------------------------------------------------------
* 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.31 $
+ * $Date: 2000/01/10 17:19:33 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#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;
Class classIx;
Class classEnum;
Class classBounded;
-#if EVAL_INSTANCES
-Class classEval;
-#endif
Class classReal; /* `numeric' classes */
Class classIntegral;
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 nameRunIO_toplevel;
Name namePrint;
Name nameOtherwise;
#endif
Name namePMFail;
Name nameEqChar;
-Name nameEqInt;
-#if !OVERLOADED_CONSTANTS
-Name nameEqInteger;
-#endif
-Name nameEqDouble;
Name namePmInt;
Name namePmInteger;
Name namePmDouble;
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;
Name nameLex;
Name nameReadField;
Name nameFlip;
+
+Name namePrimSeq;
+Name namePrimCatch;
+Name namePrimRaise;
+Name namePrimTakeMVar;
+
Name nameFromTo;
Name nameFromThen;
Name nameFrom;
/* 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 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 */
+
/* --------------------------------------------------------------------------
*
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;
}
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;
}
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 linkPreludeNames
+ 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);
+ setCurrModule(modulePrelude);
- 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
+ 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);
+# if DEFAULT_BIGNUM
+ stdDefaults = cons(typeInteger,stdDefaults);
+# else
+ stdDefaults = cons(typeInt,stdDefaults);
+# endif
+
+ 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);
+
+ 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
}
}
}
-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);
+
+ setCurrModule(modulePrelude);
+
/* 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");
+ nameFromDouble = linkName("fromDouble");
+ nameReturn = linkName("return");
+ nameBind = linkName(">>=");
+ 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<NUM_TUPLES; ++i) {
implementTuple(i);
}
}
-Void linkPreludeNames() { /* Hook to names defined in Prelude */
+Void linkPreludeNames(void) { /* Hook to names defined in Prelude */
static Bool initialised = FALSE;
if (!initialised) {
Int i;
initialised = TRUE;
- setCurrModule(modulePreludeHugs);
+
+ setCurrModule(modulePrelude);
/* primops */
- nameMkIO = linkName("primMkIO");
+ nameMkIO = linkName("hugsprimMkIO");
for (i=0; asmPrimOps[i].name; ++i) {
Text t = findText(asmPrimOps[i].name);
Name n = findName(t);
implementPrim(n);
}
+ /* static(tidyInfix) */
+ nameNegate = linkName("negate");
/* user interface */
- nameRunIO = linkName("primRunIO");
- namePrint = linkName("print");
- /* typechecker (undefined member functions) */
- nameError = linkName("error");
+ nameRunIO_toplevel = linkName("hugsprimRunIO_toplevel");
+ namePrint = linkName("print");
/* desugar */
- nameId = linkName("id");
- nameOtherwise = linkName("otherwise");
- nameUndefined = linkName("undefined");
+ nameOtherwise = linkName("otherwise");
+ nameUndefined = linkName("undefined");
/* pmc */
-#if NPLUSK
- namePmSub = linkName("primPmSub");
-#endif
+# if NPLUSK
+ namePmSub = linkName("hugsprimPmSub");
+# endif
/* translator */
- nameUnpackString = linkName("primUnpackString");
- namePMFail = linkName("primPmFail");
- nameEqChar = linkName("primEqChar");
- nameEqInt = linkName("primEqInt");
-#if !OVERLOADED_CONSTANTS
- nameEqInteger = linkName("primEqInteger");
-#endif /* !OVERLOADED_CONSTANTS */
- nameEqDouble = linkName("primEqDouble");
- namePmInt = linkName("primPmInt");
- namePmInteger = linkName("primPmInteger");
- namePmDouble = linkName("primPmDouble");
- namePmLe = linkName("primPmLe");
- namePmSubtract = linkName("primPmSubtract");
- namePmFromInteger = linkName("primPmFromInteger");
+ nameEqChar = linkName("primEqChar");
+ nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk");
+ namePmInt = linkName("hugsprimPmInt");
+ namePmInteger = linkName("hugsprimPmInteger");
+ namePmDouble = linkName("primPmDouble");
+
+ namePmFromInteger = linkName("hugsprimPmFromInteger");
+ namePmSubtract = linkName("hugsprimPmSubtract");
+ namePmLe = linkName("hugsprimPmLe");
+
+ implementCfun ( nameCons, NIL );
+ implementCfun ( nameNil, NIL );
+ implementCfun ( nameUnit, NIL );
}
}
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+/* ToDo: fix pFun (or eliminate its use) */
+#define pFun(n,s) n = predefinePrim(s)
+
Void linkControl(what)
Int what; {
- Int i;
-
+ Int i;
switch (what) {
case RESET :
case MARK :
break;
- case INSTALL : linkControl(RESET);
-
- modulePreludeHugs = newModule(findText("PreludeBuiltin"));
-
- setCurrModule(modulePreludeHugs);
-
- typeArrow = addPrimTycon(findText("(->)"),
- 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:
+#if 1
+ fprintf(stderr, "linkControl(POSTPREL)\n");
+#if 1
+ setCurrModule(modulePrelude);
+ linkPreludeTC();
+ linkPreludeCM();
+ linkPreludeNames();
+#endif
+#endif
+ break;
+
+ case PREPREL :
+
+ if (combined) {
+
+ 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);
+ nameMkInteger
+ = addWiredInBoxingTycon("PrelNum","Integer","Integer#",1,0,0);
+ nameMkPrimByteArray
+ = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",1,0,0);
+
+ for (i=0; i<NUM_TUPLES; ++i) {
+ 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);
+ } else {
+
+ modulePrelude = newModule(textPrelude);
+ setCurrModule(modulePrelude);
+
+ for (i=0; i<NUM_TUPLES; ++i) {
+ addTupleTycon(i);
+ }
+ setCurrModule(modulePrelude);
+
+ 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;
}
}
-
-/*-------------------------------------------------------------------------*/
+#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
+/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff