2 /* --------------------------------------------------------------------------
3 * Load symbols required from the Prelude
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.
11 * $RCSfile: link.c,v $
13 * $Date: 2000/04/27 16:35:29 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
20 #include "Rts.h" /* to make Prelude.h palatable */
21 #include "Assembler.h" /* for asmPrimOps and AsmReps */
22 #include "Prelude.h" /* for fixupRTStoPreludeRefs */
25 Type typeArrow; /* Function spaces */
33 Type typePrimByteArray;
35 Type typePrimMutableArray;
36 Type typePrimMutableByteArray;
45 #ifdef PROVIDE_FOREIGN
57 Class classEq; /* `standard' classes */
65 Class classReal; /* `numeric' classes */
69 Class classFractional;
72 Class classMonad; /* Monads and monads with a zero */
74 List stdDefaults; /* standard default values */
77 Name nameFalse; /* primitive boolean constructors */
79 Name nameCons; /* primitive list constructors */
80 Name nameUnit; /* primitive Unit type constructor */
84 Name nameFromDouble; /* coercion of numerics */
87 Name nameBind; /* for translating monad comps */
88 Name nameZero; /* for monads with a zero */
93 Name nameRunIO_toplevel;
97 Name nameUndefined; /* generic undefined value */
106 Name namePmFromInteger;
108 Name nameUnpackString;
111 Name nameCreateAdjThunk;
128 Name namePrimTakeMVar;
137 Name nameAssertError;
138 Name nameTangleMessage;
139 Name nameIrrefutPatError;
140 Name nameNoMethodBindingError;
141 Name nameNonExhaustiveGuardsError;
143 Name nameRecSelError;
144 Name nameRecConError;
145 Name nameRecUpdError;
147 /* these names are required before we've had a chance to do the right thing */
149 Name nameUnsafeUnpackCString;
151 /* constructors used during translation and codegen */
152 Name nameMkC; /* Char# -> Char */
153 Name nameMkI; /* Int# -> Int */
154 Name nameMkInteger; /* Integer# -> Integer */
155 Name nameMkW; /* Word# -> Word */
156 Name nameMkA; /* Addr# -> Addr */
157 Name nameMkF; /* Float# -> Float */
158 Name nameMkD; /* Double# -> Double */
159 Name nameMkPrimArray;
160 Name nameMkPrimByteArray;
162 Name nameMkPrimMutableArray;
163 Name nameMkPrimMutableByteArray;
164 Name nameMkStable; /* StablePtr# a -> StablePtr a */
165 Name nameMkThreadId; /* ThreadId# -> ThreadId */
166 Name nameMkPrimMVar; /* MVar# a -> MVar a */
168 Name nameMkWeak; /* Weak# a -> Weak a */
170 #ifdef PROVIDE_FOREIGN
171 Name nameMkForeign; /* ForeignObj# -> ForeignObj */
191 Module modulePrelPrim;
192 Module modulePrelude;
196 /* --------------------------------------------------------------------------
197 * Frequently used type skeletons:
198 * ------------------------------------------------------------------------*/
200 Type arrow; /* mkOffset(0) -> mkOffset(1) */
201 Type boundPair; /* (mkOffset(0),mkOffset(0)) */
202 Type listof; /* [ mkOffset(0) ] */
203 Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
205 Cell predNum; /* Num (mkOffset(0)) */
206 Cell predFractional; /* Fractional (mkOffset(0)) */
207 Cell predIntegral; /* Integral (mkOffset(0)) */
208 Kind starToStar; /* Type -> Type */
209 Cell predMonad; /* Monad (mkOffset(0)) */
210 Type typeProgIO; /* IO a */
213 /* --------------------------------------------------------------------------
215 * ------------------------------------------------------------------------*/
217 static Tycon linkTycon ( String s );
218 static Tycon linkClass ( String s );
219 static Name linkName ( String s );
220 static Name predefinePrim ( String s );
223 static Tycon linkTycon( String s )
225 Tycon tc = findTycon(findText(s));
226 if (nonNull(tc)) return tc;
228 tc = findTyconInAnyModule(findText(s));
229 if (nonNull(tc)) return tc;
231 FPrintf(stderr, "frambozenvla! unknown tycon %s\n", s );
233 ERRMSG(0) "Prelude does not define standard type \"%s\"", s
237 static Class linkClass( String s )
239 Class cc = findClass(findText(s));
240 if (nonNull(cc)) return cc;
242 cc = findClassInAnyModule(findText(s));
243 if (nonNull(cc)) return cc;
245 FPrintf(stderr, "frambozenvla! unknown class %s\n", s );
247 ERRMSG(0) "Prelude does not define standard class \"%s\"", s
251 static Name linkName( String s )
253 Name n = findName(findText(s));
254 if (nonNull(n)) return n;
256 n = findNameInAnyModule(findText(s));
257 if (nonNull(n)) return n;
259 FPrintf(stderr, "frambozenvla! unknown name %s\n", s );
261 ERRMSG(0) "Prelude does not define standard name \"%s\"", s
265 static Name predefinePrim ( String s )
268 Text t = findText(s);
271 //fprintf(stderr, "predefinePrim: %s already exists\n", s );
274 name(nm).defn=PREDEFINED;
280 /* --------------------------------------------------------------------------
282 * ------------------------------------------------------------------------*/
284 /* In standalone mode, linkPreludeTC, linkPreludeCM and linkPrimNames
285 are called, in that order, during static analysis of Prelude.hs.
286 In combined mode such an analysis does not happen. Instead these
287 calls will be made as a result of a call link(POSTPREL).
289 linkPreludeTC, linkPreludeCM and linkPreludeNames are needed in both
290 standalone and combined modes.
294 Void linkPreludeTC(void) { /* Hook to tycons and classes in */
295 static Bool initialised = FALSE; /* prelude when first loaded */
300 setCurrModule(modulePrelude);
302 setCurrModule(modulePrelPrim);
305 typeChar = linkTycon("Char");
306 typeInt = linkTycon("Int");
307 typeInteger = linkTycon("Integer");
308 typeWord = linkTycon("Word");
309 typeAddr = linkTycon("Addr");
310 typePrimArray = linkTycon("PrimArray");
311 typePrimByteArray = linkTycon("PrimByteArray");
312 typeRef = linkTycon("STRef");
313 typePrimMutableArray = linkTycon("PrimMutableArray");
314 typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
315 typeFloat = linkTycon("Float");
316 typeDouble = linkTycon("Double");
317 typeStable = linkTycon("StablePtr");
319 typeWeak = linkTycon("Weak");
321 # ifdef PROVIDE_FOREIGN
322 typeForeign = linkTycon("ForeignObj");
324 typeThreadId = linkTycon("ThreadId");
325 typeMVar = linkTycon("MVar");
326 typeBool = linkTycon("Bool");
327 typeST = linkTycon("ST");
328 typeIO = linkTycon("IO");
329 typeException = linkTycon("Exception");
330 typeString = linkTycon("String");
331 typeOrdering = linkTycon("Ordering");
333 classEq = linkClass("Eq");
334 classOrd = linkClass("Ord");
335 classIx = linkClass("Ix");
336 classEnum = linkClass("Enum");
337 classShow = linkClass("Show");
338 classRead = linkClass("Read");
339 classBounded = linkClass("Bounded");
340 classReal = linkClass("Real");
341 classIntegral = linkClass("Integral");
342 classRealFrac = linkClass("RealFrac");
343 classRealFloat = linkClass("RealFloat");
344 classFractional = linkClass("Fractional");
345 classFloating = linkClass("Floating");
346 classNum = linkClass("Num");
347 classMonad = linkClass("Monad");
350 stdDefaults = cons(typeDouble,stdDefaults);
351 stdDefaults = cons(typeInteger,stdDefaults);
353 predNum = ap(classNum,aVar);
354 predFractional = ap(classFractional,aVar);
355 predIntegral = ap(classIntegral,aVar);
356 predMonad = ap(classMonad,aVar);
357 typeProgIO = ap(typeIO,aVar);
359 nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
360 nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
361 nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
362 nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
363 nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
364 nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
365 nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
366 nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
368 # ifdef PROVIDE_FOREIGN
369 nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
372 nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
374 nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
375 nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
376 nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0);
377 nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
378 nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
379 nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
380 nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
383 name(namePrimSeq).type = primType(MONAD_Id, "ab", "b");
384 name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
385 name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
387 /* This is a lie. For a more accurate type of primTakeMVar
388 see ghc/interpreter/lib/Prelude.hs.
390 name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
394 for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
395 addTupInst(classEq,i);
396 addTupInst(classOrd,i);
397 addTupInst(classIx,i);
398 addTupInst(classShow,i);
399 addTupInst(classRead,i);
400 addTupInst(classBounded,i);
406 Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
407 static Bool initialised = FALSE; /* prelude when first loaded */
413 setCurrModule(modulePrelude);
415 setCurrModule(modulePrelPrim);
419 nameFalse = linkName("False");
420 nameTrue = linkName("True");
423 nameEq = linkName("==");
424 nameFromInt = linkName("fromInt");
425 nameFromInteger = linkName("fromInteger");
426 nameReturn = linkName("return");
427 nameBind = linkName(">>=");
428 nameMFail = linkName("fail");
429 nameLe = linkName("<=");
430 nameGt = linkName(">");
431 nameShowsPrec = linkName("showsPrec");
432 nameReadsPrec = linkName("readsPrec");
433 nameEQ = linkName("EQ");
434 nameCompare = linkName("compare");
435 nameMinBnd = linkName("minBound");
436 nameMaxBnd = linkName("maxBound");
437 nameRange = linkName("range");
438 nameIndex = linkName("index");
439 namePlus = linkName("+");
440 nameMult = linkName("*");
441 nameRangeSize = linkName("rangeSize");
442 nameInRange = linkName("inRange");
443 nameMinus = linkName("-");
444 /* These come before calls to implementPrim */
446 for(i=0; i<NUM_TUPLES; ++i) {
447 if (i != 1) implementTuple(i);
453 Void linkPrimNames ( void ) { /* Hook to names defined in Prelude */
454 static Bool initialised = FALSE;
460 setCurrModule(modulePrelude);
462 setCurrModule(modulePrelPrim);
466 nameMkIO = linkName("hugsprimMkIO");
470 for (i=0; asmPrimOps[i].name; ++i) {
471 Text t = findText(asmPrimOps[i].name);
472 Name n = findName(t);
477 name(n).type = primType(asmPrimOps[i].monad,
479 asmPrimOps[i].results);
480 name(n).arity = strlen(asmPrimOps[i].args);
481 name(n).primop = &(asmPrimOps[i]);
484 ERRMSG(0) "Link Error in Prelude, surplus definition of \"%s\"",
487 // Name already defined!
492 /* static(tidyInfix) */
493 nameNegate = linkName("negate");
495 nameRunIO_toplevel = linkName("hugsprimRunIO_toplevel");
496 nameShow = linkName("show");
497 namePutStr = linkName("putStr");
498 namePrint = linkName("print");
500 nameOtherwise = linkName("otherwise");
501 nameUndefined = linkName("undefined");
503 namePmSub = linkName("hugsprimPmSub");
505 nameEqChar = linkName("hugsprimEqChar");
506 nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk");
507 namePmInt = linkName("hugsprimPmInt");
508 namePmInteger = linkName("hugsprimPmInteger");
509 namePmDouble = linkName("hugsprimPmDouble");
511 nameFromDouble = linkName("fromDouble");
512 namePmFromInteger = linkName("hugsprimPmFromInteger");
514 namePmSubtract = linkName("hugsprimPmSubtract");
515 namePmLe = linkName("hugsprimPmLe");
518 implementCfun ( nameCons, NIL );
519 implementCfun ( nameNil, NIL );
520 implementCfun ( nameUnit, NIL );
526 /* --------------------------------------------------------------------------
528 * ------------------------------------------------------------------------*/
530 /* ToDo: fix pFun (or eliminate its use) */
531 #define pFun(n,s) n = predefinePrim(s)
533 Void linkControl(what)
537 //case EXIT : fooble();break;
544 Module modulePrelBase = findModule(findText("PrelBase"));
545 assert(nonNull(modulePrelBase));
546 /* fprintf(stderr, "linkControl(POSTPREL)\n"); */
547 setCurrModule(modulePrelude);
551 fixupRTStoPreludeRefs ( lookupObjName );
553 nameUnpackString = linkName("hugsprimUnpackString");
554 namePMFail = linkName("hugsprimPmFail");
555 assert(nonNull(namePMFail));
556 #define xyzzy(aaa,bbb) aaa = linkName(bbb)
560 pFun(nameSel, "_SEL");
562 /* strict constructors */
563 xyzzy(nameFlip, "flip" );
566 xyzzy(nameFromTo, "enumFromTo");
567 xyzzy(nameFromThenTo, "enumFromThenTo");
568 xyzzy(nameFrom, "enumFrom");
569 xyzzy(nameFromThen, "enumFromThen");
572 xyzzy(nameApp, "++");
573 xyzzy(nameReadField, "hugsprimReadField");
574 xyzzy(nameReadParen, "readParen");
575 xyzzy(nameShowField, "hugsprimShowField");
576 xyzzy(nameShowParen, "showParen");
577 xyzzy(nameLex, "lex");
578 xyzzy(nameComp, ".");
579 xyzzy(nameAnd, "&&");
580 xyzzy(nameCompAux, "hugsprimCompAux");
581 xyzzy(nameMap, "map");
583 /* implementTagToCon */
584 xyzzy(nameError, "hugsprimError");
587 typeStable = linkTycon("Stable");
588 typeRef = linkTycon("IORef");
589 // {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ?
591 ifLinkConstrItbl ( nameFalse );
592 ifLinkConstrItbl ( nameTrue );
593 ifLinkConstrItbl ( nameNil );
594 ifLinkConstrItbl ( nameCons );
596 /* PrelErr.hi doesn't give a type for error, alas.
597 So error never appears in any symbol table.
598 So we fake it by copying the table entry for
599 hugsprimError -- which is just a call to error.
600 Although we put it on the Prelude export list, we
601 have to claim internally that it lives in PrelErr,
602 so that the correct symbol (PrelErr_error_closure)
606 nm = newName ( findText("error"), NIL );
607 name(nm) = name(nameError);
608 name(nm).mod = findModule(findText("PrelErr"));
609 name(nm).text = findText("error");
610 setCurrModule(modulePrelude);
611 module(modulePrelude).exports
612 = cons ( nm, module(modulePrelude).exports );
614 /* The GHC prelude doesn't seem to export Addr. Add it to the
615 export list for the sake of compatibility with standalone mode.
617 module(modulePrelude).exports
618 = cons ( pair(typeAddr,DOTDOT),
619 module(modulePrelude).exports );
622 /* Make nameListMonad be the builder fn for instance Monad [].
623 Standalone hugs does this with a disgusting hack in
624 checkInstDefn() in static.c. We have a slightly different
625 disgusting hack for the combined case.
628 Class cm; /* :: Class */
629 List is; /* :: [Inst] */
630 cm = findClassInAnyModule(findText("Monad"));
632 is = cclass(cm).instances;
634 while (nonNull(is) && snd(inst(hd(is)).head) != typeList)
637 nameListMonad = inst(hd(is)).builder;
638 assert(nonNull(nameListMonad));
646 Module modulePrelBase;
648 modulePrelude = findFakeModule(textPrelude);
650 nameMkC = addWiredInBoxingTycon("PrelBase", "Char", "C#",
652 nameMkI = addWiredInBoxingTycon("PrelBase", "Int", "I#",
654 nameMkW = addWiredInBoxingTycon("PrelAddr", "Word", "W#",
656 nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr", "A#",
658 nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",
660 nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",
663 = addWiredInBoxingTycon("PrelNum","Integer","Integer#",
666 = addWiredInBoxingTycon("PrelGHC","ByteArray",
667 "PrimByteArray#",0 ,STAR );
669 for (i=0; i<NUM_TUPLES; ++i) {
670 if (i != 1) addTupleTycon(i);
672 addWiredInEnumTycon("PrelBase","Bool",
673 doubleton(findText("False"),
677 // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
678 // ,1,0,THREADID_REP);
680 setCurrModule(modulePrelude);
682 typeArrow = addPrimTycon(findText("(->)"),
683 pair(STAR,pair(STAR,STAR)),
687 pFun(nameInd, "_indirect");
688 name(nameInd).number = DFUNNAME;
690 /* newtype and USE_NEWTYPE_FOR_DICTS */
691 /* make a name entry for PrelBase.id _before_ loading Prelude
692 since ifSetClassDefaultsAndDCon() may need to refer to
695 modulePrelBase = findModule(findText("PrelBase"));
696 module(modulePrelBase).objectExtraNames
697 = singleton(findText("libHSstd_cbits"));
699 setCurrModule(modulePrelBase);
701 setCurrModule(modulePrelude);
704 fixupRTStoPreludeRefs(NULL);
706 modulePrelPrim = findFakeModule(textPrelPrim);
707 modulePrelude = findFakeModule(textPrelude);
708 setCurrModule(modulePrelPrim);
710 for (i=0; i<NUM_TUPLES; ++i) {
711 if (i != 1) addTupleTycon(i);
713 setCurrModule(modulePrelPrim);
715 typeArrow = addPrimTycon(findText("(->)"),
716 pair(STAR,pair(STAR,STAR)),
719 /* newtype and USE_NEWTYPE_FOR_DICTS */
723 pFun(nameInd, "_indirect");
724 name(nameInd).number = DFUNNAME;
727 pFun(nameSel, "_SEL");
729 /* strict constructors */
730 pFun(nameFlip, "flip" );
733 pFun(nameFromTo, "enumFromTo");
734 pFun(nameFromThenTo, "enumFromThenTo");
735 pFun(nameFrom, "enumFrom");
736 pFun(nameFromThen, "enumFromThen");
740 pFun(nameReadField, "hugsprimReadField");
741 pFun(nameReadParen, "readParen");
742 pFun(nameShowField, "hugsprimShowField");
743 pFun(nameShowParen, "showParen");
744 pFun(nameLex, "lex");
747 pFun(nameCompAux, "hugsprimCompAux");
748 pFun(nameMap, "map");
750 /* implementTagToCon */
751 pFun(namePMFail, "hugsprimPmFail");
752 pFun(nameError, "error");
753 pFun(nameUnpackString, "hugsprimUnpackString");
755 /* assertion and exception issues */
756 pFun(nameAssert, "assert");
757 pFun(nameAssertError, "assertError");
758 pFun(nameTangleMessage, "tangleMessager");
759 pFun(nameIrrefutPatError,
761 pFun(nameNoMethodBindingError,
762 "noMethodBindingError");
763 pFun(nameNonExhaustiveGuardsError,
764 "nonExhaustiveGuardsError");
765 pFun(namePatError, "patError");
766 pFun(nameRecSelError, "recSelError");
767 pFun(nameRecConError, "recConError");
768 pFun(nameRecUpdError, "recUpdError");
770 /* hooks for handwritten bytecode */
771 pFun(namePrimSeq, "primSeq");
772 pFun(namePrimCatch, "primCatch");
773 pFun(namePrimRaise, "primRaise");
774 pFun(namePrimTakeMVar, "primTakeMVar");
776 Name n = namePrimSeq;
780 name(n).closure = mkCPtr ( asm_BCO_seq() );
781 addToCodeList ( modulePrelPrim, n );
784 Name n = namePrimCatch;
788 name(n).closure = mkCPtr ( asm_BCO_catch() );
789 addToCodeList ( modulePrelPrim, n );
792 Name n = namePrimRaise;
796 name(n).closure = mkCPtr ( asm_BCO_raise() );
797 addToCodeList ( modulePrelPrim, n );
800 Name n = namePrimTakeMVar;
804 name(n).closure = mkCPtr ( asm_BCO_takeMVar() );
805 addToCodeList ( modulePrelPrim, n );
813 /*-------------------------------------------------------------------------*/