/* --------------------------------------------------------------------------
* 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.6 $
- * $Date: 1999/03/09 14:51:08 $
+ * $Revision: 1.20 $
+ * $Date: 1999/12/06 16:25:25 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "link.h"
-////Module modulePreludeHugs;
-
-Type typeArrow =BOGUS(1); /* Function spaces */
-
-Type typeChar =BOGUS(2);
-Type typeInt =BOGUS(3);
-#ifdef PROVIDE_INT64
-Type typeInt64 =BOGUS(4);
-#endif
-#ifdef PROVIDE_INTEGER
-Type typeInteger =BOGUS(5);
-#endif
-#ifdef PROVIDE_WORD
-Type typeWord =BOGUS(6);
-#endif
-#ifdef PROVIDE_ADDR
-Type typeAddr =BOGUS(7);
-#endif
-#ifdef PROVIDE_ARRAY
-Type typePrimArray =BOGUS(8);
-Type typePrimByteArray =BOGUS(9);
-Type typeRef =BOGUS(10);
-Type typePrimMutableArray =BOGUS(11);
-Type typePrimMutableByteArray =BOGUS(12);
-#endif
-Type typeFloat =BOGUS(13);
-Type typeDouble =BOGUS(14);
-#ifdef PROVIDE_STABLE
-Type typeStable =BOGUS(15);
-#endif
+Type typeArrow; /* Function spaces */
+
+Type typeChar;
+Type typeInt;
+Type typeInteger;
+Type typeWord;
+Type typeAddr;
+Type typePrimArray;
+Type typePrimByteArray;
+Type typeRef;
+Type typePrimMutableArray;
+Type typePrimMutableByteArray;
+Type typeFloat;
+Type typeDouble;
+Type typeStable;
+Type typeThreadId;
+Type typeMVar;
#ifdef PROVIDE_WEAK
-Type typeWeak =BOGUS(16);
+Type typeWeak;
#endif
#ifdef PROVIDE_FOREIGN
-Type typeForeign =BOGUS(17);
-#endif
-#ifdef PROVIDE_CONCURRENT
-Type typeThreadId =BOGUS(18);
-Type typeMVar =BOGUS(19);
-#endif
-
-Type typeList =BOGUS(20);
-Type typeUnit =BOGUS(21);
-Type typeString =BOGUS(22);
-Type typeBool =BOGUS(23);
-Type typeST =BOGUS(24);
-Type typeIO =BOGUS(25);
-Type typeException =BOGUS(26);
-
-Class classEq =BOGUS(27); /* `standard' classes */
-Class classOrd =BOGUS(28);
-Class classShow =BOGUS(29);
-Class classRead =BOGUS(30);
-Class classIx =BOGUS(31);
-Class classEnum =BOGUS(32);
-Class classBounded =BOGUS(33);
-#if EVAL_INSTANCES
-Class classEval =BOGUS(34);
-#endif
-
-Class classReal =BOGUS(35); /* `numeric' classes */
-Class classIntegral =BOGUS(36);
-Class classRealFrac =BOGUS(37);
-Class classRealFloat =BOGUS(38);
-Class classFractional =BOGUS(39);
-Class classFloating =BOGUS(40);
-Class classNum =BOGUS(41);
-
-Class classMonad =BOGUS(42); /* Monads and monads with a zero */
-/*Class classMonad0 =BOGUS();*/
-
-List stdDefaults =BOGUS(43); /* standard default values */
-
-Name nameTrue =BOGUS(44),
- nameFalse =BOGUS(45); /* primitive boolean constructors */
-Name nameNil =BOGUS(46),
- nameCons =BOGUS(47); /* primitive list constructors */
-Name nameUnit =BOGUS(48); /* primitive Unit type constructor */
-
-Name nameEq =BOGUS(49);
-Name nameFromInt =BOGUS(50),
- nameFromDouble =BOGUS(51); /* coercion of numerics */
-Name nameFromInteger =BOGUS(52);
-Name nameReturn =BOGUS(53),
- nameBind =BOGUS(54); /* for translating monad comps */
-Name nameZero =BOGUS(55); /* for monads with a zero */
-#if EVAL_INSTANCES
-Name nameStrict =BOGUS(56); /* Members of class Eval */
-Name nameSeq =BOGUS(57);
-#endif
-
-Name nameId =BOGUS(58);
-Name nameRunIO =BOGUS(59);
-Name namePrint =BOGUS(60);
-
-Name nameOtherwise =BOGUS(61);
-Name nameUndefined =BOGUS(62); /* generic undefined value */
+Type typeForeign;
+#endif
+
+Type typeList;
+Type typeUnit;
+Type typeString;
+Type typeBool;
+Type typeST;
+Type typeIO;
+Type typeException;
+
+Class classEq; /* `standard' classes */
+Class classOrd;
+Class classShow;
+Class classRead;
+Class classIx;
+Class classEnum;
+Class classBounded;
+
+Class classReal; /* `numeric' classes */
+Class classIntegral;
+Class classRealFrac;
+Class classRealFloat;
+Class classFractional;
+Class classFloating;
+Class classNum;
+Class classMonad; /* Monads and monads with a zero */
+
+List stdDefaults; /* standard default values */
+
+Name nameTrue;
+Name nameFalse; /* primitive boolean constructors */
+Name nameNil;
+Name nameCons; /* primitive list constructors */
+Name nameUnit; /* primitive Unit type constructor */
+
+Name nameEq;
+Name nameFromInt;
+Name nameFromDouble; /* coercion of numerics */
+Name nameFromInteger;
+Name nameReturn;
+Name nameBind; /* for translating monad comps */
+Name nameZero; /* for monads with a zero */
+
+Name nameId;
+Name nameRunIO;
+Name namePrint;
+
+Name nameOtherwise;
+Name nameUndefined; /* generic undefined value */
#if NPLUSK
-Name namePmSub =BOGUS(63);
-#endif
-Name namePMFail =BOGUS(64);
-Name namePMFailBUG = BOGUS(666);
-Name nameEqChar =BOGUS(65);
-Name nameEqInt =BOGUS(66);
-#if !OVERLOADED_CONSTANTS
-Name nameEqInteger =BOGUS(67);
-#endif
-Name nameEqDouble =BOGUS(68);
-Name namePmInt =BOGUS(69);
-Name namePmInteger =BOGUS(70);
-Name namePmDouble =BOGUS(71);
-Name namePmLe =BOGUS(72);
-Name namePmSubtract =BOGUS(73);
-Name namePmFromInteger =BOGUS(74);
-Name nameMkIO =BOGUS(75);
-Name nameUnpackString =BOGUS(76);
-Name nameError =BOGUS(77);
-Name nameInd =BOGUS(78);
-
-Name nameAnd =BOGUS(80);
-Name nameConCmp =BOGUS(82);
-Name nameCompAux =BOGUS(83);
-Name nameEnFrTh =BOGUS(84);
-Name nameEnFrTo =BOGUS(85);
-Name nameEnFrom =BOGUS(86);
-Name nameEnFrEn =BOGUS(87);
-Name nameEnToEn =BOGUS(88);
-Name nameEnInRng =BOGUS(89);
-Name nameEnIndex =BOGUS(90);
-Name nameEnRange =BOGUS(91);
-Name nameRangeSize =BOGUS(92);
-Name nameComp =BOGUS(93);
-Name nameShowField =BOGUS(94);
-Name nameApp =BOGUS(95);
-Name nameShowParen =BOGUS(96);
-Name nameReadParen =BOGUS(97);
-Name nameLex =BOGUS(98);
-Name nameReadField =BOGUS(99);
-Name nameFlip =BOGUS(100);
-
-Name namePrimSeq =BOGUS(1000);
-Name namePrimCatch =BOGUS(1001);
-Name namePrimRaise =BOGUS(1002);
-
-Name nameFromTo =BOGUS(101);
-Name nameFromThen =BOGUS(102);
-Name nameFrom =BOGUS(103);
-Name nameFromThenTo =BOGUS(104);
-Name nameNegate =BOGUS(105);
+Name namePmSub;
+#endif
+Name namePMFail;
+Name nameEqChar;
+Name namePmInt;
+Name namePmInteger;
+Name namePmDouble;
+Name namePmLe;
+Name namePmSubtract;
+Name namePmFromInteger;
+Name nameMkIO;
+Name nameUnpackString;
+Name nameError;
+Name nameInd;
+Name nameCreateAdjThunk;
+
+Name nameAnd;
+Name nameCompAux;
+Name nameRangeSize;
+Name nameComp;
+Name nameShowField;
+Name nameApp;
+Name nameShowParen;
+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;
/* these names are required before we've had a chance to do the right thing */
-Name nameSel =BOGUS(106);
-Name nameUnsafeUnpackCString =BOGUS(107);
+Name nameSel;
+Name nameUnsafeUnpackCString;
/* constructors used during translation and codegen */
-Name nameMkC =BOGUS(108); /* Char# -> Char */
-Name nameMkI =BOGUS(109); /* Int# -> Int */
-#ifdef PROVIDE_INT64
-Name nameMkInt64 =BOGUS(110); /* Int64# -> Int64 */
-#endif
-#ifdef PROVIDE_INTEGER
-Name nameMkInteger =BOGUS(111); /* Integer# -> Integer */
-#endif
-#ifdef PROVIDE_WORD
-Name nameMkW =BOGUS(112); /* Word# -> Word */
-#endif
-#ifdef PROVIDE_ADDR
-Name nameMkA =BOGUS(113); /* Addr# -> Addr */
-#endif
-Name nameMkF =BOGUS(114); /* Float# -> Float */
-Name nameMkD =BOGUS(115); /* Double# -> Double */
-#ifdef PROVIDE_ARRAY
-Name nameMkPrimArray =BOGUS(116);
-Name nameMkPrimByteArray =BOGUS(117);
-Name nameMkRef =BOGUS(118);
-Name nameMkPrimMutableArray =BOGUS(119);
-Name nameMkPrimMutableByteArray =BOGUS(120);
-#endif
-#ifdef PROVIDE_STABLE
-Name nameMkStable =BOGUS(121); /* StablePtr# a -> StablePtr a */
-#endif
+Name nameMkC; /* Char# -> Char */
+Name nameMkI; /* Int# -> Int */
+Name nameMkInteger; /* Integer# -> Integer */
+Name nameMkW; /* Word# -> Word */
+Name nameMkA; /* Addr# -> Addr */
+Name nameMkF; /* Float# -> Float */
+Name nameMkD; /* Double# -> Double */
+Name nameMkPrimArray;
+Name nameMkPrimByteArray;
+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 =BOGUS(122); /* Weak# a -> Weak a */
+Name nameMkWeak; /* Weak# a -> Weak a */
#endif
#ifdef PROVIDE_FOREIGN
-Name nameMkForeign =BOGUS(123); /* ForeignObj# -> ForeignObj */
-#endif
-#ifdef PROVIDE_CONCURRENT
-Name nameMkThreadId =BOGUS(124); /* ThreadId# -> ThreadId */
-Name nameMkMVar =BOGUS(125); /* MVar# -> MVar */
+Name nameMkForeign; /* ForeignObj# -> ForeignObj */
#endif
-Name nameMinBnd =BOGUS(400);
-Name nameMaxBnd =BOGUS(401);
-Name nameCompare =BOGUS(402);
-Name nameShowsPrec =BOGUS(403);
-Name nameIndex =BOGUS(404);
-Name nameReadsPrec =BOGUS(405);
-Name nameRange =BOGUS(406);
-Name nameEQ =BOGUS(407);
-Name nameInRange =BOGUS(408);
-Name nameGt =BOGUS(409);
-Name nameLe =BOGUS(410);
-Name namePlus =BOGUS(411);
-Name nameMult =BOGUS(412);
-Name nameMFail =BOGUS(413);
-Type typeOrdering =BOGUS(414);
-Module modulePrelude =BOGUS(415);
-Name nameMap = BOGUS(416);
-Name nameMinus = BOGUS(417);
-
-#define QQ(lval) assert(lval != 0); assert(lval <= -900000); lval
+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:
* ------------------------------------------------------------------------*/
-/* ToDo: move these to link.c and call them 'typeXXXX' */
- Type arrow=BOGUS(500); /* mkOffset(0) -> mkOffset(1) */
- Type boundPair=BOGUS(500);; /* (mkOffset(0),mkOffset(0)) */
- Type listof=BOGUS(500);; /* [ mkOffset(0) ] */
- Type typeVarToVar=BOGUS(500);; /* mkOffset(0) -> mkOffset(0) */
+Type arrow; /* mkOffset(0) -> mkOffset(1) */
+Type boundPair; /* (mkOffset(0),mkOffset(0)) */
+Type listof; /* [ mkOffset(0) ] */
+Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
- Cell predNum=BOGUS(500);; /* Num (mkOffset(0)) */
- Cell predFractional=BOGUS(500);; /* Fractional (mkOffset(0)) */
- Cell predIntegral=BOGUS(500);; /* Integral (mkOffset(0)) */
- Kind starToStar=BOGUS(500);; /* Type -> Type */
- Cell predMonad=BOGUS(500);; /* Monad (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 */
/* --------------------------------------------------------------------------
*
initialised = TRUE;
setCurrModule(modulePrelude);
- QQ(typeChar ) = linkTycon("Char");
- QQ(typeInt ) = linkTycon("Int");
-#ifdef PROVIDE_INT64
- QQ(typeInt64 ) = linkTycon("Int64");
-#endif
-#ifdef PROVIDE_INTEGER
- QQ(typeInteger ) = linkTycon("Integer");
-#endif
-#ifdef PROVIDE_WORD
- QQ(typeWord ) = linkTycon("Word");
-#endif
-#ifdef PROVIDE_ADDR
- QQ(typeAddr ) = linkTycon("Addr");
-#endif
-#ifdef PROVIDE_ARRAY
- QQ(typePrimArray ) = linkTycon("PrimArray");
- QQ(typePrimByteArray) = linkTycon("PrimByteArray");
- QQ(typeRef ) = linkTycon("Ref");
- QQ(typePrimMutableArray) = linkTycon("PrimMutableArray");
- QQ(typePrimMutableByteArray) = linkTycon("PrimMutableByteArray");
-#endif
- QQ(typeFloat ) = linkTycon("Float");
- QQ(typeDouble ) = linkTycon("Double");
-#ifdef PROVIDE_STABLE
- QQ(typeStable ) = linkTycon("StablePtr");
-#endif
+ typeChar = linkTycon("Char");
+ typeInt = linkTycon("Int");
+ typeInteger = linkTycon("Integer");
+ typeWord = linkTycon("Word");
+ typeAddr = linkTycon("Addr");
+ typePrimArray = linkTycon("PrimArray");
+ typePrimByteArray = linkTycon("PrimByteArray");
+ typeRef = linkTycon("STRef");
+ typePrimMutableArray = linkTycon("PrimMutableArray");
+ typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
+ typeFloat = linkTycon("Float");
+ typeDouble = linkTycon("Double");
+ typeStable = linkTycon("StablePtr");
#ifdef PROVIDE_WEAK
- QQ(typeWeak ) = linkTycon("Weak");
+ typeWeak = linkTycon("Weak");
#endif
#ifdef PROVIDE_FOREIGN
- QQ(typeForeign ) = linkTycon("ForeignObj");
-#endif
-#ifdef PROVIDE_CONCURRENT
- QQ(typeThreadId ) = linkTycon("ThreadId");
- QQ(typeMVar ) = linkTycon("MVar");
-#endif
-
- QQ(typeBool ) = linkTycon("Bool");
- QQ(typeST ) = linkTycon("ST");
- QQ(typeIO ) = linkTycon("IO");
- QQ(typeException ) = linkTycon("Exception");
- //qqfail QQ(typeList ) = linkTycon("[]");
- //qqfail QQ(typeUnit ) = linkTycon("()");
- QQ(typeString ) = linkTycon("String");
- QQ(typeOrdering ) = linkTycon("Ordering");
-
- QQ(classEq ) = linkClass("Eq");
- QQ(classOrd ) = linkClass("Ord");
- QQ(classIx ) = linkClass("Ix");
- QQ(classEnum ) = linkClass("Enum");
- QQ(classShow ) = linkClass("Show");
- QQ(classRead ) = linkClass("Read");
- QQ(classBounded ) = linkClass("Bounded");
-#if EVAL_INSTANCES
- classEval = linkClass("Eval");
-#endif
- QQ(classReal ) = linkClass("Real");
- QQ(classIntegral ) = linkClass("Integral");
- QQ(classRealFrac ) = linkClass("RealFrac");
- QQ(classRealFloat) = linkClass("RealFloat");
- QQ(classFractional) = linkClass("Fractional");
- QQ(classFloating ) = linkClass("Floating");
- QQ(classNum ) = linkClass("Num");
- QQ(classMonad ) = linkClass("Monad");
+ 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(typeBignum,stdDefaults);
+ stdDefaults = cons(typeInteger,stdDefaults);
#else
stdDefaults = cons(typeInt,stdDefaults);
#endif
mkTypes();
- QQ(nameMkC ) = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
- QQ(nameMkI ) = addPrimCfunREP(findText("I#"),1,0,INT_REP);
-#ifdef PROVIDE_INT64
- QQ(nameMkInt64 ) = addPrimCfunREP(findText("Int64#"),1,0,INT64_REP);
-#endif
-#ifdef PROVIDE_WORD
- QQ(nameMkW ) = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
-#endif
-#ifdef PROVIDE_ADDR
- QQ(nameMkA ) = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
-#endif
- QQ(nameMkF ) = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
- QQ(nameMkD ) = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
-#ifdef PROVIDE_STABLE
- QQ(nameMkStable ) = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
-#endif
+ 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_INTEGER
- QQ(nameMkInteger ) = addPrimCfunREP(findText("Integer#"),1,0,0);
-#endif
#ifdef PROVIDE_FOREIGN
- QQ(nameMkForeign ) = addPrimCfunREP(findText("Foreign#"),1,0,0);
+ nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
#endif
#ifdef PROVIDE_WEAK
- QQ(nameMkWeak ) = addPrimCfunREP(findText("Weak#"),1,0,0);
-#endif
-#ifdef PROVIDE_ARRAY
- QQ(nameMkPrimArray ) = addPrimCfunREP(findText("PrimArray#"),1,0,0);
- QQ(nameMkPrimByteArray ) = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
- QQ(nameMkRef ) = addPrimCfunREP(findText("Ref#"),1,0,0);
- QQ(nameMkPrimMutableArray ) = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
- QQ(nameMkPrimMutableByteArray) = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
-#endif
-#ifdef PROVIDE_CONCURRENT
- QQ(nameMkThreadId) = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
- QQ(nameMkMVar ) = addPrimCfun(findTextREP("MVar#"),1,0,0);
+ 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);
+
/* 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");
= primType(MONAD_Id, "aH", "a");
name(namePrimRaise).type
= primType(MONAD_Id, "E", "a");
-#if EVAL_INSTANCES
- addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->) */
-#endif
+
+ /* 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 ( void )
{
- //qqfail QQ(arrow ) = fn(aVar,mkOffset(1));
- //qqfail QQ(listof ) = ap(typeList,aVar);
- QQ(predNum ) = ap(classNum,aVar);
- QQ(predFractional) = ap(classFractional,aVar);
- QQ(predIntegral ) = ap(classIntegral,aVar);
- QQ(predMonad ) = ap(classMonad,aVar);
+ predNum = ap(classNum,aVar);
+ predFractional = ap(classFractional,aVar);
+ predIntegral = ap(classIntegral,aVar);
+ predMonad = ap(classMonad,aVar);
+ typeProgIO = ap(typeIO,aVar);
}
Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
if (!initialised) {
Int i;
initialised = TRUE;
- ////setCurrModule(modulePreludeHugs);
+
setCurrModule(modulePrelude);
+
/* constructors */
- QQ(nameFalse ) = linkName("False");
- QQ(nameTrue ) = linkName("True");
- //qqfail QQ(nameNil ) = linkName("[]");
- //qqfail QQ(nameCons ) = linkName(":");
- //qqfail QQ(nameUnit ) = linkName("()");
+ nameFalse = linkName("False");
+ nameTrue = linkName("True");
+
/* members */
- QQ(nameEq ) = linkName("==");
- QQ(nameFromInt ) = linkName("fromInt");
- QQ(nameFromInteger) = linkName("fromInteger");
- QQ(nameFromDouble) = linkName("fromDouble");
-#if EVAL_INSTANCES
- nameStrict = linkName("strict");
- nameSeq = linkName("seq");
-#endif
- QQ(nameReturn ) = linkName("return");
- QQ(nameBind ) = linkName(">>=");
-
- QQ(nameLe ) = linkName("<=");
- QQ(nameGt ) = linkName(">");
- QQ(nameShowsPrec ) = linkName("showsPrec");
- QQ(nameReadsPrec ) = linkName("readsPrec");
- QQ(nameEQ ) = linkName("EQ");
- QQ(nameCompare ) = linkName("compare");
- QQ(nameMinBnd ) = linkName("minBound");
- QQ(nameMaxBnd ) = linkName("maxBound");
- QQ(nameRange ) = linkName("range");
- QQ(nameIndex ) = linkName("index");
- QQ(namePlus ) = linkName("+");
- QQ(nameMult ) = linkName("*");
- QQ(nameRangeSize ) = linkName("rangeSize");
- QQ(nameInRange ) = linkName("inRange");
- QQ(nameMinus ) = linkName("-");
+ 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);
setCurrModule(modulePrelude);
/* primops */
- QQ(nameMkIO) = linkName("primMkIO");
+ nameMkIO = linkName("primMkIO");
for (i=0; asmPrimOps[i].name; ++i) {
Text t = findText(asmPrimOps[i].name);
Name n = findName(t);
}
/* static(tidyInfix) */
- QQ(nameNegate ) = linkName("negate");
+ nameNegate = linkName("negate");
/* user interface */
- QQ(nameRunIO ) = linkName("primRunIO");
- QQ(namePrint ) = linkName("print");
- /* typechecker (undefined member functions) */
- //qqfail QQ(nameError ) = linkName("error");
+ nameRunIO = linkName("primRunIO_hugs_toplevel");
+ namePrint = linkName("print");
/* desugar */
- //qqfail QQ(nameId ) = linkName("id");
- QQ(nameOtherwise ) = linkName("otherwise");
- QQ(nameUndefined ) = linkName("undefined");
+ nameOtherwise = linkName("otherwise");
+ nameUndefined = linkName("undefined");
/* pmc */
#if NPLUSK
- namePmSub = linkName("primPmSub");
+ namePmSub = linkName("primPmSub");
#endif
/* translator */
- ////nameUnpackString = linkName("primUnpackString");
- ////namePMFail = linkName("primPmFail");
- QQ(nameEqChar ) = linkName("primEqChar");
- QQ(nameEqInt ) = linkName("primEqInt");
-#if !OVERLOADED_CONSTANTS
- QQ(nameEqInteger ) = linkName("primEqInteger");
-#endif /* !OVERLOADED_CONSTANTS */
- QQ(nameEqDouble ) = linkName("primEqDouble");
- QQ(namePmInt ) = linkName("primPmInt");
- ////namePmInteger = linkName("primPmInteger");
- ////namePmDouble = linkName("primPmDouble");
- ////namePmLe = linkName("primPmLe");
- ////namePmSubtract = linkName("primPmSubtract");
- ////namePmFromInteger = linkName("primPmFromInteger");
- ////QQ(nameMap ) = linkName("map");
+ nameEqChar = linkName("primEqChar");
+ nameCreateAdjThunk = linkName("primCreateAdjThunk");
+ namePmInt = linkName("primPmInt");
+ namePmInteger = linkName("primPmInteger");
+ namePmDouble = linkName("primPmDouble");
+
+ namePmFromInteger = linkName("primPmFromInteger");
+ namePmSubtract = linkName("primPmSubtract");
+ namePmLe = linkName("primPmLe");
}
}
/* ToDo: fix pFun (or eliminate its use) */
-#define pFun(n,s) QQ(n) = predefinePrim(s)
+#define pFun(n,s) n = predefinePrim(s)
Void linkControl(what)
Int what; {
+ Int i;
switch (what) {
case RESET :
case MARK :
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);
/* 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");
/* implementTagToCon */
pFun(namePMFail, "primPmFail");
- pFun(namePMFailBUG, "primPmFailBUG");
pFun(nameError, "error");
pFun(nameUnpackString, "primUnpackString");
pFun(namePrimSeq, "primSeq");
pFun(namePrimCatch, "primCatch");
pFun(namePrimRaise, "primRaise");
+ pFun(namePrimTakeMVar, "primTakeMVar");
{
StgVar vv = mkStgVar(NIL,NIL);
Name n = namePrimSeq;
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;
}
}
projects / ghc-hetmet.git / blobdiff