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/18 12:10:19 $
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)) */
213 /* --------------------------------------------------------------------------
215 * ------------------------------------------------------------------------*/
217 static Tycon linkTycon ( String s );
218 static Tycon linkClass ( String s );
219 static Name linkName ( String s );
220 static Void mkTypes ( void );
221 static Name predefinePrim ( String s );
224 static Tycon linkTycon( String s )
226 Tycon tc = findTycon(findText(s));
230 ERRMSG(0) "Prelude does not define standard type \"%s\"", s
234 static Class linkClass( String s )
236 Class cc = findClass(findText(s));
240 ERRMSG(0) "Prelude does not define standard class \"%s\"", s
244 static Name linkName( String s )
246 Name n = findName(findText(s));
250 ERRMSG(0) "Prelude does not define standard name \"%s\"", s
254 static Name predefinePrim ( String s )
257 Text t = findText(s);
260 //fprintf(stderr, "predefinePrim: %s already exists\n", s );
263 name(nm).defn=PREDEFINED;
268 Void linkPreludeTC(void) { /* Hook to tycons and classes in */
269 static Bool initialised = FALSE; /* prelude when first loaded */
273 setCurrModule(modulePrelude);
275 typeChar = linkTycon("Char");
276 typeInt = linkTycon("Int");
277 typeInteger = linkTycon("Integer");
278 typeWord = linkTycon("Word");
279 typeAddr = linkTycon("Addr");
280 typePrimArray = linkTycon("PrimArray");
281 typePrimByteArray = linkTycon("PrimByteArray");
282 typeRef = linkTycon("Ref");
283 typePrimMutableArray = linkTycon("PrimMutableArray");
284 typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
285 typeFloat = linkTycon("Float");
286 typeDouble = linkTycon("Double");
287 typeStable = linkTycon("StablePtr");
289 typeWeak = linkTycon("Weak");
291 #ifdef PROVIDE_FOREIGN
292 typeForeign = linkTycon("ForeignObj");
294 typeThreadId = linkTycon("ThreadId");
295 typeMVar = linkTycon("MVar");
296 typeBool = linkTycon("Bool");
297 typeST = linkTycon("ST");
298 typeIO = linkTycon("IO");
299 typeException = linkTycon("Exception");
300 typeString = linkTycon("String");
301 typeOrdering = linkTycon("Ordering");
303 classEq = linkClass("Eq");
304 classOrd = linkClass("Ord");
305 classIx = linkClass("Ix");
306 classEnum = linkClass("Enum");
307 classShow = linkClass("Show");
308 classRead = linkClass("Read");
309 classBounded = linkClass("Bounded");
310 classReal = linkClass("Real");
311 classIntegral = linkClass("Integral");
312 classRealFrac = linkClass("RealFrac");
313 classRealFloat = linkClass("RealFloat");
314 classFractional = linkClass("Fractional");
315 classFloating = linkClass("Floating");
316 classNum = linkClass("Num");
317 classMonad = linkClass("Monad");
320 stdDefaults = cons(typeDouble,stdDefaults);
322 stdDefaults = cons(typeInteger,stdDefaults);
324 stdDefaults = cons(typeInt,stdDefaults);
328 nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
329 nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
330 nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
331 nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
332 nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
333 nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
334 nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
335 nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
337 #ifdef PROVIDE_FOREIGN
338 nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
341 nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
343 nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
344 nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
345 nameMkRef = addPrimCfunREP(findText("Ref#"),1,0,0);
346 nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
347 nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
348 nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
349 nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
351 /* The following primitives are referred to in derived instances and
352 * hence require types; the following types are a little more general
353 * than we might like, but they are the closest we can get without a
354 * special datatype class.
356 name(nameConCmp).type
357 = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
358 name(nameEnRange).type
359 = mkPolyType(starToStar,fn(boundPair,listof));
360 name(nameEnIndex).type
361 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
362 name(nameEnInRng).type
363 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
364 name(nameEnToEn).type
365 = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
366 name(nameEnFrEn).type
367 = mkPolyType(starToStar,fn(aVar,typeInt));
368 name(nameEnFrom).type
369 = mkPolyType(starToStar,fn(aVar,listof));
370 name(nameEnFrTo).type
371 = name(nameEnFrTh).type
372 = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
374 name(namePrimSeq).type
375 = primType(MONAD_Id, "ab", "b");
376 name(namePrimCatch).type
377 = primType(MONAD_Id, "aH", "a");
378 name(namePrimRaise).type
379 = 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
385 = 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);
398 static Void mkTypes ( void )
400 predNum = ap(classNum,aVar);
401 predFractional = ap(classFractional,aVar);
402 predIntegral = ap(classIntegral,aVar);
403 predMonad = ap(classMonad,aVar);
406 Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
407 static Bool initialised = FALSE; /* prelude when first loaded */
412 setCurrModule(modulePrelude);
415 nameFalse = linkName("False");
416 nameTrue = linkName("True");
419 nameEq = linkName("==");
420 nameFromInt = linkName("fromInt");
421 nameFromInteger = linkName("fromInteger");
422 nameFromDouble = linkName("fromDouble");
423 nameReturn = linkName("return");
424 nameBind = linkName(">>=");
425 nameLe = linkName("<=");
426 nameGt = linkName(">");
427 nameShowsPrec = linkName("showsPrec");
428 nameReadsPrec = linkName("readsPrec");
429 nameEQ = linkName("EQ");
430 nameCompare = linkName("compare");
431 nameMinBnd = linkName("minBound");
432 nameMaxBnd = linkName("maxBound");
433 nameRange = linkName("range");
434 nameIndex = linkName("index");
435 namePlus = linkName("+");
436 nameMult = linkName("*");
437 nameRangeSize = linkName("rangeSize");
438 nameInRange = linkName("inRange");
439 nameMinus = linkName("-");
440 /* These come before calls to implementPrim */
441 for(i=0; i<NUM_TUPLES; ++i) {
447 Void linkPreludeNames(void) { /* Hook to names defined in Prelude */
448 static Bool initialised = FALSE;
453 setCurrModule(modulePrelude);
456 nameMkIO = linkName("primMkIO");
457 for (i=0; asmPrimOps[i].name; ++i) {
458 Text t = findText(asmPrimOps[i].name);
459 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]);
473 nameRunST = linkName("primRunST");
475 /* static(tidyInfix) */
476 nameNegate = linkName("negate");
478 nameRunIO = linkName("primRunIO");
479 namePrint = linkName("print");
481 nameOtherwise = linkName("otherwise");
482 nameUndefined = linkName("undefined");
485 namePmSub = linkName("primPmSub");
488 nameEqChar = linkName("primEqChar");
489 nameEqInt = linkName("primEqInt");
490 nameCreateAdjThunk = linkName("primCreateAdjThunk");
491 nameEqDouble = linkName("primEqDouble");
492 namePmInt = linkName("primPmInt");
493 namePmInteger = linkName("primPmInteger");
494 namePmDouble = linkName("primPmDouble");
499 /* ToDo: fix pFun (or eliminate its use) */
500 #define pFun(n,s) n = predefinePrim(s)
502 Void linkControl(what)
509 case INSTALL : linkControl(RESET);
511 modulePrelude = newModule(textPrelude);
512 setCurrModule(modulePrelude);
514 typeArrow = addPrimTycon(findText("(->)"),
515 pair(STAR,pair(STAR,STAR)),
518 /* newtype and USE_NEWTYPE_FOR_DICTS */
522 pFun(nameInd, "_indirect");
523 name(nameInd).number = DFUNNAME;
526 pFun(nameSel, "_SEL");
528 /* strict constructors */
529 pFun(nameFlip, "flip" );
532 pFun(nameFromTo, "enumFromTo");
533 pFun(nameFromThenTo, "enumFromThenTo");
534 pFun(nameFrom, "enumFrom");
535 pFun(nameFromThen, "enumFromThen");
539 pFun(nameReadField, "readField");
540 pFun(nameReadParen, "readParen");
541 pFun(nameShowField, "showField");
542 pFun(nameShowParen, "showParen");
543 pFun(nameLex, "lex");
544 pFun(nameEnToEn, "toEnumPR"); //not sure
545 pFun(nameEnFrEn, "fromEnum"); //not sure
546 pFun(nameEnFrom, "enumFrom"); //not sure
547 pFun(nameEnFrTh, "enumFromThen"); //not sure
548 pFun(nameEnFrTo, "enumFromTo"); //not sure
549 pFun(nameEnRange, "range"); //not sure
550 pFun(nameEnIndex, "index"); //not sure
551 pFun(nameEnInRng, "inRange"); //not sure
552 pFun(nameConCmp, "_concmp"); //very not sure
555 pFun(nameCompAux, "primCompAux");
556 pFun(nameMap, "map");
558 /* implementTagToCon */
559 pFun(namePMFail, "primPmFail");
560 pFun(nameError, "error");
561 pFun(nameUnpackString, "primUnpackString");
563 /* hooks for handwritten bytecode */
564 pFun(namePrimSeq, "primSeq");
565 pFun(namePrimCatch, "primCatch");
566 pFun(namePrimRaise, "primRaise");
567 pFun(namePrimTakeMVar, "primTakeMVar");
569 StgVar vv = mkStgVar(NIL,NIL);
570 Name n = namePrimSeq;
574 vv = mkStgVar(NIL,NIL);
575 stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
577 stgGlobals=cons(pair(n,vv),stgGlobals);
581 StgVar vv = mkStgVar(NIL,NIL);
582 Name n = namePrimCatch;
586 stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
588 stgGlobals=cons(pair(n,vv),stgGlobals);
591 StgVar vv = mkStgVar(NIL,NIL);
592 Name n = namePrimRaise;
596 stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
598 stgGlobals=cons(pair(n,vv),stgGlobals);
601 StgVar vv = mkStgVar(NIL,NIL);
602 Name n = namePrimTakeMVar;
606 stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
608 stgGlobals=cons(pair(n,vv),stgGlobals);
616 /*-------------------------------------------------------------------------*/