ghc/interpreter/link.c

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