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