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: 1999/11/23 15:12:08 $
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 */
96 Name nameUndefined; /* generic undefined value */
109 Name namePmFromInteger;
112 Name nameUnpackString;
115 Name nameCreateAdjThunk;
141 Name namePrimTakeMVar;
149 /* these names are required before we've had a chance to do the right thing */
151 Name nameUnsafeUnpackCString;
153 /* constructors used during translation and codegen */
154 Name nameMkC; /* Char# -> Char */
155 Name nameMkI; /* Int# -> Int */
156 Name nameMkInteger; /* Integer# -> Integer */
157 Name nameMkW; /* Word# -> Word */
158 Name nameMkA; /* Addr# -> Addr */
159 Name nameMkF; /* Float# -> Float */
160 Name nameMkD; /* Double# -> Double */
161 Name nameMkPrimArray;
162 Name nameMkPrimByteArray;
164 Name nameMkPrimMutableArray;
165 Name nameMkPrimMutableByteArray;
166 Name nameMkStable; /* StablePtr# a -> StablePtr a */
167 Name nameMkThreadId; /* ThreadId# -> ThreadId */
168 Name nameMkPrimMVar; /* MVar# a -> MVar a */
170 Name nameMkWeak; /* Weak# a -> Weak a */
172 #ifdef PROVIDE_FOREIGN
173 Name nameMkForeign; /* ForeignObj# -> ForeignObj */
193 Module modulePrelude;
198 /* --------------------------------------------------------------------------
199 * Frequently used type skeletons:
200 * ------------------------------------------------------------------------*/
202 Type arrow; /* mkOffset(0) -> mkOffset(1) */
203 Type boundPair; /* (mkOffset(0),mkOffset(0)) */
204 Type listof; /* [ mkOffset(0) ] */
205 Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
207 Cell predNum; /* Num (mkOffset(0)) */
208 Cell predFractional; /* Fractional (mkOffset(0)) */
209 Cell predIntegral; /* Integral (mkOffset(0)) */
210 Kind starToStar; /* Type -> Type */
211 Cell predMonad; /* Monad (mkOffset(0)) */
212 Type typeProgIO; /* IO a */
214 /* --------------------------------------------------------------------------
216 * ------------------------------------------------------------------------*/
218 static Tycon linkTycon ( String s );
219 static Tycon linkClass ( String s );
220 static Name linkName ( String s );
221 static Void mkTypes ( void );
222 static Name predefinePrim ( String s );
225 static Tycon linkTycon( String s )
227 Tycon tc = findTycon(findText(s));
231 ERRMSG(0) "Prelude does not define standard type \"%s\"", s
235 static Class linkClass( String s )
237 Class cc = findClass(findText(s));
241 ERRMSG(0) "Prelude does not define standard class \"%s\"", s
245 static Name linkName( String s )
247 Name n = findName(findText(s));
251 ERRMSG(0) "Prelude does not define standard name \"%s\"", s
255 static Name predefinePrim ( String s )
258 Text t = findText(s);
261 //fprintf(stderr, "predefinePrim: %s already exists\n", s );
264 name(nm).defn=PREDEFINED;
269 Void linkPreludeTC(void) { /* Hook to tycons and classes in */
270 static Bool initialised = FALSE; /* prelude when first loaded */
274 setCurrModule(modulePrelude);
276 typeChar = linkTycon("Char");
277 typeInt = linkTycon("Int");
278 typeInteger = linkTycon("Integer");
279 typeWord = linkTycon("Word");
280 typeAddr = linkTycon("Addr");
281 typePrimArray = linkTycon("PrimArray");
282 typePrimByteArray = linkTycon("PrimByteArray");
283 typeRef = linkTycon("STRef");
284 typePrimMutableArray = linkTycon("PrimMutableArray");
285 typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
286 typeFloat = linkTycon("Float");
287 typeDouble = linkTycon("Double");
288 typeStable = linkTycon("StablePtr");
290 typeWeak = linkTycon("Weak");
292 #ifdef PROVIDE_FOREIGN
293 typeForeign = linkTycon("ForeignObj");
295 typeThreadId = linkTycon("ThreadId");
296 typeMVar = linkTycon("MVar");
297 typeBool = linkTycon("Bool");
298 typeST = linkTycon("ST");
299 typeIO = linkTycon("IO");
300 typeException = linkTycon("Exception");
301 typeString = linkTycon("String");
302 typeOrdering = linkTycon("Ordering");
304 classEq = linkClass("Eq");
305 classOrd = linkClass("Ord");
306 classIx = linkClass("Ix");
307 classEnum = linkClass("Enum");
308 classShow = linkClass("Show");
309 classRead = linkClass("Read");
310 classBounded = linkClass("Bounded");
311 classReal = linkClass("Real");
312 classIntegral = linkClass("Integral");
313 classRealFrac = linkClass("RealFrac");
314 classRealFloat = linkClass("RealFloat");
315 classFractional = linkClass("Fractional");
316 classFloating = linkClass("Floating");
317 classNum = linkClass("Num");
318 classMonad = linkClass("Monad");
321 stdDefaults = cons(typeDouble,stdDefaults);
323 stdDefaults = cons(typeInteger,stdDefaults);
325 stdDefaults = cons(typeInt,stdDefaults);
329 nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
330 nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
331 nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
332 nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
333 nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
334 nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
335 nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
336 nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
338 #ifdef PROVIDE_FOREIGN
339 nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
342 nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
344 nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
345 nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
346 nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0);
347 nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
348 nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
349 nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
350 nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
352 /* The following primitives are referred to in derived instances and
353 * hence require types; the following types are a little more general
354 * than we might like, but they are the closest we can get without a
355 * special datatype class.
357 name(nameConCmp).type
358 = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
359 name(nameEnRange).type
360 = mkPolyType(starToStar,fn(boundPair,listof));
361 name(nameEnIndex).type
362 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
363 name(nameEnInRng).type
364 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
365 name(nameEnToEn).type
366 = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
367 name(nameEnFrEn).type
368 = mkPolyType(starToStar,fn(aVar,typeInt));
369 name(nameEnFrom).type
370 = mkPolyType(starToStar,fn(aVar,listof));
371 name(nameEnFrTo).type
372 = name(nameEnFrTh).type
373 = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
375 name(namePrimSeq).type
376 = primType(MONAD_Id, "ab", "b");
377 name(namePrimCatch).type
378 = primType(MONAD_Id, "aH", "a");
379 name(namePrimRaise).type
380 = primType(MONAD_Id, "E", "a");
382 /* This is a lie. For a more accurate type of primTakeMVar
383 see ghc/interpreter/lib/Prelude.hs.
385 name(namePrimTakeMVar).type
386 = primType(MONAD_Id, "rbc", "d");
388 for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
389 addTupInst(classEq,i);
390 addTupInst(classOrd,i);
391 addTupInst(classIx,i);
392 addTupInst(classShow,i);
393 addTupInst(classRead,i);
394 addTupInst(classBounded,i);
399 static Void mkTypes ( void )
401 predNum = ap(classNum,aVar);
402 predFractional = ap(classFractional,aVar);
403 predIntegral = ap(classIntegral,aVar);
404 predMonad = ap(classMonad,aVar);
405 typeProgIO = ap(typeIO,aVar);
408 Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
409 static Bool initialised = FALSE; /* prelude when first loaded */
414 setCurrModule(modulePrelude);
417 nameFalse = linkName("False");
418 nameTrue = linkName("True");
421 nameEq = linkName("==");
422 nameFromInt = linkName("fromInt");
423 nameFromInteger = linkName("fromInteger");
424 nameFromDouble = linkName("fromDouble");
425 nameReturn = linkName("return");
426 nameBind = linkName(">>=");
427 nameLe = linkName("<=");
428 nameGt = linkName(">");
429 nameShowsPrec = linkName("showsPrec");
430 nameReadsPrec = linkName("readsPrec");
431 nameEQ = linkName("EQ");
432 nameCompare = linkName("compare");
433 nameMinBnd = linkName("minBound");
434 nameMaxBnd = linkName("maxBound");
435 nameRange = linkName("range");
436 nameIndex = linkName("index");
437 namePlus = linkName("+");
438 nameMult = linkName("*");
439 nameRangeSize = linkName("rangeSize");
440 nameInRange = linkName("inRange");
441 nameMinus = linkName("-");
442 /* These come before calls to implementPrim */
443 for(i=0; i<NUM_TUPLES; ++i) {
449 Void linkPreludeNames(void) { /* Hook to names defined in Prelude */
450 static Bool initialised = FALSE;
455 setCurrModule(modulePrelude);
458 nameMkIO = linkName("primMkIO");
459 for (i=0; asmPrimOps[i].name; ++i) {
460 Text t = findText(asmPrimOps[i].name);
461 Name n = findName(t);
467 name(n).type = primType(asmPrimOps[i].monad,
469 asmPrimOps[i].results);
470 name(n).arity = strlen(asmPrimOps[i].args);
471 name(n).primop = &(asmPrimOps[i]);
475 nameRunST = linkName("primRunST");
477 /* static(tidyInfix) */
478 nameNegate = linkName("negate");
480 nameRunIO = linkName("primRunIO_hugs_toplevel");
481 namePrint = linkName("print");
483 nameOtherwise = linkName("otherwise");
484 nameUndefined = linkName("undefined");
487 namePmSub = linkName("primPmSub");
490 nameEqChar = linkName("primEqChar");
491 nameEqInt = linkName("primEqInt");
492 nameCreateAdjThunk = linkName("primCreateAdjThunk");
493 nameEqDouble = linkName("primEqDouble");
494 namePmInt = linkName("primPmInt");
495 namePmInteger = linkName("primPmInteger");
496 namePmDouble = linkName("primPmDouble");
501 /* ToDo: fix pFun (or eliminate its use) */
502 #define pFun(n,s) n = predefinePrim(s)
504 Void linkControl(what)
511 case INSTALL : linkControl(RESET);
513 modulePrelude = newModule(textPrelude);
514 setCurrModule(modulePrelude);
516 typeArrow = addPrimTycon(findText("(->)"),
517 pair(STAR,pair(STAR,STAR)),
520 /* newtype and USE_NEWTYPE_FOR_DICTS */
524 pFun(nameInd, "_indirect");
525 name(nameInd).number = DFUNNAME;
528 pFun(nameSel, "_SEL");
530 /* strict constructors */
531 pFun(nameFlip, "flip" );
534 pFun(nameFromTo, "enumFromTo");
535 pFun(nameFromThenTo, "enumFromThenTo");
536 pFun(nameFrom, "enumFrom");
537 pFun(nameFromThen, "enumFromThen");
541 pFun(nameReadField, "readField");
542 pFun(nameReadParen, "readParen");
543 pFun(nameShowField, "showField");
544 pFun(nameShowParen, "showParen");
545 pFun(nameLex, "lex");
546 pFun(nameEnToEn, "toEnumPR"); //not sure
547 pFun(nameEnFrEn, "fromEnum"); //not sure
548 pFun(nameEnFrom, "enumFrom"); //not sure
549 pFun(nameEnFrTh, "enumFromThen"); //not sure
550 pFun(nameEnFrTo, "enumFromTo"); //not sure
551 pFun(nameEnRange, "range"); //not sure
552 pFun(nameEnIndex, "index"); //not sure
553 pFun(nameEnInRng, "inRange"); //not sure
554 pFun(nameConCmp, "_concmp"); //very not sure
557 pFun(nameCompAux, "primCompAux");
558 pFun(nameMap, "map");
560 /* implementTagToCon */
561 pFun(namePMFail, "primPmFail");
562 pFun(nameError, "error");
563 pFun(nameUnpackString, "primUnpackString");
565 /* hooks for handwritten bytecode */
566 pFun(namePrimSeq, "primSeq");
567 pFun(namePrimCatch, "primCatch");
568 pFun(namePrimRaise, "primRaise");
569 pFun(namePrimTakeMVar, "primTakeMVar");
571 StgVar vv = mkStgVar(NIL,NIL);
572 Name n = namePrimSeq;
576 vv = mkStgVar(NIL,NIL);
577 stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
579 stgGlobals=cons(pair(n,vv),stgGlobals);
583 StgVar vv = mkStgVar(NIL,NIL);
584 Name n = namePrimCatch;
588 stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
590 stgGlobals=cons(pair(n,vv),stgGlobals);
593 StgVar vv = mkStgVar(NIL,NIL);
594 Name n = namePrimRaise;
598 stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
600 stgGlobals=cons(pair(n,vv),stgGlobals);
603 StgVar vv = mkStgVar(NIL,NIL);
604 Name n = namePrimTakeMVar;
608 stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
610 stgGlobals=cons(pair(n,vv),stgGlobals);
618 /*-------------------------------------------------------------------------*/