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/15 23:27:16 $
14 * ------------------------------------------------------------------------*/
20 #include "Assembler.h" /* for asmPrimOps and AsmReps */
24 Type typeArrow; /* Function spaces */
32 Type typePrimByteArray;
34 Type typePrimMutableArray;
35 Type typePrimMutableByteArray;
44 #ifdef PROVIDE_FOREIGN
56 Class classEq; /* `standard' classes */
64 Class classReal; /* `numeric' classes */
68 Class classFractional;
71 Class classMonad; /* Monads and monads with a zero */
73 List stdDefaults; /* standard default values */
76 Name nameFalse; /* primitive boolean constructors */
78 Name nameCons; /* primitive list constructors */
79 Name nameUnit; /* primitive Unit type constructor */
83 Name nameFromDouble; /* coercion of numerics */
86 Name nameBind; /* for translating monad comps */
87 Name nameZero; /* for monads with a zero */
92 Name nameRunIO_toplevel;
96 Name nameUndefined; /* generic undefined value */
105 Name namePmFromInteger;
107 Name nameUnpackString;
110 Name nameCreateAdjThunk;
127 Name namePrimTakeMVar;
136 Name nameAssertError;
137 Name nameTangleMessage;
138 Name nameIrrefutPatError;
139 Name nameNoMethodBindingError;
140 Name nameNonExhaustiveGuardsError;
142 Name nameRecSelError;
143 Name nameRecConError;
144 Name nameRecUpdError;
146 /* these names are required before we've had a chance to do the right thing */
148 Name nameUnsafeUnpackCString;
150 /* constructors used during translation and codegen */
151 Name nameMkC; /* Char# -> Char */
152 Name nameMkI; /* Int# -> Int */
153 Name nameMkInteger; /* Integer# -> Integer */
154 Name nameMkW; /* Word# -> Word */
155 Name nameMkA; /* Addr# -> Addr */
156 Name nameMkF; /* Float# -> Float */
157 Name nameMkD; /* Double# -> Double */
158 Name nameMkPrimArray;
159 Name nameMkPrimByteArray;
161 Name nameMkPrimMutableArray;
162 Name nameMkPrimMutableByteArray;
163 Name nameMkStable; /* StablePtr# a -> StablePtr a */
164 Name nameMkThreadId; /* ThreadId# -> ThreadId */
165 Name nameMkPrimMVar; /* MVar# a -> MVar a */
167 Name nameMkWeak; /* Weak# a -> Weak a */
169 #ifdef PROVIDE_FOREIGN
170 Name nameMkForeign; /* ForeignObj# -> ForeignObj */
190 Module modulePrelude;
195 /* --------------------------------------------------------------------------
196 * Frequently used type skeletons:
197 * ------------------------------------------------------------------------*/
199 Type arrow; /* mkOffset(0) -> mkOffset(1) */
200 Type boundPair; /* (mkOffset(0),mkOffset(0)) */
201 Type listof; /* [ mkOffset(0) ] */
202 Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
204 Cell predNum; /* Num (mkOffset(0)) */
205 Cell predFractional; /* Fractional (mkOffset(0)) */
206 Cell predIntegral; /* Integral (mkOffset(0)) */
207 Kind starToStar; /* Type -> Type */
208 Cell predMonad; /* Monad (mkOffset(0)) */
209 Type typeProgIO; /* IO a */
212 /* --------------------------------------------------------------------------
214 * ------------------------------------------------------------------------*/
216 static Tycon linkTycon ( String s );
217 static Tycon linkClass ( String s );
218 static Name linkName ( String s );
219 static Name predefinePrim ( String s );
222 static Tycon linkTycon( String s )
224 Tycon tc = findTycon(findText(s));
225 if (nonNull(tc)) return tc;
227 tc = findTyconInAnyModule(findText(s));
228 if (nonNull(tc)) return tc;
230 fprintf(stderr, "frambozenvla! unknown tycon %s\n", s );
232 ERRMSG(0) "Prelude does not define standard type \"%s\"", s
236 static Class linkClass( String s )
238 Class cc = findClass(findText(s));
239 if (nonNull(cc)) return cc;
241 cc = findClassInAnyModule(findText(s));
242 if (nonNull(cc)) return cc;
244 fprintf(stderr, "frambozenvla! unknown class %s\n", s );
246 ERRMSG(0) "Prelude does not define standard class \"%s\"", s
250 static Name linkName( String s )
252 Name n = findName(findText(s));
253 if (nonNull(n)) return n;
255 n = findNameInAnyModule(findText(s));
256 if (nonNull(n)) return n;
258 fprintf(stderr, "frambozenvla! unknown name %s\n", s );
260 ERRMSG(0) "Prelude does not define standard name \"%s\"", s
264 static Name predefinePrim ( String s )
267 Text t = findText(s);
270 //fprintf(stderr, "predefinePrim: %s already exists\n", s );
273 name(nm).defn=PREDEFINED;
279 /* --------------------------------------------------------------------------
281 * ------------------------------------------------------------------------*/
283 /* In standalone mode, linkPreludeTC, linkPreludeCM and linkPrimNames
284 are called, in that order, during static analysis of Prelude.hs.
285 In combined mode such an analysis does not happen. Instead these
286 calls will be made as a result of a call link(POSTPREL).
288 linkPreludeTC, linkPreludeCM and linkPreludeNames are needed in both
289 standalone and combined modes.
293 Void linkPreludeTC(void) { /* Hook to tycons and classes in */
294 static Bool initialised = FALSE; /* prelude when first loaded */
298 setCurrModule(modulePrelude);
300 typeChar = linkTycon("Char");
301 typeInt = linkTycon("Int");
302 typeInteger = linkTycon("Integer");
303 typeWord = linkTycon("Word");
304 typeAddr = linkTycon("Addr");
305 typePrimArray = linkTycon("PrimArray");
306 typePrimByteArray = linkTycon("PrimByteArray");
307 typeRef = linkTycon("STRef");
308 typePrimMutableArray = linkTycon("PrimMutableArray");
309 typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
310 typeFloat = linkTycon("Float");
311 typeDouble = linkTycon("Double");
312 typeStable = linkTycon("StablePtr");
314 typeWeak = linkTycon("Weak");
316 # ifdef PROVIDE_FOREIGN
317 typeForeign = linkTycon("ForeignObj");
319 typeThreadId = linkTycon("ThreadId");
320 typeMVar = linkTycon("MVar");
321 typeBool = linkTycon("Bool");
322 typeST = linkTycon("ST");
323 typeIO = linkTycon("IO");
324 typeException = linkTycon("Exception");
325 typeString = linkTycon("String");
326 typeOrdering = linkTycon("Ordering");
328 classEq = linkClass("Eq");
329 classOrd = linkClass("Ord");
330 classIx = linkClass("Ix");
331 classEnum = linkClass("Enum");
332 classShow = linkClass("Show");
333 classRead = linkClass("Read");
334 classBounded = linkClass("Bounded");
335 classReal = linkClass("Real");
336 classIntegral = linkClass("Integral");
337 classRealFrac = linkClass("RealFrac");
338 classRealFloat = linkClass("RealFloat");
339 classFractional = linkClass("Fractional");
340 classFloating = linkClass("Floating");
341 classNum = linkClass("Num");
342 classMonad = linkClass("Monad");
345 stdDefaults = cons(typeDouble,stdDefaults);
346 stdDefaults = cons(typeInteger,stdDefaults);
348 predNum = ap(classNum,aVar);
349 predFractional = ap(classFractional,aVar);
350 predIntegral = ap(classIntegral,aVar);
351 predMonad = ap(classMonad,aVar);
352 typeProgIO = ap(typeIO,aVar);
354 nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
355 nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
356 nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
357 nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
358 nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
359 nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
360 nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
361 nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
363 # ifdef PROVIDE_FOREIGN
364 nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
367 nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
369 nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
370 nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
371 nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0);
372 nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
373 nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
374 nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
375 nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
377 name(namePrimSeq).type = primType(MONAD_Id, "ab", "b");
378 name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
379 name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
381 /* This is a lie. For a more accurate type of primTakeMVar
382 see ghc/interpreter/lib/Prelude.hs.
384 name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
387 for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
388 addTupInst(classEq,i);
389 addTupInst(classOrd,i);
390 addTupInst(classIx,i);
391 addTupInst(classShow,i);
392 addTupInst(classRead,i);
393 addTupInst(classBounded,i);
399 Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
400 static Bool initialised = FALSE; /* prelude when first loaded */
405 setCurrModule(modulePrelude);
408 nameFalse = linkName("False");
409 nameTrue = linkName("True");
412 nameEq = linkName("==");
413 nameFromInt = linkName("fromInt");
414 nameFromInteger = linkName("fromInteger");
415 nameReturn = linkName("return");
416 nameBind = linkName(">>=");
417 nameMFail = linkName("fail");
418 nameLe = linkName("<=");
419 nameGt = linkName(">");
420 nameShowsPrec = linkName("showsPrec");
421 nameReadsPrec = linkName("readsPrec");
422 nameEQ = linkName("EQ");
423 nameCompare = linkName("compare");
424 nameMinBnd = linkName("minBound");
425 nameMaxBnd = linkName("maxBound");
426 nameRange = linkName("range");
427 nameIndex = linkName("index");
428 namePlus = linkName("+");
429 nameMult = linkName("*");
430 nameRangeSize = linkName("rangeSize");
431 nameInRange = linkName("inRange");
432 nameMinus = linkName("-");
433 /* These come before calls to implementPrim */
435 for(i=0; i<NUM_TUPLES; ++i) {
436 if (i != 1) implementTuple(i);
442 Void linkPrimNames ( void ) { /* Hook to names defined in Prelude */
443 static Bool initialised = FALSE;
448 setCurrModule(modulePrelude);
451 nameMkIO = linkName("hugsprimMkIO");
455 for (i=0; asmPrimOps[i].name; ++i) {
456 Text t = findText(asmPrimOps[i].name);
457 Name n = findName(t);
462 name(n).type = primType(asmPrimOps[i].monad,
464 asmPrimOps[i].results);
465 name(n).arity = strlen(asmPrimOps[i].args);
466 name(n).primop = &(asmPrimOps[i]);
469 ERRMSG(0) "Link Error in Prelude, surplus definition of \"%s\"",
472 // Name already defined!
477 /* static(tidyInfix) */
478 nameNegate = linkName("negate");
480 nameRunIO_toplevel = linkName("hugsprimRunIO_toplevel");
481 nameShow = linkName("show");
482 namePutStr = linkName("putStr");
483 namePrint = linkName("print");
485 nameOtherwise = linkName("otherwise");
486 nameUndefined = linkName("undefined");
488 namePmSub = linkName("hugsprimPmSub");
490 nameEqChar = linkName("hugsprimEqChar");
491 nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk");
492 namePmInt = linkName("hugsprimPmInt");
493 namePmInteger = linkName("hugsprimPmInteger");
494 namePmDouble = linkName("hugsprimPmDouble");
496 nameFromDouble = linkName("fromDouble");
497 namePmFromInteger = linkName("hugsprimPmFromInteger");
499 namePmSubtract = linkName("hugsprimPmSubtract");
500 namePmLe = linkName("hugsprimPmLe");
503 implementCfun ( nameCons, NIL );
504 implementCfun ( nameNil, NIL );
505 implementCfun ( nameUnit, NIL );
511 /* --------------------------------------------------------------------------
513 * ------------------------------------------------------------------------*/
515 /* ToDo: fix pFun (or eliminate its use) */
516 #define pFun(n,s) n = predefinePrim(s)
518 Void linkControl(what)
522 //case EXIT : fooble();break;
529 Module modulePrelBase = findModule(findText("PrelBase"));
530 assert(nonNull(modulePrelBase));
531 fprintf(stderr, "linkControl(POSTPREL)\n");
532 setCurrModule(modulePrelude);
536 fixupRTStoPreludeRefs ( lookupObjName );
538 nameUnpackString = linkName("hugsprimUnpackString");
539 namePMFail = linkName("hugsprimPmFail");
540 assert(nonNull(namePMFail));
541 #define xyzzy(aaa,bbb) aaa = linkName(bbb)
545 pFun(nameSel, "_SEL");
547 /* strict constructors */
548 xyzzy(nameFlip, "flip" );
551 xyzzy(nameFromTo, "enumFromTo");
552 xyzzy(nameFromThenTo, "enumFromThenTo");
553 xyzzy(nameFrom, "enumFrom");
554 xyzzy(nameFromThen, "enumFromThen");
557 xyzzy(nameApp, "++");
558 xyzzy(nameReadField, "hugsprimReadField");
559 xyzzy(nameReadParen, "readParen");
560 xyzzy(nameShowField, "hugsprimShowField");
561 xyzzy(nameShowParen, "showParen");
562 xyzzy(nameLex, "lex");
563 xyzzy(nameComp, ".");
564 xyzzy(nameAnd, "&&");
565 xyzzy(nameCompAux, "hugsprimCompAux");
566 xyzzy(nameMap, "map");
568 /* implementTagToCon */
569 xyzzy(nameError, "hugsprimError");
572 typeStable = linkTycon("Stable");
573 typeRef = linkTycon("IORef");
574 // {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ?
576 ifLinkConstrItbl ( nameFalse );
577 ifLinkConstrItbl ( nameTrue );
578 ifLinkConstrItbl ( nameNil );
579 ifLinkConstrItbl ( nameCons );
581 /* PrelErr.hi doesn't give a type for error, alas.
582 So error never appears in any symbol table.
583 So we fake it by copying the table entry for
584 hugsprimError -- which is just a call to error.
585 Although we put it on the Prelude export list, we
586 have to claim internally that it lives in PrelErr,
587 so that the correct symbol (PrelErr_error_closure)
591 nm = newName ( findText("error"), NIL );
592 name(nm) = name(nameError);
593 name(nm).mod = findModule(findText("PrelErr"));
594 name(nm).text = findText("error");
595 setCurrModule(modulePrelude);
596 module(modulePrelude).exports
597 = cons ( nm, module(modulePrelude).exports );
599 /* The GHC prelude doesn't seem to export Addr. Add it to the
600 export list for the sake of compatibility with standalone mode.
602 module(modulePrelude).exports
603 = cons ( pair(typeAddr,DOTDOT),
604 module(modulePrelude).exports );
607 /* Make nameListMonad be the builder fn for instance Monad [].
608 Standalone hugs does this with a disgusting hack in
609 checkInstDefn() in static.c. We have a slightly different
610 disgusting hack for the combined case.
613 Class cm; /* :: Class */
614 List is; /* :: [Inst] */
615 cm = findClassInAnyModule(findText("Monad"));
617 is = cclass(cm).instances;
619 while (nonNull(is) && snd(inst(hd(is)).head) != typeList)
622 nameListMonad = inst(hd(is)).builder;
623 assert(nonNull(nameListMonad));
631 Module modulePrelBase;
633 modulePrelude = findFakeModule(textPrelude);
634 module(modulePrelude).objectExtraNames
635 = singleton(findText("libHS_cbits"));
637 nameMkC = addWiredInBoxingTycon("PrelBase", "Char", "C#",CHAR_REP, STAR );
638 nameMkI = addWiredInBoxingTycon("PrelBase", "Int", "I#",INT_REP, STAR );
639 nameMkW = addWiredInBoxingTycon("PrelAddr", "Word", "W#",WORD_REP, STAR );
640 nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr", "A#",ADDR_REP, STAR );
641 nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",FLOAT_REP, STAR );
642 nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",DOUBLE_REP, STAR );
644 = addWiredInBoxingTycon("PrelNum","Integer","Integer#",0 ,STAR );
646 = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",0 ,STAR );
648 for (i=0; i<NUM_TUPLES; ++i) {
649 if (i != 1) addTupleTycon(i);
651 addWiredInEnumTycon("PrelBase","Bool",
652 doubleton(findText("False"),findText("True")));
655 // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
656 // ,1,0,THREADID_REP);
658 setCurrModule(modulePrelude);
660 typeArrow = addPrimTycon(findText("(->)"),
661 pair(STAR,pair(STAR,STAR)),
665 pFun(nameInd, "_indirect");
666 name(nameInd).number = DFUNNAME;
668 /* newtype and USE_NEWTYPE_FOR_DICTS */
669 /* make a name entry for PrelBase.id _before_ loading Prelude
670 since ifSetClassDefaultsAndDCon() may need to refer to
673 modulePrelBase = findModule(findText("PrelBase"));
674 setCurrModule(modulePrelBase);
676 setCurrModule(modulePrelude);
679 fixupRTStoPreludeRefs(NULL);
681 modulePrelude = newModule(textPrelude);
682 setCurrModule(modulePrelude);
684 for (i=0; i<NUM_TUPLES; ++i) {
685 if (i != 1) addTupleTycon(i);
687 setCurrModule(modulePrelude);
689 typeArrow = addPrimTycon(findText("(->)"),
690 pair(STAR,pair(STAR,STAR)),
693 /* newtype and USE_NEWTYPE_FOR_DICTS */
697 pFun(nameInd, "_indirect");
698 name(nameInd).number = DFUNNAME;
701 pFun(nameSel, "_SEL");
703 /* strict constructors */
704 pFun(nameFlip, "flip" );
707 pFun(nameFromTo, "enumFromTo");
708 pFun(nameFromThenTo, "enumFromThenTo");
709 pFun(nameFrom, "enumFrom");
710 pFun(nameFromThen, "enumFromThen");
714 pFun(nameReadField, "hugsprimReadField");
715 pFun(nameReadParen, "readParen");
716 pFun(nameShowField, "hugsprimShowField");
717 pFun(nameShowParen, "showParen");
718 pFun(nameLex, "lex");
721 pFun(nameCompAux, "hugsprimCompAux");
722 pFun(nameMap, "map");
724 /* implementTagToCon */
725 pFun(namePMFail, "hugsprimPmFail");
726 pFun(nameError, "error");
727 pFun(nameUnpackString, "hugsprimUnpackString");
729 /* assertion and exception issues */
730 pFun(nameAssert, "assert");
731 pFun(nameAssertError, "assertError");
732 pFun(nameTangleMessage, "tangleMessager");
733 pFun(nameIrrefutPatError,
735 pFun(nameNoMethodBindingError,
736 "noMethodBindingError");
737 pFun(nameNonExhaustiveGuardsError,
738 "nonExhaustiveGuardsError");
739 pFun(namePatError, "patError");
740 pFun(nameRecSelError, "recSelError");
741 pFun(nameRecConError, "recConError");
742 pFun(nameRecUpdError, "recUpdError");
744 /* hooks for handwritten bytecode */
745 pFun(namePrimSeq, "primSeq");
746 pFun(namePrimCatch, "primCatch");
747 pFun(namePrimRaise, "primRaise");
748 pFun(namePrimTakeMVar, "primTakeMVar");
750 StgVar vv = mkStgVar(NIL,NIL);
751 Name n = namePrimSeq;
755 vv = mkStgVar(NIL,NIL);
756 stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
758 stgGlobals=cons(pair(n,vv),stgGlobals);
762 StgVar vv = mkStgVar(NIL,NIL);
763 Name n = namePrimCatch;
767 stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
769 stgGlobals=cons(pair(n,vv),stgGlobals);
772 StgVar vv = mkStgVar(NIL,NIL);
773 Name n = namePrimRaise;
777 stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
779 stgGlobals=cons(pair(n,vv),stgGlobals);
782 StgVar vv = mkStgVar(NIL,NIL);
783 Name n = namePrimTakeMVar;
787 stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
789 stgGlobals=cons(pair(n,vv),stgGlobals);
797 //#include "fooble.c"
798 /*-------------------------------------------------------------------------*/