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/12 17:32:40 $
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 */
111 Name namePmFromInteger;
114 Name nameUnpackString;
117 Name nameCreateAdjThunk;
150 /* these names are required before we've had a chance to do the right thing */
152 Name nameUnsafeUnpackCString;
154 /* constructors used during translation and codegen */
155 Name nameMkC; /* Char# -> Char */
156 Name nameMkI; /* Int# -> Int */
157 Name nameMkInteger; /* Integer# -> Integer */
158 Name nameMkW; /* Word# -> Word */
159 Name nameMkA; /* Addr# -> Addr */
160 Name nameMkF; /* Float# -> Float */
161 Name nameMkD; /* Double# -> Double */
162 Name nameMkPrimArray;
163 Name nameMkPrimByteArray;
165 Name nameMkPrimMutableArray;
166 Name nameMkPrimMutableByteArray;
167 Name nameMkStable; /* StablePtr# a -> StablePtr a */
169 Name nameMkWeak; /* Weak# a -> Weak a */
171 #ifdef PROVIDE_FOREIGN
172 Name nameMkForeign; /* ForeignObj# -> ForeignObj */
174 #ifdef PROVIDE_CONCURRENT
175 Name nameMkThreadId; /* ThreadId# -> ThreadId */
176 Name nameMkMVar; /* MVar# -> MVar */
196 Module modulePrelude;
201 /* --------------------------------------------------------------------------
202 * Frequently used type skeletons:
203 * ------------------------------------------------------------------------*/
205 Type arrow; /* mkOffset(0) -> mkOffset(1) */
206 Type boundPair; /* (mkOffset(0),mkOffset(0)) */
207 Type listof; /* [ mkOffset(0) ] */
208 Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
210 Cell predNum; /* Num (mkOffset(0)) */
211 Cell predFractional; /* Fractional (mkOffset(0)) */
212 Cell predIntegral; /* Integral (mkOffset(0)) */
213 Kind starToStar; /* Type -> Type */
214 Cell predMonad; /* Monad (mkOffset(0)) */
216 /* --------------------------------------------------------------------------
218 * ------------------------------------------------------------------------*/
220 static Tycon linkTycon ( String s );
221 static Tycon linkClass ( String s );
222 static Name linkName ( String s );
223 static Void mkTypes ( void );
224 static Name predefinePrim ( String s );
227 static Tycon linkTycon( String s )
229 Tycon tc = findTycon(findText(s));
233 ERRMSG(0) "Prelude does not define standard type \"%s\"", s
237 static Class linkClass( String s )
239 Class cc = findClass(findText(s));
243 ERRMSG(0) "Prelude does not define standard class \"%s\"", s
247 static Name linkName( String s )
249 Name n = findName(findText(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;
271 Void linkPreludeTC(void) { /* Hook to tycons and classes in */
272 static Bool initialised = FALSE; /* prelude when first loaded */
276 setCurrModule(modulePrelude);
278 typeChar = linkTycon("Char");
279 typeInt = linkTycon("Int");
280 typeInteger = linkTycon("Integer");
281 typeWord = linkTycon("Word");
282 typeAddr = linkTycon("Addr");
283 typePrimArray = linkTycon("PrimArray");
284 typePrimByteArray = linkTycon("PrimByteArray");
285 typeRef = linkTycon("Ref");
286 typePrimMutableArray = linkTycon("PrimMutableArray");
287 typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
288 typeFloat = linkTycon("Float");
289 typeDouble = linkTycon("Double");
290 typeStable = linkTycon("StablePtr");
292 typeWeak = linkTycon("Weak");
294 #ifdef PROVIDE_FOREIGN
295 typeForeign = linkTycon("ForeignObj");
297 #ifdef PROVIDE_CONCURRENT
298 typeThreadId = linkTycon("ThreadId");
299 typeMVar = linkTycon("MVar");
302 typeBool = linkTycon("Bool");
303 typeST = linkTycon("ST");
304 typeIO = linkTycon("IO");
305 typeException = linkTycon("Exception");
306 typeString = linkTycon("String");
307 typeOrdering = linkTycon("Ordering");
309 classEq = linkClass("Eq");
310 classOrd = linkClass("Ord");
311 classIx = linkClass("Ix");
312 classEnum = linkClass("Enum");
313 classShow = linkClass("Show");
314 classRead = linkClass("Read");
315 classBounded = linkClass("Bounded");
316 classReal = linkClass("Real");
317 classIntegral = linkClass("Integral");
318 classRealFrac = linkClass("RealFrac");
319 classRealFloat = linkClass("RealFloat");
320 classFractional = linkClass("Fractional");
321 classFloating = linkClass("Floating");
322 classNum = linkClass("Num");
323 classMonad = linkClass("Monad");
326 stdDefaults = cons(typeDouble,stdDefaults);
328 stdDefaults = cons(typeInteger,stdDefaults);
330 stdDefaults = cons(typeInt,stdDefaults);
334 nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
335 nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
336 nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
337 nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
338 nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
339 nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
340 nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
341 nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
342 #ifdef PROVIDE_FOREIGN
343 nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
346 nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
348 nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
349 nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
350 nameMkRef = addPrimCfunREP(findText("Ref#"),1,0,0);
351 nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
352 nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
353 #ifdef PROVIDE_CONCURRENT
354 nameMkThreadId = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
355 nameMkMVar = addPrimCfun(findTextREP("MVar#"),1,0,0);
357 /* The following primitives are referred to in derived instances and
358 * hence require types; the following types are a little more general
359 * than we might like, but they are the closest we can get without a
360 * special datatype class.
362 name(nameConCmp).type
363 = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
364 name(nameEnRange).type
365 = mkPolyType(starToStar,fn(boundPair,listof));
366 name(nameEnIndex).type
367 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
368 name(nameEnInRng).type
369 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
370 name(nameEnToEn).type
371 = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
372 name(nameEnFrEn).type
373 = mkPolyType(starToStar,fn(aVar,typeInt));
374 name(nameEnFrom).type
375 = mkPolyType(starToStar,fn(aVar,listof));
376 name(nameEnFrTo).type
377 = name(nameEnFrTh).type
378 = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
380 name(namePrimSeq).type
381 = primType(MONAD_Id, "ab", "b");
382 name(namePrimCatch).type
383 = primType(MONAD_Id, "aH", "a");
384 name(namePrimRaise).type
385 = primType(MONAD_Id, "E", "a");
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");
568 StgVar vv = mkStgVar(NIL,NIL);
569 Name n = namePrimSeq;
573 vv = mkStgVar(NIL,NIL);
574 stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
576 stgGlobals=cons(pair(n,vv),stgGlobals);
580 StgVar vv = mkStgVar(NIL,NIL);
581 Name n = namePrimCatch;
585 stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
587 stgGlobals=cons(pair(n,vv),stgGlobals);
590 StgVar vv = mkStgVar(NIL,NIL);
591 Name n = namePrimRaise;
595 stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
597 stgGlobals=cons(pair(n,vv),stgGlobals);
606 /*-------------------------------------------------------------------------*/