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/10/29 00:53:25 $
14 * ------------------------------------------------------------------------*/
21 #include "Assembler.h" /* for asmPrimOps and AsmReps */
26 Type typeArrow; /* Function spaces */
34 Type typePrimByteArray;
36 Type typePrimMutableArray;
37 Type typePrimMutableByteArray;
44 #ifdef PROVIDE_FOREIGN
47 #ifdef PROVIDE_CONCURRENT
60 Class classEq; /* `standard' classes */
68 Class classReal; /* `numeric' classes */
72 Class classFractional;
75 Class classMonad; /* Monads and monads with a zero */
77 List stdDefaults; /* standard default values */
80 Name nameFalse; /* primitive boolean constructors */
82 Name nameCons; /* primitive list constructors */
83 Name nameUnit; /* primitive Unit type constructor */
87 Name nameFromDouble; /* coercion of numerics */
90 Name nameBind; /* for translating monad comps */
91 Name nameZero; /* for monads with a zero */
98 Name nameUndefined; /* generic undefined value */
105 #if !OVERLOADED_CONSTANTS
114 Name namePmFromInteger;
117 Name nameUnpackString;
120 Name nameCreateAdjThunk;
153 /* these names are required before we've had a chance to do the right thing */
155 Name nameUnsafeUnpackCString;
157 /* constructors used during translation and codegen */
158 Name nameMkC; /* Char# -> Char */
159 Name nameMkI; /* Int# -> Int */
160 Name nameMkInteger; /* Integer# -> Integer */
161 Name nameMkW; /* Word# -> Word */
162 Name nameMkA; /* Addr# -> Addr */
163 Name nameMkF; /* Float# -> Float */
164 Name nameMkD; /* Double# -> Double */
165 Name nameMkPrimArray;
166 Name nameMkPrimByteArray;
168 Name nameMkPrimMutableArray;
169 Name nameMkPrimMutableByteArray;
170 Name nameMkStable; /* StablePtr# a -> StablePtr a */
172 Name nameMkWeak; /* Weak# a -> Weak a */
174 #ifdef PROVIDE_FOREIGN
175 Name nameMkForeign; /* ForeignObj# -> ForeignObj */
177 #ifdef PROVIDE_CONCURRENT
178 Name nameMkThreadId; /* ThreadId# -> ThreadId */
179 Name nameMkMVar; /* MVar# -> MVar */
199 Module modulePrelude;
204 /* --------------------------------------------------------------------------
205 * Frequently used type skeletons:
206 * ------------------------------------------------------------------------*/
208 Type arrow; /* mkOffset(0) -> mkOffset(1) */
209 Type boundPair; /* (mkOffset(0),mkOffset(0)) */
210 Type listof; /* [ mkOffset(0) ] */
211 Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
213 Cell predNum; /* Num (mkOffset(0)) */
214 Cell predFractional; /* Fractional (mkOffset(0)) */
215 Cell predIntegral; /* Integral (mkOffset(0)) */
216 Kind starToStar; /* Type -> Type */
217 Cell predMonad; /* Monad (mkOffset(0)) */
219 /* --------------------------------------------------------------------------
221 * ------------------------------------------------------------------------*/
223 static Tycon linkTycon ( String s );
224 static Tycon linkClass ( String s );
225 static Name linkName ( String s );
226 static Void mkTypes ( void );
227 static Name predefinePrim ( String s );
230 static Tycon linkTycon( String s )
232 Tycon tc = findTycon(findText(s));
236 ERRMSG(0) "Prelude does not define standard type \"%s\"", s
240 static Class linkClass( String s )
242 Class cc = findClass(findText(s));
246 ERRMSG(0) "Prelude does not define standard class \"%s\"", s
250 static Name linkName( String s )
252 Name n = findName(findText(s));
256 ERRMSG(0) "Prelude does not define standard name \"%s\"", s
260 static Name predefinePrim ( String s )
263 Text t = findText(s);
266 //fprintf(stderr, "predefinePrim: %s already exists\n", s );
269 name(nm).defn=PREDEFINED;
274 Void linkPreludeTC(void) { /* Hook to tycons and classes in */
275 static Bool initialised = FALSE; /* prelude when first loaded */
279 setCurrModule(modulePrelude);
281 typeChar = linkTycon("Char");
282 typeInt = linkTycon("Int");
283 typeInteger = linkTycon("Integer");
284 typeWord = linkTycon("Word");
285 typeAddr = linkTycon("Addr");
286 typePrimArray = linkTycon("PrimArray");
287 typePrimByteArray = linkTycon("PrimByteArray");
288 typeRef = linkTycon("Ref");
289 typePrimMutableArray = linkTycon("PrimMutableArray");
290 typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
291 typeFloat = linkTycon("Float");
292 typeDouble = linkTycon("Double");
293 typeStable = linkTycon("StablePtr");
295 typeWeak = linkTycon("Weak");
297 #ifdef PROVIDE_FOREIGN
298 typeForeign = linkTycon("ForeignObj");
300 #ifdef PROVIDE_CONCURRENT
301 typeThreadId = linkTycon("ThreadId");
302 typeMVar = linkTycon("MVar");
305 typeBool = linkTycon("Bool");
306 typeST = linkTycon("ST");
307 typeIO = linkTycon("IO");
308 typeException = linkTycon("Exception");
309 typeString = linkTycon("String");
310 typeOrdering = linkTycon("Ordering");
312 classEq = linkClass("Eq");
313 classOrd = linkClass("Ord");
314 classIx = linkClass("Ix");
315 classEnum = linkClass("Enum");
316 classShow = linkClass("Show");
317 classRead = linkClass("Read");
318 classBounded = linkClass("Bounded");
319 classReal = linkClass("Real");
320 classIntegral = linkClass("Integral");
321 classRealFrac = linkClass("RealFrac");
322 classRealFloat = linkClass("RealFloat");
323 classFractional = linkClass("Fractional");
324 classFloating = linkClass("Floating");
325 classNum = linkClass("Num");
326 classMonad = linkClass("Monad");
329 stdDefaults = cons(typeDouble,stdDefaults);
331 stdDefaults = cons(typeInteger,stdDefaults);
333 stdDefaults = cons(typeInt,stdDefaults);
337 nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
338 nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
339 nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
340 nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
341 nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
342 nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
343 nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
344 nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
345 #ifdef PROVIDE_FOREIGN
346 nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
349 nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
351 nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
352 nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
353 nameMkRef = addPrimCfunREP(findText("Ref#"),1,0,0);
354 nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
355 nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
356 #ifdef PROVIDE_CONCURRENT
357 nameMkThreadId = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
358 nameMkMVar = addPrimCfun(findTextREP("MVar#"),1,0,0);
360 /* The following primitives are referred to in derived instances and
361 * hence require types; the following types are a little more general
362 * than we might like, but they are the closest we can get without a
363 * special datatype class.
365 name(nameConCmp).type
366 = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
367 name(nameEnRange).type
368 = mkPolyType(starToStar,fn(boundPair,listof));
369 name(nameEnIndex).type
370 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
371 name(nameEnInRng).type
372 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
373 name(nameEnToEn).type
374 = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
375 name(nameEnFrEn).type
376 = mkPolyType(starToStar,fn(aVar,typeInt));
377 name(nameEnFrom).type
378 = mkPolyType(starToStar,fn(aVar,listof));
379 name(nameEnFrTo).type
380 = name(nameEnFrTh).type
381 = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
383 name(namePrimSeq).type
384 = primType(MONAD_Id, "ab", "b");
385 name(namePrimCatch).type
386 = primType(MONAD_Id, "aH", "a");
387 name(namePrimRaise).type
388 = primType(MONAD_Id, "E", "a");
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);
401 static Void mkTypes ( void )
403 predNum = ap(classNum,aVar);
404 predFractional = ap(classFractional,aVar);
405 predIntegral = ap(classIntegral,aVar);
406 predMonad = ap(classMonad,aVar);
409 Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
410 static Bool initialised = FALSE; /* prelude when first loaded */
415 setCurrModule(modulePrelude);
418 nameFalse = linkName("False");
419 nameTrue = linkName("True");
422 nameEq = linkName("==");
423 nameFromInt = linkName("fromInt");
424 nameFromInteger = linkName("fromInteger");
425 nameFromDouble = linkName("fromDouble");
426 nameReturn = linkName("return");
427 nameBind = linkName(">>=");
428 nameLe = linkName("<=");
429 nameGt = linkName(">");
430 nameShowsPrec = linkName("showsPrec");
431 nameReadsPrec = linkName("readsPrec");
432 nameEQ = linkName("EQ");
433 nameCompare = linkName("compare");
434 nameMinBnd = linkName("minBound");
435 nameMaxBnd = linkName("maxBound");
436 nameRange = linkName("range");
437 nameIndex = linkName("index");
438 namePlus = linkName("+");
439 nameMult = linkName("*");
440 nameRangeSize = linkName("rangeSize");
441 nameInRange = linkName("inRange");
442 nameMinus = linkName("-");
443 /* These come before calls to implementPrim */
444 for(i=0; i<NUM_TUPLES; ++i) {
450 Void linkPreludeNames(void) { /* Hook to names defined in Prelude */
451 static Bool initialised = FALSE;
456 setCurrModule(modulePrelude);
459 nameMkIO = linkName("primMkIO");
460 for (i=0; asmPrimOps[i].name; ++i) {
461 Text t = findText(asmPrimOps[i].name);
462 Name n = findName(t);
468 name(n).type = primType(asmPrimOps[i].monad,
470 asmPrimOps[i].results);
471 name(n).arity = strlen(asmPrimOps[i].args);
472 name(n).primop = &(asmPrimOps[i]);
476 nameRunST = linkName("primRunST");
478 /* static(tidyInfix) */
479 nameNegate = linkName("negate");
481 nameRunIO = linkName("primRunIO");
482 namePrint = linkName("print");
484 nameOtherwise = linkName("otherwise");
485 nameUndefined = linkName("undefined");
488 namePmSub = linkName("primPmSub");
491 nameEqChar = linkName("primEqChar");
492 nameEqInt = linkName("primEqInt");
493 nameCreateAdjThunk = linkName("primCreateAdjThunk");
494 #if !OVERLOADED_CONSTANTS
495 nameEqInteger = linkName("primEqInteger");
496 #endif /* !OVERLOADED_CONSTANTS */
497 nameEqDouble = linkName("primEqDouble");
498 namePmInt = linkName("primPmInt");
499 name(namePmInt).inlineMe = TRUE;
504 /* ToDo: fix pFun (or eliminate its use) */
505 #define pFun(n,s) n = predefinePrim(s)
507 Void linkControl(what)
514 case INSTALL : linkControl(RESET);
516 modulePrelude = newModule(textPrelude);
517 setCurrModule(modulePrelude);
519 typeArrow = addPrimTycon(findText("(->)"),
520 pair(STAR,pair(STAR,STAR)),
523 /* newtype and USE_NEWTYPE_FOR_DICTS */
527 pFun(nameInd, "_indirect");
528 name(nameInd).number = DFUNNAME;
531 pFun(nameSel, "_SEL");
533 /* strict constructors */
534 pFun(nameFlip, "flip" );
537 pFun(nameFromTo, "enumFromTo");
538 pFun(nameFromThenTo, "enumFromThenTo");
539 pFun(nameFrom, "enumFrom");
540 pFun(nameFromThen, "enumFromThen");
544 pFun(nameReadField, "readField");
545 pFun(nameReadParen, "readParen");
546 pFun(nameShowField, "showField");
547 pFun(nameShowParen, "showParen");
548 pFun(nameLex, "lex");
549 pFun(nameEnToEn, "toEnumPR"); //not sure
550 pFun(nameEnFrEn, "fromEnum"); //not sure
551 pFun(nameEnFrom, "enumFrom"); //not sure
552 pFun(nameEnFrTh, "enumFromThen"); //not sure
553 pFun(nameEnFrTo, "enumFromTo"); //not sure
554 pFun(nameEnRange, "range"); //not sure
555 pFun(nameEnIndex, "index"); //not sure
556 pFun(nameEnInRng, "inRange"); //not sure
557 pFun(nameConCmp, "_concmp"); //very not sure
560 pFun(nameCompAux, "primCompAux");
561 name(nameCompAux).inlineMe = TRUE;
562 pFun(nameMap, "map");
564 /* implementTagToCon */
565 pFun(namePMFail, "primPmFail");
566 pFun(nameError, "error");
567 pFun(nameUnpackString, "primUnpackString");
569 // /* foreign export dynamic */
570 //pFun(nameCreateAdjThunk, "primCreateAdjThunk");
572 /* hooks for handwritten bytecode */
573 pFun(namePrimSeq, "primSeq");
574 pFun(namePrimCatch, "primCatch");
575 pFun(namePrimRaise, "primRaise");
577 StgVar vv = mkStgVar(NIL,NIL);
578 Name n = namePrimSeq;
582 vv = mkStgVar(NIL,NIL);
583 stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
585 stgGlobals=cons(pair(n,vv),stgGlobals);
589 StgVar vv = mkStgVar(NIL,NIL);
590 Name n = namePrimCatch;
594 stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
596 stgGlobals=cons(pair(n,vv),stgGlobals);
599 StgVar vv = mkStgVar(NIL,NIL);
600 Name n = namePrimRaise;
604 stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
606 stgGlobals=cons(pair(n,vv),stgGlobals);
615 /*-------------------------------------------------------------------------*/