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/03/23 14:54:21 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
20 #include "Assembler.h" /* for asmPrimOps and AsmReps */
21 #include "Rts.h" /* to make Prelude.h palatable */
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 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 */
299 setCurrModule(modulePrelude);
301 typeChar = linkTycon("Char");
302 typeInt = linkTycon("Int");
303 typeInteger = linkTycon("Integer");
304 typeWord = linkTycon("Word");
305 typeAddr = linkTycon("Addr");
306 typePrimArray = linkTycon("PrimArray");
307 typePrimByteArray = linkTycon("PrimByteArray");
308 typeRef = linkTycon("STRef");
309 typePrimMutableArray = linkTycon("PrimMutableArray");
310 typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
311 typeFloat = linkTycon("Float");
312 typeDouble = linkTycon("Double");
313 typeStable = linkTycon("StablePtr");
315 typeWeak = linkTycon("Weak");
317 # ifdef PROVIDE_FOREIGN
318 typeForeign = linkTycon("ForeignObj");
320 typeThreadId = linkTycon("ThreadId");
321 typeMVar = linkTycon("MVar");
322 typeBool = linkTycon("Bool");
323 typeST = linkTycon("ST");
324 typeIO = linkTycon("IO");
325 typeException = linkTycon("Exception");
326 typeString = linkTycon("String");
327 typeOrdering = linkTycon("Ordering");
329 classEq = linkClass("Eq");
330 classOrd = linkClass("Ord");
331 classIx = linkClass("Ix");
332 classEnum = linkClass("Enum");
333 classShow = linkClass("Show");
334 classRead = linkClass("Read");
335 classBounded = linkClass("Bounded");
336 classReal = linkClass("Real");
337 classIntegral = linkClass("Integral");
338 classRealFrac = linkClass("RealFrac");
339 classRealFloat = linkClass("RealFloat");
340 classFractional = linkClass("Fractional");
341 classFloating = linkClass("Floating");
342 classNum = linkClass("Num");
343 classMonad = linkClass("Monad");
346 stdDefaults = cons(typeDouble,stdDefaults);
347 stdDefaults = cons(typeInteger,stdDefaults);
349 predNum = ap(classNum,aVar);
350 predFractional = ap(classFractional,aVar);
351 predIntegral = ap(classIntegral,aVar);
352 predMonad = ap(classMonad,aVar);
353 typeProgIO = ap(typeIO,aVar);
355 nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
356 nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
357 nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
358 nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
359 nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
360 nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
361 nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
362 nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
364 # ifdef PROVIDE_FOREIGN
365 nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
368 nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
370 nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
371 nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
372 nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0);
373 nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
374 nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
375 nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
376 nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
379 name(namePrimSeq).type = primType(MONAD_Id, "ab", "b");
380 name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
381 name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
383 /* This is a lie. For a more accurate type of primTakeMVar
384 see ghc/interpreter/lib/Prelude.hs.
386 name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
390 for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
391 addTupInst(classEq,i);
392 addTupInst(classOrd,i);
393 addTupInst(classIx,i);
394 addTupInst(classShow,i);
395 addTupInst(classRead,i);
396 addTupInst(classBounded,i);
402 Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
403 static Bool initialised = FALSE; /* prelude when first loaded */
408 setCurrModule(modulePrelude);
411 nameFalse = linkName("False");
412 nameTrue = linkName("True");
415 nameEq = linkName("==");
416 nameFromInt = linkName("fromInt");
417 nameFromInteger = linkName("fromInteger");
418 nameReturn = linkName("return");
419 nameBind = linkName(">>=");
420 nameMFail = linkName("fail");
421 nameLe = linkName("<=");
422 nameGt = linkName(">");
423 nameShowsPrec = linkName("showsPrec");
424 nameReadsPrec = linkName("readsPrec");
425 nameEQ = linkName("EQ");
426 nameCompare = linkName("compare");
427 nameMinBnd = linkName("minBound");
428 nameMaxBnd = linkName("maxBound");
429 nameRange = linkName("range");
430 nameIndex = linkName("index");
431 namePlus = linkName("+");
432 nameMult = linkName("*");
433 nameRangeSize = linkName("rangeSize");
434 nameInRange = linkName("inRange");
435 nameMinus = linkName("-");
436 /* These come before calls to implementPrim */
438 for(i=0; i<NUM_TUPLES; ++i) {
439 if (i != 1) implementTuple(i);
445 Void linkPrimNames ( void ) { /* Hook to names defined in Prelude */
446 static Bool initialised = FALSE;
451 setCurrModule(modulePrelude);
454 nameMkIO = linkName("hugsprimMkIO");
458 for (i=0; asmPrimOps[i].name; ++i) {
459 Text t = findText(asmPrimOps[i].name);
460 Name n = findName(t);
465 name(n).type = primType(asmPrimOps[i].monad,
467 asmPrimOps[i].results);
468 name(n).arity = strlen(asmPrimOps[i].args);
469 name(n).primop = &(asmPrimOps[i]);
472 ERRMSG(0) "Link Error in Prelude, surplus definition of \"%s\"",
475 // Name already defined!
480 /* static(tidyInfix) */
481 nameNegate = linkName("negate");
483 nameRunIO_toplevel = linkName("hugsprimRunIO_toplevel");
484 nameShow = linkName("show");
485 namePutStr = linkName("putStr");
486 namePrint = linkName("print");
488 nameOtherwise = linkName("otherwise");
489 nameUndefined = linkName("undefined");
491 namePmSub = linkName("hugsprimPmSub");
493 nameEqChar = linkName("hugsprimEqChar");
494 nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk");
495 namePmInt = linkName("hugsprimPmInt");
496 namePmInteger = linkName("hugsprimPmInteger");
497 namePmDouble = linkName("hugsprimPmDouble");
499 nameFromDouble = linkName("fromDouble");
500 namePmFromInteger = linkName("hugsprimPmFromInteger");
502 namePmSubtract = linkName("hugsprimPmSubtract");
503 namePmLe = linkName("hugsprimPmLe");
506 implementCfun ( nameCons, NIL );
507 implementCfun ( nameNil, NIL );
508 implementCfun ( nameUnit, NIL );
514 /* --------------------------------------------------------------------------
516 * ------------------------------------------------------------------------*/
518 /* ToDo: fix pFun (or eliminate its use) */
519 #define pFun(n,s) n = predefinePrim(s)
521 Void linkControl(what)
525 //case EXIT : fooble();break;
532 Module modulePrelBase = findModule(findText("PrelBase"));
533 assert(nonNull(modulePrelBase));
534 /* fprintf(stderr, "linkControl(POSTPREL)\n"); */
535 setCurrModule(modulePrelude);
539 fixupRTStoPreludeRefs ( lookupObjName );
541 nameUnpackString = linkName("hugsprimUnpackString");
542 namePMFail = linkName("hugsprimPmFail");
543 assert(nonNull(namePMFail));
544 #define xyzzy(aaa,bbb) aaa = linkName(bbb)
548 pFun(nameSel, "_SEL");
550 /* strict constructors */
551 xyzzy(nameFlip, "flip" );
554 xyzzy(nameFromTo, "enumFromTo");
555 xyzzy(nameFromThenTo, "enumFromThenTo");
556 xyzzy(nameFrom, "enumFrom");
557 xyzzy(nameFromThen, "enumFromThen");
560 xyzzy(nameApp, "++");
561 xyzzy(nameReadField, "hugsprimReadField");
562 xyzzy(nameReadParen, "readParen");
563 xyzzy(nameShowField, "hugsprimShowField");
564 xyzzy(nameShowParen, "showParen");
565 xyzzy(nameLex, "lex");
566 xyzzy(nameComp, ".");
567 xyzzy(nameAnd, "&&");
568 xyzzy(nameCompAux, "hugsprimCompAux");
569 xyzzy(nameMap, "map");
571 /* implementTagToCon */
572 xyzzy(nameError, "hugsprimError");
575 typeStable = linkTycon("Stable");
576 typeRef = linkTycon("IORef");
577 // {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ?
579 ifLinkConstrItbl ( nameFalse );
580 ifLinkConstrItbl ( nameTrue );
581 ifLinkConstrItbl ( nameNil );
582 ifLinkConstrItbl ( nameCons );
584 /* PrelErr.hi doesn't give a type for error, alas.
585 So error never appears in any symbol table.
586 So we fake it by copying the table entry for
587 hugsprimError -- which is just a call to error.
588 Although we put it on the Prelude export list, we
589 have to claim internally that it lives in PrelErr,
590 so that the correct symbol (PrelErr_error_closure)
594 nm = newName ( findText("error"), NIL );
595 name(nm) = name(nameError);
596 name(nm).mod = findModule(findText("PrelErr"));
597 name(nm).text = findText("error");
598 setCurrModule(modulePrelude);
599 module(modulePrelude).exports
600 = cons ( nm, module(modulePrelude).exports );
602 /* The GHC prelude doesn't seem to export Addr. Add it to the
603 export list for the sake of compatibility with standalone mode.
605 module(modulePrelude).exports
606 = cons ( pair(typeAddr,DOTDOT),
607 module(modulePrelude).exports );
610 /* Make nameListMonad be the builder fn for instance Monad [].
611 Standalone hugs does this with a disgusting hack in
612 checkInstDefn() in static.c. We have a slightly different
613 disgusting hack for the combined case.
616 Class cm; /* :: Class */
617 List is; /* :: [Inst] */
618 cm = findClassInAnyModule(findText("Monad"));
620 is = cclass(cm).instances;
622 while (nonNull(is) && snd(inst(hd(is)).head) != typeList)
625 nameListMonad = inst(hd(is)).builder;
626 assert(nonNull(nameListMonad));
634 Module modulePrelBase;
636 modulePrelude = findFakeModule(textPrelude);
638 nameMkC = addWiredInBoxingTycon("PrelBase", "Char", "C#",
640 nameMkI = addWiredInBoxingTycon("PrelBase", "Int", "I#",
642 nameMkW = addWiredInBoxingTycon("PrelAddr", "Word", "W#",
644 nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr", "A#",
646 nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",
648 nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",
651 = addWiredInBoxingTycon("PrelNum","Integer","Integer#",
654 = addWiredInBoxingTycon("PrelGHC","ByteArray",
655 "PrimByteArray#",0 ,STAR );
657 for (i=0; i<NUM_TUPLES; ++i) {
658 if (i != 1) addTupleTycon(i);
660 addWiredInEnumTycon("PrelBase","Bool",
661 doubleton(findText("False"),
665 // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
666 // ,1,0,THREADID_REP);
668 setCurrModule(modulePrelude);
670 typeArrow = addPrimTycon(findText("(->)"),
671 pair(STAR,pair(STAR,STAR)),
675 pFun(nameInd, "_indirect");
676 name(nameInd).number = DFUNNAME;
678 /* newtype and USE_NEWTYPE_FOR_DICTS */
679 /* make a name entry for PrelBase.id _before_ loading Prelude
680 since ifSetClassDefaultsAndDCon() may need to refer to
683 modulePrelBase = findModule(findText("PrelBase"));
684 module(modulePrelBase).objectExtraNames
685 = singleton(findText("libHS_cbits"));
687 setCurrModule(modulePrelBase);
689 setCurrModule(modulePrelude);
692 fixupRTStoPreludeRefs(NULL);
694 modulePrelude = //newModule(textPrelude);
695 findFakeModule(textPrelude);
696 setCurrModule(modulePrelude);
698 for (i=0; i<NUM_TUPLES; ++i) {
699 if (i != 1) addTupleTycon(i);
701 setCurrModule(modulePrelude);
703 typeArrow = addPrimTycon(findText("(->)"),
704 pair(STAR,pair(STAR,STAR)),
707 /* newtype and USE_NEWTYPE_FOR_DICTS */
711 pFun(nameInd, "_indirect");
712 name(nameInd).number = DFUNNAME;
715 pFun(nameSel, "_SEL");
717 /* strict constructors */
718 pFun(nameFlip, "flip" );
721 pFun(nameFromTo, "enumFromTo");
722 pFun(nameFromThenTo, "enumFromThenTo");
723 pFun(nameFrom, "enumFrom");
724 pFun(nameFromThen, "enumFromThen");
728 pFun(nameReadField, "hugsprimReadField");
729 pFun(nameReadParen, "readParen");
730 pFun(nameShowField, "hugsprimShowField");
731 pFun(nameShowParen, "showParen");
732 pFun(nameLex, "lex");
735 pFun(nameCompAux, "hugsprimCompAux");
736 pFun(nameMap, "map");
738 /* implementTagToCon */
739 pFun(namePMFail, "hugsprimPmFail");
740 pFun(nameError, "error");
741 pFun(nameUnpackString, "hugsprimUnpackString");
743 /* assertion and exception issues */
744 pFun(nameAssert, "assert");
745 pFun(nameAssertError, "assertError");
746 pFun(nameTangleMessage, "tangleMessager");
747 pFun(nameIrrefutPatError,
749 pFun(nameNoMethodBindingError,
750 "noMethodBindingError");
751 pFun(nameNonExhaustiveGuardsError,
752 "nonExhaustiveGuardsError");
753 pFun(namePatError, "patError");
754 pFun(nameRecSelError, "recSelError");
755 pFun(nameRecConError, "recConError");
756 pFun(nameRecUpdError, "recUpdError");
758 /* hooks for handwritten bytecode */
759 pFun(namePrimSeq, "primSeq");
760 pFun(namePrimCatch, "primCatch");
761 pFun(namePrimRaise, "primRaise");
762 pFun(namePrimTakeMVar, "primTakeMVar");
764 StgVar vv = mkStgVar(NIL,NIL);
765 Name n = namePrimSeq;
769 vv = mkStgVar(NIL,NIL);
770 stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
772 stgGlobals=cons(pair(n,vv),stgGlobals);
776 StgVar vv = mkStgVar(NIL,NIL);
777 Name n = namePrimCatch;
781 stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
783 stgGlobals=cons(pair(n,vv),stgGlobals);
786 StgVar vv = mkStgVar(NIL,NIL);
787 Name n = namePrimRaise;
791 stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
793 stgGlobals=cons(pair(n,vv),stgGlobals);
796 StgVar vv = mkStgVar(NIL,NIL);
797 Name n = namePrimTakeMVar;
801 stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
803 stgGlobals=cons(pair(n,vv),stgGlobals);
811 //#include "fooble.c"
812 /*-------------------------------------------------------------------------*/