ghc/interpreter/link.c

   1 /* -*- mode: hugs-c; -*- */
   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.2 $
  11  * $Date: 1998/12/02 13:22:18 $
  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
 144 /* constructors used during translation and codegen */
 145 Name nameMkC;                           /* Char#        -> Char           */
 146 Name nameMkI;                           /* Int#         -> Int            */
 147 #ifdef PROVIDE_INT64
 148 Name nameMkInt64;                       /* Int64#       -> Int64          */
 149 #endif
 150 #ifdef PROVIDE_INTEGER
 151 Name nameMkInteger;                     /* Integer#     -> Integer        */
 152 #endif
 153 #ifdef PROVIDE_WORD
 154 Name nameMkW;                           /* Word#        -> Word           */
 155 #endif
 156 #ifdef PROVIDE_ADDR
 157 Name nameMkA;                           /* Addr#        -> Addr            */
 158 #endif
 159 Name nameMkF;                           /* Float#       -> Float           */
 160 Name nameMkD;                           /* Double#      -> Double          */
 161 #ifdef PROVIDE_ARRAY
 162 Name nameMkPrimArray;
 163 Name nameMkPrimByteArray;
 164 Name nameMkRef;
 165 Name nameMkPrimMutableArray;
 166 Name nameMkPrimMutableByteArray;
 167 #endif
 168 #ifdef PROVIDE_STABLE
 169 Name nameMkStable;                      /* StablePtr# a -> StablePtr a     */
 170 #endif
 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  * ------------------------------------------------------------------------*/
 185
 186 static Tycon linkTycon( String s );
 187 static Tycon linkClass( String s );
 188 static Name  linkName ( String s );
 189
 190 static Tycon linkTycon( String s )
 191 {
 192     Tycon tc = findTycon(findText(s));
 193     if (nonNull(tc)) {
 194         return tc;
 195     }
 196     ERRMSG(0) "Prelude does not define standard type \"%s\"", s
 197     EEND;
 198 }
 199
 200 static Class linkClass( String s )
 201 {
 202     Class cc = findClass(findText(s));
 203     if (nonNull(cc)) {
 204         return cc;
 205     }
 206     ERRMSG(0) "Prelude does not define standard class \"%s\"", s
 207     EEND;
 208 }
 209
 210 static Name linkName( String s )
 211 {
 212     Name n = findName(findText(s));
 213     if (nonNull(n)) {
 214         return n;
 215     }
 216     ERRMSG(0) "Prelude does not define standard name \"%s\"", s
 217     EEND;
 218 }
 219
 220 /* ToDo: kill this! */
 221 static Name  predefinePrim ( String s );
 222 static Name  predefinePrim ( String s )
 223 {
 224     Name nm = newName(findText(s));
 225     name(nm).defn=PREDEFINED;
 226     return nm;
 227 }
 228
 229 Void linkPreludeTC() {                  /* Hook to tycons and classes in   */
 230     static Bool initialised = FALSE;    /* prelude when first loaded       */
 231     if (!initialised) {
 232         Int i;
 233         initialised = TRUE;
 234         setCurrModule(modulePreludeHugs);
 235
 236         typeChar        = linkTycon("Char");
 237         typeInt         = linkTycon("Int");
 238 #ifdef PROVIDE_INT64
 239         typeInt64       = linkTycon("Int64");
 240 #endif
 241 #ifdef PROVIDE_INTEGER
 242         typeInteger     = linkTycon("Integer");
 243 #endif
 244 #ifdef PROVIDE_WORD
 245         typeWord        = linkTycon("Word");
 246 #endif
 247 #ifdef PROVIDE_ADDR
 248         typeAddr        = linkTycon("Addr");
 249 #endif
 250 #ifdef PROVIDE_ARRAY
 251         typePrimArray            = linkTycon("PrimArray");
 252         typePrimByteArray        = linkTycon("PrimByteArray");
 253         typeRef                  = linkTycon("Ref");
 254         typePrimMutableArray     = linkTycon("PrimMutableArray");
 255         typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
 256 #endif
 257         typeFloat       = linkTycon("Float");
 258         typeDouble      = linkTycon("Double");
 259 #ifdef PROVIDE_STABLE
 260         typeStable      = linkTycon("StablePtr");
 261 #endif
 262 #ifdef PROVIDE_WEAK
 263         typeWeak        = linkTycon("Weak");
 264 #endif
 265 #ifdef PROVIDE_FOREIGN
 266         typeForeign     = linkTycon("ForeignObj");
 267 #endif
 268 #ifdef PROVIDE_CONCURRENT
 269         typeThreadId    = linkTycon("ThreadId");
 270         typeMVar        = linkTycon("MVar");
 271 #endif
 272
 273         typeBool        = linkTycon("Bool");
 274         typeST          = linkTycon("ST");
 275         typeIO          = linkTycon("IO");
 276         typeException   = linkTycon("Exception");
 277         typeList        = linkTycon("[]");
 278         typeUnit        = linkTycon("()");
 279         typeString      = linkTycon("String");
 280
 281         classEq         = linkClass("Eq");
 282         classOrd        = linkClass("Ord");
 283         classIx         = linkClass("Ix");
 284         classEnum       = linkClass("Enum");
 285         classShow       = linkClass("Show");
 286         classRead       = linkClass("Read");
 287         classBounded    = linkClass("Bounded");
 288 #if EVAL_INSTANCES
 289         classEval       = linkClass("Eval");
 290 #endif
 291         classReal       = linkClass("Real");
 292         classIntegral   = linkClass("Integral");
 293         classRealFrac   = linkClass("RealFrac");
 294         classRealFloat  = linkClass("RealFloat");
 295         classFractional = linkClass("Fractional");
 296         classFloating   = linkClass("Floating");
 297         classNum        = linkClass("Num");
 298         classMonad      = linkClass("Monad");
 299         classMonad0     = linkClass("MonadZero");
 300
 301         stdDefaults     = NIL;
 302         stdDefaults     = cons(typeDouble,stdDefaults);
 303 #if DEFAULT_BIGNUM
 304         stdDefaults     = cons(typeBignum,stdDefaults);
 305 #else
 306         stdDefaults     = cons(typeInt,stdDefaults);
 307 #endif
 308         mkTypes();
 309
 310         nameMkC         = addPrimCfun(findText("C#"),1,0,CHAR_REP);
 311         nameMkI         = addPrimCfun(findText("I#"),1,0,INT_REP);
 312 #ifdef PROVIDE_INT64
 313         nameMkInt64     = addPrimCfun(findText("Int64#"),1,0,INT64_REP);
 314 #endif
 315 #ifdef PROVIDE_WORD
 316         nameMkW         = addPrimCfun(findText("W#"),1,0,WORD_REP);
 317 #endif
 318 #ifdef PROVIDE_ADDR
 319         nameMkA         = addPrimCfun(findText("A#"),1,0,ADDR_REP);
 320 #endif
 321         nameMkF         = addPrimCfun(findText("F#"),1,0,FLOAT_REP);
 322         nameMkD         = addPrimCfun(findText("D#"),1,0,DOUBLE_REP);
 323 #ifdef PROVIDE_STABLE
 324         nameMkStable    = addPrimCfun(findText("Stable#"),1,0,STABLE_REP);
 325 #endif
 326
 327 #ifdef PROVIDE_INTEGER
 328         nameMkInteger   = addPrimCfun(findText("Integer#"),1,0,0);
 329 #endif
 330 #ifdef PROVIDE_FOREIGN
 331         nameMkForeign   = addPrimCfun(findText("Foreign#"),1,0,0);
 332 #endif
 333 #ifdef PROVIDE_WEAK
 334         nameMkWeak      = addPrimCfun(findText("Weak#"),1,0,0);
 335 #endif
 336 #ifdef PROVIDE_ARRAY
 337         nameMkPrimArray            = addPrimCfun(findText("PrimArray#"),1,0,0);
 338         nameMkPrimByteArray        = addPrimCfun(findText("PrimByteArray#"),1,0,0);
 339         nameMkRef                  = addPrimCfun(findText("Ref#"),1,0,0);
 340         nameMkPrimMutableArray     = addPrimCfun(findText("PrimMutableArray#"),1,0,0);
 341         nameMkPrimMutableByteArray = addPrimCfun(findText("PrimMutableByteArray#"),1,0,0);
 342 #endif
 343 #ifdef PROVIDE_CONCURRENT
 344         nameMkThreadId  = addPrimCfun(findText("ThreadId#"),1,0,0);
 345         nameMkMVar      = addPrimCfun(findText("MVar#"),1,0,0);
 346 #endif
 347
 348 #if EVAL_INSTANCES
 349         addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->)     */
 350 #endif
 351
 352         for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
 353 #if EVAL_INSTANCES
 354             addEvalInst(0,mkTuple(i),i,NIL);
 355 #endif
 356 #if DERIVE_EQ
 357             addTupInst(classEq,i);
 358 #endif
 359 #if DERIVE_ORD
 360             addTupInst(classOrd,i);
 361 #endif
 362 #if DERIVE_IX
 363             addTupInst(classIx,i);
 364 #endif
 365 #if DERIVE_SHOW
 366             addTupInst(classShow,i);
 367 #endif
 368 #if DERIVE_READ
 369             addTupInst(classRead,i);
 370 #endif
 371 #if DERIVE_BOUNDED
 372             addTupInst(classBounded,i);
 373 #endif
 374         }
 375     }
 376 }
 377
 378 Void linkPreludeCM() {                  /* Hook to cfuns and mfuns in      */
 379     static Bool initialised = FALSE;    /* prelude when first loaded       */
 380     if (!initialised) {
 381         Int i;
 382         initialised = TRUE;
 383         setCurrModule(modulePreludeHugs);
 384         /* constructors */
 385         nameFalse       = linkName("False");
 386         nameTrue        = linkName("True");
 387         nameNil         = linkName("[]");
 388         nameCons        = linkName(":");
 389         nameUnit        = linkName("()");
 390         /* members */
 391         nameEq          = linkName("==");
 392         nameFromInt     = linkName("fromInt");
 393         nameFromInteger = linkName("fromInteger");
 394         nameFromDouble  = linkName("fromDouble");
 395 #if EVAL_INSTANCES
 396         nameStrict      = linkName("strict");
 397         nameSeq         = linkName("seq");
 398 #endif
 399         nameReturn      = linkName("return");
 400         nameBind        = linkName(">>=");
 401         nameZero        = linkName("zero");
 402
 403         /* These come before calls to implementPrim */
 404         for(i=0; i<NUM_TUPLES; ++i) {
 405             implementTuple(i);
 406         }
 407     }
 408 }
 409
 410 Void linkPreludeNames() {               /* Hook to names defined in Prelude */
 411     static Bool initialised = FALSE;
 412     if (!initialised) {
 413         Int i;
 414         initialised = TRUE;
 415         setCurrModule(modulePreludeHugs);
 416
 417         /* primops */
 418         nameMkIO          = linkName("primMkIO");
 419         for (i=0; asmPrimOps[i].name; ++i) {
 420             Text t = findText(asmPrimOps[i].name);
 421             Name n = findName(t);
 422             if (isNull(n)) {
 423                 n = newName(t);
 424             }
 425             name(n).line   = 0;
 426             name(n).defn   = NIL;
 427             name(n).type   = primType(asmPrimOps[i].monad,asmPrimOps[i].args,asmPrimOps[i].results);
 428             name(n).arity  = strlen(asmPrimOps[i].args);
 429             name(n).primop = &(asmPrimOps[i]);
 430             implementPrim(n);
 431         }
 432
 433         /* user interface                           */
 434         nameRunIO         = linkName("primRunIO");
 435         namePrint         = linkName("print");
 436         /* typechecker (undefined member functions) */
 437         nameError         = linkName("error");
 438         /* desugar                                  */
 439         nameId            = linkName("id");
 440         nameOtherwise     = linkName("otherwise");
 441         nameUndefined     = linkName("undefined");
 442         /* pmc                                      */
 443 #if NPLUSK
 444         namePmSub         = linkName("primPmSub");
 445 #endif
 446         /* translator                               */
 447         nameUnpackString  = linkName("primUnpackString");
 448         namePMFail        = linkName("primPmFail");
 449         nameEqChar        = linkName("primEqChar");
 450         nameEqInt         = linkName("primEqInt");
 451 #if !OVERLOADED_CONSTANTS
 452         nameEqInteger     = linkName("primEqInteger");
 453 #endif /* !OVERLOADED_CONSTANTS */
 454         nameEqDouble      = linkName("primEqDouble");
 455         namePmInt         = linkName("primPmInt");
 456         namePmInteger     = linkName("primPmInteger");
 457         namePmDouble      = linkName("primPmDouble");
 458         namePmLe          = linkName("primPmLe");
 459         namePmSubtract    = linkName("primPmSubtract");
 460         namePmFromInteger = linkName("primPmFromInteger");
 461     }
 462 }
 463
 464 Void linkControl(what)
 465 Int what; {
 466     Int  i;
 467
 468     switch (what) {
 469         case RESET   :
 470         case MARK    :
 471                        break;
 472
 473         case INSTALL : linkControl(RESET);
 474
 475                        modulePreludeHugs = newModule(findText("PreludeBuiltin"));
 476
 477                        setCurrModule(modulePreludeHugs);
 478
 479                        typeArrow = addPrimTycon(findText("(->)"),
 480                                                 pair(STAR,pair(STAR,STAR)),
 481                                                 2,DATATYPE,NIL);
 482
 483                        /* ToDo: fix pFun (or eliminate its use) */
 484 #define pFun(n,s,t)    n = predefinePrim(s)
 485                        /* newtype and USE_NEWTYPE_FOR_DICTS     */
 486                        pFun(nameId,             "id",       "id");
 487                        /* desugaring                            */
 488                        pFun(nameInd,            "_indirect","error");
 489                        name(nameInd).number = DFUNNAME;
 490                        /* pmc                                   */
 491                        pFun(nameSel,            "_SEL",     "sel");
 492                        /* strict constructors                   */
 493                        pFun(nameForce,          "primForce","id");
 494                        /* implementTagToCon                     */
 495                        pFun(namePMFail,         "primPmFail","primPmFail");
 496 #undef pFun
 497
 498                        break;
 499     }
 500 }
 501
 502 /*-------------------------------------------------------------------------*/