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