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/09 02:47:13 $
14 * ------------------------------------------------------------------------*/
21 #include "Assembler.h" /* for asmPrimOps and AsmReps */
26 Type typeArrow; /* Function spaces */
34 Type typePrimByteArray;
36 Type typePrimMutableArray;
37 Type typePrimMutableByteArray;
46 #ifdef PROVIDE_FOREIGN
58 Class classEq; /* `standard' classes */
66 Class classReal; /* `numeric' classes */
70 Class classFractional;
73 Class classMonad; /* Monads and monads with a zero */
75 List stdDefaults; /* standard default values */
78 Name nameFalse; /* primitive boolean constructors */
80 Name nameCons; /* primitive list constructors */
81 Name nameUnit; /* primitive Unit type constructor */
85 Name nameFromDouble; /* coercion of numerics */
88 Name nameBind; /* for translating monad comps */
89 Name nameZero; /* for monads with a zero */
94 Name nameRunIO_toplevel;
98 Name nameUndefined; /* generic undefined value */
109 Name namePmFromInteger;
111 Name nameUnpackString;
114 Name nameCreateAdjThunk;
131 Name namePrimTakeMVar;
139 /* these names are required before we've had a chance to do the right thing */
141 Name nameUnsafeUnpackCString;
143 /* constructors used during translation and codegen */
144 Name nameMkC; /* Char# -> Char */
145 Name nameMkI; /* Int# -> Int */
146 Name nameMkInteger; /* Integer# -> Integer */
147 Name nameMkW; /* Word# -> Word */
148 Name nameMkA; /* Addr# -> Addr */
149 Name nameMkF; /* Float# -> Float */
150 Name nameMkD; /* Double# -> Double */
151 Name nameMkPrimArray;
152 Name nameMkPrimByteArray;
154 Name nameMkPrimMutableArray;
155 Name nameMkPrimMutableByteArray;
156 Name nameMkStable; /* StablePtr# a -> StablePtr a */
157 Name nameMkThreadId; /* ThreadId# -> ThreadId */
158 Name nameMkPrimMVar; /* MVar# a -> MVar a */
160 Name nameMkWeak; /* Weak# a -> Weak a */
162 #ifdef PROVIDE_FOREIGN
163 Name nameMkForeign; /* ForeignObj# -> ForeignObj */
183 Module modulePrelude;
188 /* --------------------------------------------------------------------------
189 * Frequently used type skeletons:
190 * ------------------------------------------------------------------------*/
192 Type arrow; /* mkOffset(0) -> mkOffset(1) */
193 Type boundPair; /* (mkOffset(0),mkOffset(0)) */
194 Type listof; /* [ mkOffset(0) ] */
195 Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
197 Cell predNum; /* Num (mkOffset(0)) */
198 Cell predFractional; /* Fractional (mkOffset(0)) */
199 Cell predIntegral; /* Integral (mkOffset(0)) */
200 Kind starToStar; /* Type -> Type */
201 Cell predMonad; /* Monad (mkOffset(0)) */
202 Type typeProgIO; /* IO a */
205 /* --------------------------------------------------------------------------
207 * ------------------------------------------------------------------------*/
209 static Tycon linkTycon ( String s );
210 static Tycon linkClass ( String s );
211 static Name linkName ( String s );
212 static Name predefinePrim ( String s );
215 static Tycon linkTycon( String s )
217 Tycon tc = findTycon(findText(s));
218 if (nonNull(tc)) return tc;
220 tc = findTyconInAnyModule(findText(s));
221 if (nonNull(tc)) return tc;
223 fprintf(stderr, "frambozenvla! unknown tycon %s\n", s );
225 ERRMSG(0) "Prelude does not define standard type \"%s\"", s
229 static Class linkClass( String s )
231 Class cc = findClass(findText(s));
232 if (nonNull(cc)) return cc;
234 cc = findClassInAnyModule(findText(s));
235 if (nonNull(cc)) return cc;
237 fprintf(stderr, "frambozenvla! unknown class %s\n", s );
239 ERRMSG(0) "Prelude does not define standard class \"%s\"", s
243 static Name linkName( String s )
245 Name n = findName(findText(s));
246 if (nonNull(n)) return n;
248 n = findNameInAnyModule(findText(s));
249 if (nonNull(n)) return n;
251 fprintf(stderr, "frambozenvla! unknown name %s\n", s );
253 ERRMSG(0) "Prelude does not define standard name \"%s\"", s
257 static Name predefinePrim ( String s )
260 Text t = findText(s);
263 //fprintf(stderr, "predefinePrim: %s already exists\n", s );
266 name(nm).defn=PREDEFINED;
272 /* --------------------------------------------------------------------------
274 * ------------------------------------------------------------------------*/
276 /* In standalone mode, linkPreludeTC, linkPreludeCM and linkPrimitiveNames
277 are called, in that order, during static analysis of Prelude.hs.
278 In combined mode such an analysis does not happen. Instead these
279 calls will be made as a result of a call link(POSTPREL).
281 linkPreludeTC, linkPreludeCM and linkPreludeNames are needed in both
282 standalone and combined modes.
286 Void linkPreludeTC(void) { /* Hook to tycons and classes in */
287 static Bool initialised = FALSE; /* prelude when first loaded */
291 setCurrModule(modulePrelude);
293 typeChar = linkTycon("Char");
294 typeInt = linkTycon("Int");
295 typeInteger = linkTycon("Integer");
296 typeWord = linkTycon("Word");
297 typeAddr = linkTycon("Addr");
298 typePrimArray = linkTycon("PrimArray");
299 typePrimByteArray = linkTycon("PrimByteArray");
300 typeRef = linkTycon("STRef");
301 typePrimMutableArray = linkTycon("PrimMutableArray");
302 typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
303 typeFloat = linkTycon("Float");
304 typeDouble = linkTycon("Double");
305 typeStable = linkTycon("StablePtr");
307 typeWeak = linkTycon("Weak");
309 # ifdef PROVIDE_FOREIGN
310 typeForeign = linkTycon("ForeignObj");
312 typeThreadId = linkTycon("ThreadId");
313 typeMVar = linkTycon("MVar");
314 typeBool = linkTycon("Bool");
315 typeST = linkTycon("ST");
316 typeIO = linkTycon("IO");
317 typeException = linkTycon("Exception");
318 typeString = linkTycon("String");
319 typeOrdering = linkTycon("Ordering");
321 classEq = linkClass("Eq");
322 classOrd = linkClass("Ord");
323 classIx = linkClass("Ix");
324 classEnum = linkClass("Enum");
325 classShow = linkClass("Show");
326 classRead = linkClass("Read");
327 classBounded = linkClass("Bounded");
328 classReal = linkClass("Real");
329 classIntegral = linkClass("Integral");
330 classRealFrac = linkClass("RealFrac");
331 classRealFloat = linkClass("RealFloat");
332 classFractional = linkClass("Fractional");
333 classFloating = linkClass("Floating");
334 classNum = linkClass("Num");
335 classMonad = linkClass("Monad");
338 stdDefaults = cons(typeDouble,stdDefaults);
340 stdDefaults = cons(typeInteger,stdDefaults);
342 stdDefaults = cons(typeInt,stdDefaults);
345 predNum = ap(classNum,aVar);
346 predFractional = ap(classFractional,aVar);
347 predIntegral = ap(classIntegral,aVar);
348 predMonad = ap(classMonad,aVar);
349 typeProgIO = ap(typeIO,aVar);
351 nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
352 nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
353 nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
354 nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
355 nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
356 nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
357 nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
358 nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
360 # ifdef PROVIDE_FOREIGN
361 nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
364 nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
366 nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
367 nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
368 nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0);
369 nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
370 nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
371 nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
372 nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
374 name(namePrimSeq).type = primType(MONAD_Id, "ab", "b");
375 name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
376 name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
378 /* This is a lie. For a more accurate type of primTakeMVar
379 see ghc/interpreter/lib/Prelude.hs.
381 name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
384 for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
385 addTupInst(classEq,i);
386 addTupInst(classOrd,i);
387 addTupInst(classIx,i);
388 addTupInst(classShow,i);
389 addTupInst(classRead,i);
390 addTupInst(classBounded,i);
396 Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
397 static Bool initialised = FALSE; /* prelude when first loaded */
402 setCurrModule(modulePrelude);
405 nameFalse = linkName("False");
406 nameTrue = linkName("True");
409 nameEq = linkName("==");
410 nameFromInt = linkName("fromInt");
411 nameFromInteger = linkName("fromInteger");
412 nameReturn = linkName("return");
413 nameBind = linkName(">>=");
414 nameMFail = linkName("fail");
415 nameLe = linkName("<=");
416 nameGt = linkName(">");
417 nameShowsPrec = linkName("showsPrec");
418 nameReadsPrec = linkName("readsPrec");
419 nameEQ = linkName("EQ");
420 nameCompare = linkName("compare");
421 nameMinBnd = linkName("minBound");
422 nameMaxBnd = linkName("maxBound");
423 nameRange = linkName("range");
424 nameIndex = linkName("index");
425 namePlus = linkName("+");
426 nameMult = linkName("*");
427 nameRangeSize = linkName("rangeSize");
428 nameInRange = linkName("inRange");
429 nameMinus = linkName("-");
430 /* These come before calls to implementPrim */
432 for(i=0; i<NUM_TUPLES; ++i) {
433 if (i != 1) implementTuple(i);
439 Void linkPrimitiveNames(void) { /* Hook to names defined in Prelude */
440 static Bool initialised = FALSE;
445 setCurrModule(modulePrelude);
448 nameMkIO = linkName("hugsprimMkIO");
452 for (i=0; asmPrimOps[i].name; ++i) {
453 Text t = findText(asmPrimOps[i].name);
454 Name n = findName(t);
459 name(n).type = primType(asmPrimOps[i].monad,
461 asmPrimOps[i].results);
462 name(n).arity = strlen(asmPrimOps[i].args);
463 name(n).primop = &(asmPrimOps[i]);
466 ERRMSG(0) "Link Error in Prelude, surplus definition of \"%s\"",
469 // Name already defined!
474 /* static(tidyInfix) */
475 nameNegate = linkName("negate");
477 nameRunIO_toplevel = linkName("hugsprimRunIO_toplevel");
478 nameShow = linkName("show");
479 namePutStr = linkName("putStr");
480 namePrint = linkName("print");
482 nameOtherwise = linkName("otherwise");
483 nameUndefined = linkName("undefined");
486 namePmSub = linkName("hugsprimPmSub");
489 nameEqChar = linkName("hugsprimEqChar");
490 nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk");
491 namePmInt = linkName("hugsprimPmInt");
492 namePmInteger = linkName("hugsprimPmInteger");
493 namePmDouble = linkName("hugsprimPmDouble");
495 nameFromDouble = linkName("fromDouble");
496 namePmFromInteger = linkName("hugsprimPmFromInteger");
498 namePmSubtract = linkName("hugsprimPmSubtract");
499 namePmLe = linkName("hugsprimPmLe");
502 implementCfun ( nameCons, NIL );
503 implementCfun ( nameNil, NIL );
504 implementCfun ( nameUnit, NIL );
510 /* --------------------------------------------------------------------------
512 * ------------------------------------------------------------------------*/
514 /* ToDo: fix pFun (or eliminate its use) */
515 #define pFun(n,s) n = predefinePrim(s)
517 Void linkControl(what)
521 //case EXIT : fooble();break;
528 Module modulePrelBase = findModule(findText("PrelBase"));
529 assert(nonNull(modulePrelBase));
530 fprintf(stderr, "linkControl(POSTPREL)\n");
531 setCurrModule(modulePrelude);
534 linkPrimitiveNames();
536 nameUnpackString = linkName("hugsprimUnpackString");
537 namePMFail = linkName("hugsprimPmFail");
538 assert(nonNull(namePMFail));
539 #define xyzzy(aaa,bbb) aaa = linkName(bbb)
543 pFun(nameSel, "_SEL");
545 /* strict constructors */
546 xyzzy(nameFlip, "flip" );
549 xyzzy(nameFromTo, "enumFromTo");
550 xyzzy(nameFromThenTo, "enumFromThenTo");
551 xyzzy(nameFrom, "enumFrom");
552 xyzzy(nameFromThen, "enumFromThen");
555 xyzzy(nameApp, "++");
556 xyzzy(nameReadField, "hugsprimReadField");
557 xyzzy(nameReadParen, "readParen");
558 xyzzy(nameShowField, "hugsprimShowField");
559 xyzzy(nameShowParen, "showParen");
560 xyzzy(nameLex, "lex");
561 xyzzy(nameComp, ".");
562 xyzzy(nameAnd, "&&");
563 xyzzy(nameCompAux, "hugsprimCompAux");
564 xyzzy(nameMap, "map");
566 /* implementTagToCon */
567 xyzzy(nameError, "hugsprimError");
569 typeStable = linkTycon("Stable");
570 typeRef = linkTycon("IORef");
571 // {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ?
573 ifLinkConstrItbl ( nameFalse );
574 ifLinkConstrItbl ( nameTrue );
575 ifLinkConstrItbl ( nameNil );
576 ifLinkConstrItbl ( nameCons );
578 /* PrelErr.hi doesn't give a type for error, alas.
579 So error never appears in any symbol table.
580 So we fake it by copying the table entry for
581 hugsprimError -- which is just a call to error.
582 Although we put it on the Prelude export list, we
583 have to claim internally that it lives in PrelErr,
584 so that the correct symbol (PrelErr_error_closure)
588 nm = newName ( findText("error"), NIL );
589 name(nm) = name(nameError);
590 name(nm).mod = findModule(findText("PrelErr"));
591 name(nm).text = findText("error");
592 setCurrModule(modulePrelude);
593 module(modulePrelude).exports
594 = cons ( nm, module(modulePrelude).exports );
596 /* The GHC prelude doesn't seem to export Addr. Add it to the
597 export list for the sake of compatibility with standalone mode.
599 module(modulePrelude).exports
600 = cons ( pair(typeAddr,DOTDOT),
601 module(modulePrelude).exports );
604 /* Make nameListMonad be the builder fn for instance Monad [].
605 Standalone hugs does this with a disgusting hack in
606 checkInstDefn() in static.c. We have a slightly different
607 disgusting hack for the combined case.
610 Class cm; /* :: Class */
611 List is; /* :: [Inst] */
612 cm = findClassInAnyModule(findText("Monad"));
614 is = cclass(cm).instances;
616 while (nonNull(is) && snd(inst(hd(is)).head) != typeList)
619 nameListMonad = inst(hd(is)).builder;
620 assert(nonNull(nameListMonad));
628 Module modulePrelBase;
630 modulePrelude = findFakeModule(textPrelude);
631 module(modulePrelude).objectExtraNames
632 = singleton(findText("libHS_cbits"));
634 nameMkC = addWiredInBoxingTycon("PrelBase", "Char", "C#",CHAR_REP, STAR );
635 nameMkI = addWiredInBoxingTycon("PrelBase", "Int", "I#",INT_REP, STAR );
636 nameMkW = addWiredInBoxingTycon("PrelAddr", "Word", "W#",WORD_REP, STAR );
637 nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr", "A#",ADDR_REP, STAR );
638 nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",FLOAT_REP, STAR );
639 nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",DOUBLE_REP, STAR );
641 = addWiredInBoxingTycon("PrelNum","Integer","Integer#",0 ,STAR );
643 = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",0 ,STAR );
645 for (i=0; i<NUM_TUPLES; ++i) {
646 if (i != 1) addTupleTycon(i);
648 addWiredInEnumTycon("PrelBase","Bool",
649 doubleton(findText("False"),findText("True")));
652 // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
653 // ,1,0,THREADID_REP);
655 setCurrModule(modulePrelude);
657 typeArrow = addPrimTycon(findText("(->)"),
658 pair(STAR,pair(STAR,STAR)),
662 pFun(nameInd, "_indirect");
663 name(nameInd).number = DFUNNAME;
665 /* newtype and USE_NEWTYPE_FOR_DICTS */
666 /* make a name entry for PrelBase.id _before_ loading Prelude
667 since ifSetClassDefaultsAndDCon() may need to refer to
670 modulePrelBase = findModule(findText("PrelBase"));
671 setCurrModule(modulePrelBase);
673 setCurrModule(modulePrelude);
677 modulePrelude = newModule(textPrelude);
678 setCurrModule(modulePrelude);
680 for (i=0; i<NUM_TUPLES; ++i) {
681 if (i != 1) addTupleTycon(i);
683 setCurrModule(modulePrelude);
685 typeArrow = addPrimTycon(findText("(->)"),
686 pair(STAR,pair(STAR,STAR)),
689 /* newtype and USE_NEWTYPE_FOR_DICTS */
693 pFun(nameInd, "_indirect");
694 name(nameInd).number = DFUNNAME;
697 pFun(nameSel, "_SEL");
699 /* strict constructors */
700 pFun(nameFlip, "flip" );
703 pFun(nameFromTo, "enumFromTo");
704 pFun(nameFromThenTo, "enumFromThenTo");
705 pFun(nameFrom, "enumFrom");
706 pFun(nameFromThen, "enumFromThen");
710 pFun(nameReadField, "hugsprimReadField");
711 pFun(nameReadParen, "readParen");
712 pFun(nameShowField, "hugsprimShowField");
713 pFun(nameShowParen, "showParen");
714 pFun(nameLex, "lex");
717 pFun(nameCompAux, "hugsprimCompAux");
718 pFun(nameMap, "map");
720 /* implementTagToCon */
721 pFun(namePMFail, "hugsprimPmFail");
722 pFun(nameError, "error");
723 pFun(nameUnpackString, "hugsprimUnpackString");
725 /* hooks for handwritten bytecode */
726 pFun(namePrimSeq, "primSeq");
727 pFun(namePrimCatch, "primCatch");
728 pFun(namePrimRaise, "primRaise");
729 pFun(namePrimTakeMVar, "primTakeMVar");
731 StgVar vv = mkStgVar(NIL,NIL);
732 Name n = namePrimSeq;
736 vv = mkStgVar(NIL,NIL);
737 stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
739 stgGlobals=cons(pair(n,vv),stgGlobals);
743 StgVar vv = mkStgVar(NIL,NIL);
744 Name n = namePrimCatch;
748 stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
750 stgGlobals=cons(pair(n,vv),stgGlobals);
753 StgVar vv = mkStgVar(NIL,NIL);
754 Name n = namePrimRaise;
758 stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
760 stgGlobals=cons(pair(n,vv),stgGlobals);
763 StgVar vv = mkStgVar(NIL,NIL);
764 Name n = namePrimTakeMVar;
768 stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
770 stgGlobals=cons(pair(n,vv),stgGlobals);
778 //#include "fooble.c"
779 /*-------------------------------------------------------------------------*/