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.3 $
  11  * $Date: 1999/01/13 16:47:27 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "static.h"
  18 #include "translate.h"
  19 #include "type.h"
  20 #include "errors.h"
  21 #include "Assembler.h" /* for asmPrimOps and AsmReps */
  22
  23 #include "link.h"
  24
  25 Module modulePreludeHugs;
  26
  27 Type typeArrow;                         /* Function spaces                 */
  28
  29 Type typeChar;
  30 Type typeInt;
  31 #ifdef PROVIDE_INT64
  32 Type typeInt64;
  33 #endif
  34 #ifdef PROVIDE_INTEGER
  35 Type typeInteger;
  36 #endif
  37 #ifdef PROVIDE_WORD
  38 Type typeWord;
  39 #endif
  40 #ifdef PROVIDE_ADDR
  41 Type typeAddr;
  42 #endif
  43 #ifdef PROVIDE_ARRAY
  44 Type typePrimArray;
  45 Type typePrimByteArray;
  46 Type typeRef;
  47 Type typePrimMutableArray;
  48 Type typePrimMutableByteArray;
  49 #endif
  50 Type typeFloat;
  51 Type typeDouble;
  52 #ifdef PROVIDE_STABLE
  53 Type typeStable;
  54 #endif
  55 #ifdef PROVIDE_WEAK
  56 Type typeWeak;
  57 #endif
  58 #ifdef PROVIDE_FOREIGN
  59 Type typeForeign;
  60 #endif
  61 #ifdef PROVIDE_CONCURRENT
  62 Type typeThreadId;
  63 Type typeMVar;
  64 #endif
  65
  66 Type typeList;
  67 Type typeUnit;
  68 Type typeString;
  69 Type typeBool;
  70 Type typeST;
  71 Type typeIO;
  72 Type typeException;
  73
  74 Class classEq;                          /* `standard' classes              */
  75 Class classOrd;
  76 Class classShow;
  77 Class classRead;
  78 Class classIx;
  79 Class classEnum;
  80 Class classBounded;
  81 #if EVAL_INSTANCES
  82 Class classEval;
  83 #endif
  84
  85 Class classReal;                        /* `numeric' classes               */
  86 Class classIntegral;
  87 Class classRealFrac;
  88 Class classRealFloat;
  89 Class classFractional;
  90 Class classFloating;
  91 Class classNum;
  92
  93 Class classMonad;                       /* Monads and monads with a zero   */
  94 Class classMonad0;
  95
  96 List stdDefaults;                       /* standard default values         */
  97
  98 Name nameTrue,    nameFalse;            /* primitive boolean constructors  */
  99 Name nameNil,     nameCons;             /* primitive list constructors     */
 100 Name nameUnit;                          /* primitive Unit type constructor */
 101
 102 Name nameEq;
 103 Name nameFromInt, nameFromDouble;       /* coercion of numerics            */
 104 Name nameFromInteger;
 105 Name nameReturn,  nameBind;             /* for translating monad comps     */
 106 Name nameZero;                          /* for monads with a zero          */
 107 #if EVAL_INSTANCES
 108 Name nameStrict;                        /* Members of class Eval           */
 109 Name nameSeq;
 110 #endif
 111
 112 Name nameId;
 113 Name nameRunIO;
 114 Name namePrint;
 115
 116 Name nameOtherwise;
 117 Name nameUndefined;                     /* generic undefined value         */
 118 #if NPLUSK
 119 Name namePmSub;
 120 #endif
 121 Name namePMFail;
 122 Name nameEqChar;
 123 Name nameEqInt;
 124 #if !OVERLOADED_CONSTANTS
 125 Name nameEqInteger;
 126 #endif
 127 Name nameEqDouble;
 128 Name namePmInt;
 129 Name namePmInteger;
 130 Name namePmDouble;
 131 Name namePmLe;
 132 Name namePmSubtract;
 133 Name namePmFromInteger;
 134 Name nameMkIO;
 135 Name nameUnpackString;
 136 Name nameError;
 137 Name nameInd;
 138
 139 Name nameForce;
 140
 141 /* these names are required before we've had a chance to do the right thing */
 142 Name nameSel;
 143 Name nameUnsafeUnpackCString;
 144
 145 /* constructors used during translation and codegen */
 146 Name nameMkC;                           /* Char#        -> Char           */
 147 Name nameMkI;                           /* Int#         -> Int            */
 148 #ifdef PROVIDE_INT64
 149 Name nameMkInt64;                       /* Int64#       -> Int64          */
 150 #endif
 151 #ifdef PROVIDE_INTEGER
 152 Name nameMkInteger;                     /* Integer#     -> Integer        */
 153 #endif
 154 #ifdef PROVIDE_WORD
 155 Name nameMkW;                           /* Word#        -> Word           */
 156 #endif
 157 #ifdef PROVIDE_ADDR
 158 Name nameMkA;                           /* Addr#        -> Addr            */
 159 #endif
 160 Name nameMkF;                           /* Float#       -> Float           */
 161 Name nameMkD;                           /* Double#      -> Double          */
 162 #ifdef PROVIDE_ARRAY
 163 Name nameMkPrimArray;
 164 Name nameMkPrimByteArray;
 165 Name nameMkRef;
 166 Name nameMkPrimMutableArray;
 167 Name nameMkPrimMutableByteArray;
 168 #endif
 169 #ifdef PROVIDE_STABLE
 170 Name nameMkStable;                      /* StablePtr# a -> StablePtr a     */
 171 #endif
 172 #ifdef PROVIDE_WEAK
 173 Name nameMkWeak;                        /* Weak# a      -> Weak a          */
 174 #endif
 175 #ifdef PROVIDE_FOREIGN
 176 Name nameMkForeign;                     /* ForeignObj#  -> ForeignObj      */
 177 #endif
 178 #ifdef PROVIDE_CONCURRENT
 179 Name nameMkThreadId;                    /* ThreadId#    -> ThreadId        */
 180 Name nameMkMVar;                        /* MVar#        -> MVar            */
 181 #endif
 182
 183 /* --------------------------------------------------------------------------
 184  *
 185  * ------------------------------------------------------------------------*/
 186
 187 static Tycon linkTycon( String s );
 188 static Tycon linkClass( String s );
 189 static Name  linkName ( String s );
 190
 191 static Tycon linkTycon( String s )
 192 {
 193     Tycon tc = findTycon(findText(s));
 194     if (nonNull(tc)) {
 195         return tc;
 196     }
 197     ERRMSG(0) "Prelude does not define standard type \"%s\"", s
 198     EEND;
 199 }
 200
 201 static Class linkClass( String s )
 202 {
 203     Class cc = findClass(findText(s));
 204     if (nonNull(cc)) {
 205         return cc;
 206     }
 207     ERRMSG(0) "Prelude does not define standard class \"%s\"", s
 208     EEND;
 209 }
 210
 211 static Name linkName( String s )
 212 {
 213     Name n = findName(findText(s));
 214     if (nonNull(n)) {
 215         return n;
 216     }
 217     ERRMSG(0) "Prelude does not define standard name \"%s\"", s
 218     EEND;
 219 }
 220
 221 /* ToDo: kill this! */
 222 static Name  predefinePrim ( String s );
 223 static Name  predefinePrim ( String s )
 224 {
 225     Name nm = newName(findText(s));
 226     name(nm).defn=PREDEFINED;
 227     return nm;
 228 }
 229
 230 Void linkPreludeTC() {                  /* Hook to tycons and classes in   */
 231     static Bool initialised = FALSE;    /* prelude when first loaded       */
 232     if (!initialised) {
 233         Int i;
 234         initialised = TRUE;
 235         setCurrModule(modulePreludeHugs);
 236
 237         typeChar        = linkTycon("Char");
 238         typeInt         = linkTycon("Int");
 239 #ifdef PROVIDE_INT64
 240         typeInt64       = linkTycon("Int64");
 241 #endif
 242 #ifdef PROVIDE_INTEGER
 243         typeInteger     = linkTycon("Integer");
 244 #endif
 245 #ifdef PROVIDE_WORD
 246         typeWord        = linkTycon("Word");
 247 #endif
 248 #ifdef PROVIDE_ADDR
 249         typeAddr        = linkTycon("Addr");
 250 #endif
 251 #ifdef PROVIDE_ARRAY
 252         typePrimArray            = linkTycon("PrimArray");
 253         typePrimByteArray        = linkTycon("PrimByteArray");
 254         typeRef                  = linkTycon("Ref");
 255         typePrimMutableArray     = linkTycon("PrimMutableArray");
 256         typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
 257 #endif
 258         typeFloat       = linkTycon("Float");
 259         typeDouble      = linkTycon("Double");
 260 #ifdef PROVIDE_STABLE
 261         typeStable      = linkTycon("StablePtr");
 262 #endif
 263 #ifdef PROVIDE_WEAK
 264         typeWeak        = linkTycon("Weak");
 265 #endif
 266 #ifdef PROVIDE_FOREIGN
 267         typeForeign     = linkTycon("ForeignObj");
 268 #endif
 269 #ifdef PROVIDE_CONCURRENT
 270         typeThreadId    = linkTycon("ThreadId");
 271         typeMVar        = linkTycon("MVar");
 272 #endif
 273
 274         typeBool        = linkTycon("Bool");
 275         typeST          = linkTycon("ST");
 276         typeIO          = linkTycon("IO");
 277         typeException   = linkTycon("Exception");
 278         typeList        = linkTycon("[]");
 279         typeUnit        = linkTycon("()");
 280         typeString      = linkTycon("String");
 281
 282         classEq         = linkClass("Eq");
 283         classOrd        = linkClass("Ord");
 284         classIx         = linkClass("Ix");
 285         classEnum       = linkClass("Enum");
 286         classShow       = linkClass("Show");
 287         classRead       = linkClass("Read");
 288         classBounded    = linkClass("Bounded");
 289 #if EVAL_INSTANCES
 290         classEval       = linkClass("Eval");
 291 #endif
 292         classReal       = linkClass("Real");
 293         classIntegral   = linkClass("Integral");
 294         classRealFrac   = linkClass("RealFrac");
 295         classRealFloat  = linkClass("RealFloat");
 296         classFractional = linkClass("Fractional");
 297         classFloating   = linkClass("Floating");
 298         classNum        = linkClass("Num");
 299         classMonad      = linkClass("Monad");
 300         classMonad0     = linkClass("MonadZero");
 301
 302         stdDefaults     = NIL;
 303         stdDefaults     = cons(typeDouble,stdDefaults);
 304 #if DEFAULT_BIGNUM
 305         stdDefaults     = cons(typeBignum,stdDefaults);
 306 #else
 307         stdDefaults     = cons(typeInt,stdDefaults);
 308 #endif
 309         mkTypes();
 310
 311         nameMkC         = addPrimCfun(findText("C#"),1,0,CHAR_REP);
 312         nameMkI         = addPrimCfun(findText("I#"),1,0,INT_REP);
 313 #ifdef PROVIDE_INT64
 314         nameMkInt64     = addPrimCfun(findText("Int64#"),1,0,INT64_REP);
 315 #endif
 316 #ifdef PROVIDE_WORD
 317         nameMkW         = addPrimCfun(findText("W#"),1,0,WORD_REP);
 318 #endif
 319 #ifdef PROVIDE_ADDR
 320         nameMkA         = addPrimCfun(findText("A#"),1,0,ADDR_REP);
 321 #endif
 322         nameMkF         = addPrimCfun(findText("F#"),1,0,FLOAT_REP);
 323         nameMkD         = addPrimCfun(findText("D#"),1,0,DOUBLE_REP);
 324 #ifdef PROVIDE_STABLE
 325         nameMkStable    = addPrimCfun(findText("Stable#"),1,0,STABLE_REP);
 326 #endif
 327
 328 #ifdef PROVIDE_INTEGER
 329         nameMkInteger   = addPrimCfun(findText("Integer#"),1,0,0);
 330 #endif
 331 #ifdef PROVIDE_FOREIGN
 332         nameMkForeign   = addPrimCfun(findText("Foreign#"),1,0,0);
 333 #endif
 334 #ifdef PROVIDE_WEAK
 335         nameMkWeak      = addPrimCfun(findText("Weak#"),1,0,0);
 336 #endif
 337 #ifdef PROVIDE_ARRAY
 338         nameMkPrimArray            = addPrimCfun(findText("PrimArray#"),1,0,0);
 339         nameMkPrimByteArray        = addPrimCfun(findText("PrimByteArray#"),1,0,0);
 340         nameMkRef                  = addPrimCfun(findText("Ref#"),1,0,0);
 341         nameMkPrimMutableArray     = addPrimCfun(findText("PrimMutableArray#"),1,0,0);
 342         nameMkPrimMutableByteArray = addPrimCfun(findText("PrimMutableByteArray#"),1,0,0);
 343 #endif
 344 #ifdef PROVIDE_CONCURRENT
 345         nameMkThreadId  = addPrimCfun(findText("ThreadId#"),1,0,0);
 346         nameMkMVar      = addPrimCfun(findText("MVar#"),1,0,0);
 347 #endif
 348
 349 #if EVAL_INSTANCES
 350         addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->)     */
 351 #endif
 352
 353         for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
 354 #if EVAL_INSTANCES
 355             addEvalInst(0,mkTuple(i),i,NIL);
 356 #endif
 357 #if DERIVE_EQ
 358             addTupInst(classEq,i);
 359 #endif
 360 #if DERIVE_ORD
 361             addTupInst(classOrd,i);
 362 #endif
 363 #if DERIVE_IX
 364             addTupInst(classIx,i);
 365 #endif
 366 #if DERIVE_SHOW
 367             addTupInst(classShow,i);
 368 #endif
 369 #if DERIVE_READ
 370             addTupInst(classRead,i);
 371 #endif
 372 #if DERIVE_BOUNDED
 373             addTupInst(classBounded,i);
 374 #endif
 375         }
 376     }
 377 }
 378
 379 Void linkPreludeCM() {                  /* 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         setCurrModule(modulePreludeHugs);
 385         /* constructors */
 386         nameFalse       = linkName("False");
 387         nameTrue        = linkName("True");
 388         nameNil         = linkName("[]");
 389         nameCons        = linkName(":");
 390         nameUnit        = linkName("()");
 391         /* members */
 392         nameEq          = linkName("==");
 393         nameFromInt     = linkName("fromInt");
 394         nameFromInteger = linkName("fromInteger");
 395         nameFromDouble  = linkName("fromDouble");
 396 #if EVAL_INSTANCES
 397         nameStrict      = linkName("strict");
 398         nameSeq         = linkName("seq");
 399 #endif
 400         nameReturn      = linkName("return");
 401         nameBind        = linkName(">>=");
 402         nameZero        = linkName("zero");
 403
 404         /* These come before calls to implementPrim */
 405         for(i=0; i<NUM_TUPLES; ++i) {
 406             implementTuple(i);
 407         }
 408     }
 409 }
 410
 411 Void linkPreludeNames() {               /* Hook to names defined in Prelude */
 412     static Bool initialised = FALSE;
 413     if (!initialised) {
 414         Int i;
 415         initialised = TRUE;
 416         setCurrModule(modulePreludeHugs);
 417
 418         /* primops */
 419         nameMkIO          = linkName("primMkIO");
 420         for (i=0; asmPrimOps[i].name; ++i) {
 421             Text t = findText(asmPrimOps[i].name);
 422             Name n = findName(t);
 423             if (isNull(n)) {
 424                 n = newName(t);
 425             }
 426             name(n).line   = 0;
 427             name(n).defn   = NIL;
 428             name(n).type   = primType(asmPrimOps[i].monad,asmPrimOps[i].args,asmPrimOps[i].results);
 429             name(n).arity  = strlen(asmPrimOps[i].args);
 430             name(n).primop = &(asmPrimOps[i]);
 431             implementPrim(n);
 432         }
 433
 434         /* user interface                           */
 435         nameRunIO         = linkName("primRunIO");
 436         namePrint         = linkName("print");
 437         /* typechecker (undefined member functions) */
 438         nameError         = linkName("error");
 439         /* desugar                                  */
 440         nameId            = linkName("id");
 441         nameOtherwise     = linkName("otherwise");
 442         nameUndefined     = linkName("undefined");
 443         /* pmc                                      */
 444 #if NPLUSK
 445         namePmSub         = linkName("primPmSub");
 446 #endif
 447         /* translator                               */
 448         nameUnpackString  = linkName("primUnpackString");
 449         namePMFail        = linkName("primPmFail");
 450         nameEqChar        = linkName("primEqChar");
 451         nameEqInt         = linkName("primEqInt");
 452 #if !OVERLOADED_CONSTANTS
 453         nameEqInteger     = linkName("primEqInteger");
 454 #endif /* !OVERLOADED_CONSTANTS */
 455         nameEqDouble      = linkName("primEqDouble");
 456         namePmInt         = linkName("primPmInt");
 457         namePmInteger     = linkName("primPmInteger");
 458         namePmDouble      = linkName("primPmDouble");
 459         namePmLe          = linkName("primPmLe");
 460         namePmSubtract    = linkName("primPmSubtract");
 461         namePmFromInteger = linkName("primPmFromInteger");
 462     }
 463 }
 464
 465 Void linkControl(what)
 466 Int what; {
 467     Int  i;
 468
 469     switch (what) {
 470         case RESET   :
 471         case MARK    :
 472                        break;
 473
 474         case INSTALL : linkControl(RESET);
 475
 476                        modulePreludeHugs = newModule(findText("PreludeBuiltin"));
 477
 478                        setCurrModule(modulePreludeHugs);
 479
 480                        typeArrow = addPrimTycon(findText("(->)"),
 481                                                 pair(STAR,pair(STAR,STAR)),
 482                                                 2,DATATYPE,NIL);
 483
 484                        /* ToDo: fix pFun (or eliminate its use) */
 485 #define pFun(n,s,t)    n = predefinePrim(s)
 486                        /* newtype and USE_NEWTYPE_FOR_DICTS     */
 487                        pFun(nameId,             "id",       "id");
 488                        /* desugaring                            */
 489                        pFun(nameInd,            "_indirect","error");
 490                        name(nameInd).number = DFUNNAME;
 491                        /* pmc                                   */
 492                        pFun(nameSel,            "_SEL",     "sel");
 493                        /* strict constructors                   */
 494                        pFun(nameForce,          "primForce","id");
 495                        /* implementTagToCon                     */
 496                        pFun(namePMFail,         "primPmFail","primPmFail");
 497                        pFun(nameError,          "error","error");
 498                        pFun(nameUnpackString, "primUnpackString", "primUnpackString");
 499 #undef pFun
 500
 501                        break;
 502     }
 503 }
 504
 505 /*-------------------------------------------------------------------------*/