ghc/interpreter/link.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Load symbols required from the Prelude
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * $RCSfile: link.c,v $
  10  * $Revision: 1.5 $
  11  * $Date: 1999/03/01 14:46:47 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "backend.h"
  17 #include "connect.h"
  18 #include "errors.h"
  19 #include "Assembler.h" /* for asmPrimOps and AsmReps */
  20
  21 #include "link.h"
  22
  23 ////Module modulePreludeHugs;
  24
  25
  26 Type typeArrow  =BOGUS(1);                         /* Function spaces                 */
  27
  28 Type typeChar  =BOGUS(2);
  29 Type typeInt  =BOGUS(3);
  30 #ifdef PROVIDE_INT64
  31 Type typeInt64  =BOGUS(4);
  32 #endif
  33 #ifdef PROVIDE_INTEGER
  34 Type typeInteger  =BOGUS(5);
  35 #endif
  36 #ifdef PROVIDE_WORD
  37 Type typeWord  =BOGUS(6);
  38 #endif
  39 #ifdef PROVIDE_ADDR
  40 Type typeAddr  =BOGUS(7);
  41 #endif
  42 #ifdef PROVIDE_ARRAY
  43 Type typePrimArray  =BOGUS(8);
  44 Type typePrimByteArray  =BOGUS(9);
  45 Type typeRef  =BOGUS(10);
  46 Type typePrimMutableArray  =BOGUS(11);
  47 Type typePrimMutableByteArray  =BOGUS(12);
  48 #endif
  49 Type typeFloat  =BOGUS(13);
  50 Type typeDouble  =BOGUS(14);
  51 #ifdef PROVIDE_STABLE
  52 Type typeStable  =BOGUS(15);
  53 #endif
  54 #ifdef PROVIDE_WEAK
  55 Type typeWeak  =BOGUS(16);
  56 #endif
  57 #ifdef PROVIDE_FOREIGN
  58 Type typeForeign  =BOGUS(17);
  59 #endif
  60 #ifdef PROVIDE_CONCURRENT
  61 Type typeThreadId  =BOGUS(18);
  62 Type typeMVar  =BOGUS(19);
  63 #endif
  64
  65 Type typeList  =BOGUS(20);
  66 Type typeUnit  =BOGUS(21);
  67 Type typeString  =BOGUS(22);
  68 Type typeBool  =BOGUS(23);
  69 Type typeST  =BOGUS(24);
  70 Type typeIO  =BOGUS(25);
  71 Type typeException  =BOGUS(26);
  72
  73 Class classEq  =BOGUS(27);                          /* `standard' classes              */
  74 Class classOrd  =BOGUS(28);
  75 Class classShow  =BOGUS(29);
  76 Class classRead  =BOGUS(30);
  77 Class classIx  =BOGUS(31);
  78 Class classEnum  =BOGUS(32);
  79 Class classBounded  =BOGUS(33);
  80 #if EVAL_INSTANCES
  81 Class classEval  =BOGUS(34);
  82 #endif
  83
  84 Class classReal  =BOGUS(35);                        /* `numeric' classes               */
  85 Class classIntegral  =BOGUS(36);
  86 Class classRealFrac  =BOGUS(37);
  87 Class classRealFloat  =BOGUS(38);
  88 Class classFractional  =BOGUS(39);
  89 Class classFloating  =BOGUS(40);
  90 Class classNum  =BOGUS(41);
  91
  92 Class classMonad  =BOGUS(42);                       /* Monads and monads with a zero   */
  93 /*Class classMonad0  =BOGUS();*/
  94
  95 List stdDefaults  =BOGUS(43);                       /* standard default values         */
  96
  97 Name nameTrue  =BOGUS(44),
  98      nameFalse  =BOGUS(45);            /* primitive boolean constructors  */
  99 Name nameNil  =BOGUS(46),
 100      nameCons  =BOGUS(47);             /* primitive list constructors     */
 101 Name nameUnit  =BOGUS(48);                          /* primitive Unit type constructor */
 102
 103 Name nameEq  =BOGUS(49);
 104 Name nameFromInt  =BOGUS(50),
 105      nameFromDouble  =BOGUS(51);       /* coercion of numerics            */
 106 Name nameFromInteger  =BOGUS(52);
 107 Name nameReturn  =BOGUS(53),
 108      nameBind  =BOGUS(54);             /* for translating monad comps     */
 109 Name nameZero  =BOGUS(55);                          /* for monads with a zero          */
 110 #if EVAL_INSTANCES
 111 Name nameStrict  =BOGUS(56);                        /* Members of class Eval           */
 112 Name nameSeq  =BOGUS(57);
 113 #endif
 114
 115 Name nameId  =BOGUS(58);
 116 Name nameRunIO  =BOGUS(59);
 117 Name namePrint  =BOGUS(60);
 118
 119 Name nameOtherwise  =BOGUS(61);
 120 Name nameUndefined  =BOGUS(62);                     /* generic undefined value         */
 121 #if NPLUSK
 122 Name namePmSub  =BOGUS(63);
 123 #endif
 124 Name namePMFail  =BOGUS(64);
 125 Name nameEqChar  =BOGUS(65);
 126 Name nameEqInt  =BOGUS(66);
 127 #if !OVERLOADED_CONSTANTS
 128 Name nameEqInteger  =BOGUS(67);
 129 #endif
 130 Name nameEqDouble  =BOGUS(68);
 131 Name namePmInt  =BOGUS(69);
 132 Name namePmInteger  =BOGUS(70);
 133 Name namePmDouble  =BOGUS(71);
 134 Name namePmLe  =BOGUS(72);
 135 Name namePmSubtract  =BOGUS(73);
 136 Name namePmFromInteger  =BOGUS(74);
 137 Name nameMkIO  =BOGUS(75);
 138 Name nameUnpackString  =BOGUS(76);
 139 Name nameError  =BOGUS(77);
 140 Name nameInd  =BOGUS(78);
 141
 142 Name nameForce  =BOGUS(79);
 143
 144 Name nameAnd  =BOGUS(80);
 145 Name nameConCmp  =BOGUS(82);
 146 Name nameCompAux  =BOGUS(83);
 147 Name nameEnFrTh  =BOGUS(84);
 148 Name nameEnFrTo  =BOGUS(85);
 149 Name nameEnFrom  =BOGUS(86);
 150 Name nameEnFrEn  =BOGUS(87);
 151 Name nameEnToEn  =BOGUS(88);
 152 Name nameEnInRng  =BOGUS(89);
 153 Name nameEnIndex  =BOGUS(90);
 154 Name nameEnRange  =BOGUS(91);
 155 Name nameRangeSize  =BOGUS(92);
 156 Name nameComp  =BOGUS(93);
 157 Name nameShowField  =BOGUS(94);
 158 Name nameApp  =BOGUS(95);
 159 Name nameShowParen  =BOGUS(96);
 160 Name nameReadParen  =BOGUS(97);
 161 Name nameLex  =BOGUS(98);
 162 Name nameReadField  =BOGUS(99);
 163 Name nameFlip  =BOGUS(100);
 164 Name nameFromTo  =BOGUS(101);
 165 Name nameFromThen  =BOGUS(102);
 166 Name nameFrom  =BOGUS(103);
 167 Name nameFromThenTo  =BOGUS(104);
 168 Name nameNegate  =BOGUS(105);
 169
 170 /* these names are required before we've had a chance to do the right thing */
 171 Name nameSel  =BOGUS(106);
 172 Name nameUnsafeUnpackCString  =BOGUS(107);
 173
 174 /* constructors used during translation and codegen */
 175 Name nameMkC  =BOGUS(108);                           /* Char#        -> Char           */
 176 Name nameMkI  =BOGUS(109);                           /* Int#         -> Int            */
 177 #ifdef PROVIDE_INT64
 178 Name nameMkInt64  =BOGUS(110);                       /* Int64#       -> Int64          */
 179 #endif
 180 #ifdef PROVIDE_INTEGER
 181 Name nameMkInteger  =BOGUS(111);                     /* Integer#     -> Integer        */
 182 #endif
 183 #ifdef PROVIDE_WORD
 184 Name nameMkW  =BOGUS(112);                           /* Word#        -> Word           */
 185 #endif
 186 #ifdef PROVIDE_ADDR
 187 Name nameMkA  =BOGUS(113);                           /* Addr#        -> Addr            */
 188 #endif
 189 Name nameMkF  =BOGUS(114);                           /* Float#       -> Float           */
 190 Name nameMkD  =BOGUS(115);                           /* Double#      -> Double          */
 191 #ifdef PROVIDE_ARRAY
 192 Name nameMkPrimArray  =BOGUS(116);
 193 Name nameMkPrimByteArray  =BOGUS(117);
 194 Name nameMkRef  =BOGUS(118);
 195 Name nameMkPrimMutableArray  =BOGUS(119);
 196 Name nameMkPrimMutableByteArray  =BOGUS(120);
 197 #endif
 198 #ifdef PROVIDE_STABLE
 199 Name nameMkStable  =BOGUS(121);                      /* StablePtr# a -> StablePtr a     */
 200 #endif
 201 #ifdef PROVIDE_WEAK
 202 Name nameMkWeak  =BOGUS(122);                        /* Weak# a      -> Weak a          */
 203 #endif
 204 #ifdef PROVIDE_FOREIGN
 205 Name nameMkForeign  =BOGUS(123);                     /* ForeignObj#  -> ForeignObj      */
 206 #endif
 207 #ifdef PROVIDE_CONCURRENT
 208 Name nameMkThreadId  =BOGUS(124);                    /* ThreadId#    -> ThreadId        */
 209 Name nameMkMVar  =BOGUS(125);                        /* MVar#        -> MVar            */
 210 #endif
 211
 212
 213
 214 Name nameMinBnd =BOGUS(400);
 215 Name  nameMaxBnd =BOGUS(401);
 216 Name  nameCompare =BOGUS(402);
 217 Name nameShowsPrec =BOGUS(403);
 218 Name  nameIndex =BOGUS(404);
 219 Name nameReadsPrec =BOGUS(405);
 220 Name nameRange =BOGUS(406);
 221 Name nameEQ =BOGUS(407);
 222 Name nameInRange =BOGUS(408);
 223 Name nameGt =BOGUS(409);
 224 Name nameLe =BOGUS(410);
 225 Name namePlus =BOGUS(411);
 226 Name nameMult =BOGUS(412);
 227 Name nameMFail =BOGUS(413);
 228 Type typeOrdering =BOGUS(414);
 229 Module modulePrelude =BOGUS(415);
 230
 231 #define QQ(lval) assert(lval != 0); assert(lval <= -900000); lval
 232
 233 /* --------------------------------------------------------------------------
 234  * Frequently used type skeletons:
 235  * ------------------------------------------------------------------------*/
 236
 237 /* ToDo: move these to link.c and call them 'typeXXXX' */
 238        Type  arrow=BOGUS(500);                     /* mkOffset(0) -> mkOffset(1)      */
 239        Type  boundPair=BOGUS(500);;                 /* (mkOffset(0),mkOffset(0))       */
 240        Type  listof=BOGUS(500);;                    /* [ mkOffset(0) ]                 */
 241        Type  typeVarToVar=BOGUS(500);;              /* mkOffset(0) -> mkOffset(0)      */
 242
 243        Cell  predNum=BOGUS(500);;                   /* Num (mkOffset(0))               */
 244        Cell  predFractional=BOGUS(500);;            /* Fractional (mkOffset(0))        */
 245        Cell  predIntegral=BOGUS(500);;              /* Integral (mkOffset(0))          */
 246        Kind  starToStar=BOGUS(500);;                /* Type -> Type                    */
 247        Cell  predMonad=BOGUS(500);;                 /* Monad (mkOffset(0))             */
 248
 249 /* --------------------------------------------------------------------------
 250  *
 251  * ------------------------------------------------------------------------*/
 252
 253 static Tycon linkTycon ( String s );
 254 static Tycon linkClass ( String s );
 255 static Name  linkName  ( String s );
 256 static Void  mkTypes   ( void );
 257
 258
 259 static Tycon linkTycon( String s )
 260 {
 261     Tycon tc = findTycon(findText(s));
 262     if (nonNull(tc)) {
 263         return tc;
 264     }
 265     ERRMSG(0) "Prelude does not define standard type \"%s\"", s
 266     EEND;
 267 }
 268
 269 static Class linkClass( String s )
 270 {
 271     Class cc = findClass(findText(s));
 272     if (nonNull(cc)) {
 273         return cc;
 274     }
 275     ERRMSG(0) "Prelude does not define standard class \"%s\"", s
 276     EEND;
 277 }
 278
 279 static Name linkName( String s )
 280 {
 281     Name n = findName(findText(s));
 282     if (nonNull(n)) {
 283         return n;
 284     }
 285     ERRMSG(0) "Prelude does not define standard name \"%s\"", s
 286     EEND;
 287 }
 288
 289 /* ToDo: kill this! */
 290 static Name  predefinePrim ( String s );
 291 static Name  predefinePrim ( String s )
 292 {
 293     Name nm = newName(findText(s),NIL);
 294     name(nm).defn=PREDEFINED;
 295     return nm;
 296 }
 297
 298 Void linkPreludeTC(void) {              /* Hook to tycons and classes in   */
 299     static Bool initialised = FALSE;    /* prelude when first loaded       */
 300     if (!initialised) {
 301         Int i;
 302         initialised = TRUE;
 303         ////setCurrModule(modulePreludeHugs);
 304         setCurrModule(modulePrelude);
 305
 306         QQ(typeChar      )  = linkTycon("Char");
 307         QQ(typeInt       )  = linkTycon("Int");
 308 #ifdef PROVIDE_INT64
 309         QQ(typeInt64     )  = linkTycon("Int64");
 310 #endif
 311 #ifdef PROVIDE_INTEGER
 312         QQ(typeInteger   )  = linkTycon("Integer");
 313 #endif
 314 #ifdef PROVIDE_WORD
 315         QQ(typeWord      )  = linkTycon("Word");
 316 #endif
 317 #ifdef PROVIDE_ADDR
 318         QQ(typeAddr      )  = linkTycon("Addr");
 319 #endif
 320 #ifdef PROVIDE_ARRAY
 321         QQ(typePrimArray )           = linkTycon("PrimArray");
 322         QQ(typePrimByteArray)        = linkTycon("PrimByteArray");
 323         QQ(typeRef       )           = linkTycon("Ref");
 324         QQ(typePrimMutableArray)     = linkTycon("PrimMutableArray");
 325         QQ(typePrimMutableByteArray) = linkTycon("PrimMutableByteArray");
 326 #endif
 327         QQ(typeFloat     )  = linkTycon("Float");
 328         QQ(typeDouble    )  = linkTycon("Double");
 329 #ifdef PROVIDE_STABLE
 330         QQ(typeStable    )  = linkTycon("StablePtr");
 331 #endif
 332 #ifdef PROVIDE_WEAK
 333         QQ(typeWeak      )  = linkTycon("Weak");
 334 #endif
 335 #ifdef PROVIDE_FOREIGN
 336         QQ(typeForeign   )  = linkTycon("ForeignObj");
 337 #endif
 338 #ifdef PROVIDE_CONCURRENT
 339         QQ(typeThreadId  )  = linkTycon("ThreadId");
 340         QQ(typeMVar      )  = linkTycon("MVar");
 341 #endif
 342
 343         QQ(typeBool      )  = linkTycon("Bool");
 344         QQ(typeST        )  = linkTycon("ST");
 345         QQ(typeIO        )  = linkTycon("IO");
 346         QQ(typeException )  = linkTycon("Exception");
 347         //qqfail QQ(typeList      )  = linkTycon("[]");
 348         //qqfail QQ(typeUnit      )  = linkTycon("()");
 349         QQ(typeString    )  = linkTycon("String");
 350         QQ(typeOrdering  )  = linkTycon("Ordering");
 351
 352         QQ(classEq       )  = linkClass("Eq");
 353         QQ(classOrd      )  = linkClass("Ord");
 354         QQ(classIx       )  = linkClass("Ix");
 355         QQ(classEnum     )  = linkClass("Enum");
 356         QQ(classShow     )  = linkClass("Show");
 357         QQ(classRead     )  = linkClass("Read");
 358         QQ(classBounded  )  = linkClass("Bounded");
 359 #if EVAL_INSTANCES
 360         classEval       = linkClass("Eval");
 361 #endif
 362         QQ(classReal     )  = linkClass("Real");
 363         QQ(classIntegral )  = linkClass("Integral");
 364         QQ(classRealFrac )  = linkClass("RealFrac");
 365         QQ(classRealFloat)  = linkClass("RealFloat");
 366         QQ(classFractional) = linkClass("Fractional");
 367         QQ(classFloating )  = linkClass("Floating");
 368         QQ(classNum      )  = linkClass("Num");
 369         QQ(classMonad    )  = linkClass("Monad");
 370
 371         stdDefaults     = NIL;
 372         stdDefaults     = cons(typeDouble,stdDefaults);
 373 #if DEFAULT_BIGNUM
 374         stdDefaults     = cons(typeBignum,stdDefaults);
 375 #else
 376         stdDefaults     = cons(typeInt,stdDefaults);
 377 #endif
 378         mkTypes();
 379
 380         QQ(nameMkC       )  = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
 381         QQ(nameMkI       )  = addPrimCfunREP(findText("I#"),1,0,INT_REP);
 382 #ifdef PROVIDE_INT64
 383         QQ(nameMkInt64   )  = addPrimCfunREP(findText("Int64#"),1,0,INT64_REP);
 384 #endif
 385 #ifdef PROVIDE_WORD
 386         QQ(nameMkW       )  = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
 387 #endif
 388 #ifdef PROVIDE_ADDR
 389         QQ(nameMkA       )  = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
 390 #endif
 391         QQ(nameMkF       )  = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
 392         QQ(nameMkD       )  = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
 393 #ifdef PROVIDE_STABLE
 394         QQ(nameMkStable  )  = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
 395 #endif
 396
 397 #ifdef PROVIDE_INTEGER
 398         QQ(nameMkInteger )  = addPrimCfunREP(findText("Integer#"),1,0,0);
 399 #endif
 400 #ifdef PROVIDE_FOREIGN
 401         QQ(nameMkForeign )  = addPrimCfunREP(findText("Foreign#"),1,0,0);
 402 #endif
 403 #ifdef PROVIDE_WEAK
 404         QQ(nameMkWeak    )  = addPrimCfunREP(findText("Weak#"),1,0,0);
 405 #endif
 406 #ifdef PROVIDE_ARRAY
 407         QQ(nameMkPrimArray           ) = addPrimCfunREP(findText("PrimArray#"),1,0,0);
 408         QQ(nameMkPrimByteArray       ) = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
 409         QQ(nameMkRef                 ) = addPrimCfunREP(findText("Ref#"),1,0,0);
 410         QQ(nameMkPrimMutableArray    ) = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
 411         QQ(nameMkPrimMutableByteArray) = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
 412 #endif
 413 #ifdef PROVIDE_CONCURRENT
 414         QQ(nameMkThreadId)  = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
 415         QQ(nameMkMVar    )  = addPrimCfun(findTextREP("MVar#"),1,0,0);
 416 #endif
 417 #if 1
 418         /* The following primitives are referred to in derived instances and
 419          * hence require types; the following types are a little more general
 420          * than we might like, but they are the closest we can get without a
 421          * special datatype class.
 422          */
 423         name(nameConCmp).type
 424             = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
 425         name(nameEnRange).type
 426             = mkPolyType(starToStar,fn(boundPair,listof));
 427         name(nameEnIndex).type
 428             = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
 429         name(nameEnInRng).type
 430             = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
 431         name(nameEnToEn).type
 432             = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
 433         name(nameEnFrEn).type
 434             = mkPolyType(starToStar,fn(aVar,typeInt));
 435         name(nameEnFrom).type
 436             = mkPolyType(starToStar,fn(aVar,listof));
 437         name(nameEnFrTo).type
 438             = name(nameEnFrTh).type
 439             = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
 440 #endif
 441 #if EVAL_INSTANCES
 442         addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->)     */
 443 #endif
 444
 445         for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
 446 #if EVAL_INSTANCES
 447             addEvalInst(0,mkTuple(i),i,NIL);
 448 #endif
 449 #if DERIVE_EQ
 450             addTupInst(classEq,i);
 451 #endif
 452 #if DERIVE_ORD
 453             addTupInst(classOrd,i);
 454 #endif
 455 #if DERIVE_IX
 456             addTupInst(classIx,i);
 457 #endif
 458 #if DERIVE_SHOW
 459             addTupInst(classShow,i);
 460 #endif
 461 #if DERIVE_READ
 462             addTupInst(classRead,i);
 463 #endif
 464 #if DERIVE_BOUNDED
 465             addTupInst(classBounded,i);
 466 #endif
 467         }
 468     }
 469 }
 470
 471 static Void mkTypes ( void )
 472 {
 473         //qqfail QQ(arrow         ) = fn(aVar,mkOffset(1));
 474         //qqfail QQ(listof        ) = ap(typeList,aVar);
 475         QQ(predNum       ) = ap(classNum,aVar);
 476         QQ(predFractional) = ap(classFractional,aVar);
 477         QQ(predIntegral  ) = ap(classIntegral,aVar);
 478         QQ(predMonad     ) = ap(classMonad,aVar);
 479 }
 480
 481 Void linkPreludeCM(void) {              /* Hook to cfuns and mfuns in      */
 482     static Bool initialised = FALSE;    /* prelude when first loaded       */
 483     if (!initialised) {
 484         Int i;
 485         initialised = TRUE;
 486         ////setCurrModule(modulePreludeHugs);
 487         setCurrModule(modulePrelude);
 488         /* constructors */
 489         QQ(nameFalse     )  = linkName("False");
 490         QQ(nameTrue      )  = linkName("True");
 491         //qqfail QQ(nameNil       )  = linkName("[]");
 492         //qqfail QQ(nameCons      )  = linkName(":");
 493         //qqfail QQ(nameUnit      )  = linkName("()");
 494         /* members */
 495         QQ(nameEq        )  = linkName("==");
 496         QQ(nameFromInt   )  = linkName("fromInt");
 497         QQ(nameFromInteger) = linkName("fromInteger");
 498         QQ(nameFromDouble)  = linkName("fromDouble");
 499 #if EVAL_INSTANCES
 500         nameStrict      = linkName("strict");
 501         nameSeq         = linkName("seq");
 502 #endif
 503         QQ(nameReturn    )  = linkName("return");
 504         QQ(nameBind      )  = linkName(">>=");
 505
 506         QQ(nameLe        )  = linkName("<=");
 507         QQ(nameGt        )  = linkName(">");
 508         QQ(nameShowsPrec )  = linkName("showsPrec");
 509         QQ(nameReadsPrec )  = linkName("readsPrec");
 510         QQ(nameEQ        )  = linkName("EQ");
 511         QQ(nameCompare   )  = linkName("compare");
 512         QQ(nameMinBnd    )  = linkName("minBound");
 513         QQ(nameMaxBnd    )  = linkName("maxBound");
 514         QQ(nameRange     )  = linkName("range");
 515         QQ(nameIndex     )  = linkName("index");
 516         QQ(namePlus      )  = linkName("+");
 517         QQ(nameMult      )  = linkName("*");
 518         QQ(nameRangeSize )  = linkName("rangeSize");
 519         QQ(nameInRange   )  = linkName("inRange");
 520         /* These come before calls to implementPrim */
 521         for(i=0; i<NUM_TUPLES; ++i) {
 522             implementTuple(i);
 523         }
 524     }
 525 }
 526
 527 Void linkPreludeNames(void) {           /* Hook to names defined in Prelude */
 528     static Bool initialised = FALSE;
 529     if (!initialised) {
 530         Int i;
 531         initialised = TRUE;
 532
 533         setCurrModule(modulePrelude);
 534
 535         /* primops */
 536         QQ(nameMkIO)          = linkName("primMkIO");
 537         for (i=0; asmPrimOps[i].name; ++i) {
 538             Text t = findText(asmPrimOps[i].name);
 539             Name n = findName(t);
 540             if (isNull(n)) {
 541                 n = newName(t,NIL);
 542             }
 543             name(n).line   = 0;
 544             name(n).defn   = NIL;
 545             name(n).type   = primType(asmPrimOps[i].monad,
 546                                       asmPrimOps[i].args,
 547                                       asmPrimOps[i].results);
 548             name(n).arity  = strlen(asmPrimOps[i].args);
 549             name(n).primop = &(asmPrimOps[i]);
 550             implementPrim(n);
 551         }
 552
 553         /* hooks for handwritten bytecode */
 554         {
 555            StgVar vv = mkStgVar(NIL,NIL);
 556            Text t = findText("primSeq");
 557            Name n = newName(t,NIL);
 558            name(n).line = name(n).defn = 0;
 559            name(n).arity = 1;
 560            name(n).type = primType(MONAD_Id, "ab", "b");
 561            vv = mkStgVar(NIL,NIL);
 562            stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
 563            name(n).stgVar = vv;
 564            stgGlobals=cons(pair(n,vv),stgGlobals);
 565         }
 566
 567         {
 568            StgVar vv = mkStgVar(NIL,NIL);
 569            Text t = findText("primCatch");
 570            Name n = newName(t,NIL);
 571            name(n).line = name(n).defn = 0;
 572            name(n).arity = 2;
 573            name(n).type = primType(MONAD_Id, "aH", "a");
 574            stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
 575            name(n).stgVar = vv;
 576            stgGlobals=cons(pair(n,vv),stgGlobals);
 577         }
 578
 579         {
 580            StgVar vv = mkStgVar(NIL,NIL);
 581            Text t = findText("primRaise");
 582            Name n = newName(t,NIL);
 583            name(n).line = name(n).defn = 0;
 584            name(n).arity = 1;
 585            name(n).type = primType(MONAD_Id, "E", "a");
 586            stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
 587            name(n).stgVar = vv;
 588            stgGlobals=cons(pair(n,vv),stgGlobals);
 589         }
 590
 591         /* static(tidyInfix)                        */
 592         QQ(nameNegate    )    = linkName("negate");
 593         /* user interface                           */
 594         QQ(nameRunIO     )    = linkName("primRunIO");
 595         QQ(namePrint     )    = linkName("print");
 596         /* typechecker (undefined member functions) */
 597         //qqfail QQ(nameError     )    = linkName("error");
 598         /* desugar                                  */
 599         //qqfail QQ(nameId        )    = linkName("id");
 600         QQ(nameOtherwise )    = linkName("otherwise");
 601         QQ(nameUndefined )    = linkName("undefined");
 602         /* pmc                                      */
 603 #if NPLUSK
 604         namePmSub         = linkName("primPmSub");
 605 #endif
 606         /* translator                               */
 607         ////nameUnpackString  = linkName("primUnpackString");
 608         ////namePMFail        = linkName("primPmFail");
 609         QQ(nameEqChar    )    = linkName("primEqChar");
 610         QQ(nameEqInt     )    = linkName("primEqInt");
 611 #if !OVERLOADED_CONSTANTS
 612         QQ(nameEqInteger )    = linkName("primEqInteger");
 613 #endif /* !OVERLOADED_CONSTANTS */
 614         QQ(nameEqDouble  )    = linkName("primEqDouble");
 615         QQ(namePmInt     )    = linkName("primPmInt");
 616         ////namePmInteger     = linkName("primPmInteger");
 617         ////namePmDouble      = linkName("primPmDouble");
 618         ////namePmLe          = linkName("primPmLe");
 619         ////namePmSubtract    = linkName("primPmSubtract");
 620         ////namePmFromInteger = linkName("primPmFromInteger");
 621     }
 622 }
 623
 624
 625 /* ToDo: fix pFun (or eliminate its use) */
 626 #define pFun(n,s)    QQ(n) = predefinePrim(s)
 627
 628 Void linkControl(what)
 629 Int what; {
 630     switch (what) {
 631         case RESET   :
 632         case MARK    :
 633                        break;
 634
 635         case INSTALL : linkControl(RESET);
 636
 637                        modulePrelude = newModule(textPrelude);
 638                        setCurrModule(modulePrelude);
 639
 640                        typeArrow = addPrimTycon(findText("(->)"),
 641                                                 pair(STAR,pair(STAR,STAR)),
 642                                                 2,DATATYPE,NIL);
 643
 644                        /* newtype and USE_NEWTYPE_FOR_DICTS     */
 645                        pFun(nameId,             "id");
 646
 647                        /* desugaring                            */
 648                        pFun(nameInd,            "_indirect");
 649                        name(nameInd).number = DFUNNAME;
 650
 651                        /* pmc                                   */
 652                        pFun(nameSel,            "_SEL");
 653
 654                        /* strict constructors                   */
 655                        pFun(nameFlip,           "flip"     );
 656
 657                        /* parser                                */
 658                        pFun(nameFromTo,         "enumFromTo");
 659                        pFun(nameFromThenTo,     "enumFromThenTo");
 660                        pFun(nameFrom,           "enumFrom");
 661                        pFun(nameFromThen,       "enumFromThen");
 662
 663                        /* deriving                              */
 664                        pFun(nameApp,            "++");
 665                        pFun(nameReadParen,      "readParen");
 666                        pFun(nameShowParen,      "showParen");
 667                        pFun(nameLex,            "lex");
 668                        pFun(nameEnToEn,         "toEnumPR"); //not sure
 669                        pFun(nameEnFrEn,         "fromEnum"); //not sure
 670                        pFun(nameEnFrom,         "enumFrom"); //not sure
 671                        pFun(nameEnFrTh,         "enumFromThen"); //not sure
 672                        pFun(nameEnFrTo,         "enumFromTo"); //not sure
 673                        pFun(nameEnRange,        "range"); //not sure
 674                        pFun(nameEnIndex,        "index"); //not sure
 675                        pFun(nameEnInRng,        "inRange"); //not sure
 676                        pFun(nameConCmp,         "_concmp"); //very not sure
 677                        pFun(nameComp,           ".");
 678                        pFun(nameAnd,            "&&");
 679                        pFun(nameCompAux,        "primCompAux");
 680
 681                        /* implementTagToCon                     */
 682                        pFun(namePMFail,         "primPmFail");
 683                        pFun(nameError,          "error");
 684                        pFun(nameUnpackString,   "primUnpackString");
 685
 686                        break;
 687     }
 688 }
 689 #undef pFun
 690
 691
 692 /*-------------------------------------------------------------------------*/