2 /* --------------------------------------------------------------------------
3 * Load symbols required from the Prelude
5 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
6 * All rights reserved. See NOTICE for details and conditions of use etc...
7 * Hugs version 1.4, December 1997
11 * $Date: 1999/03/01 14:46:47 $
12 * ------------------------------------------------------------------------*/
19 #include "Assembler.h" /* for asmPrimOps and AsmReps */
23 ////Module modulePreludeHugs;
26 Type typeArrow =BOGUS(1); /* Function spaces */
28 Type typeChar =BOGUS(2);
29 Type typeInt =BOGUS(3);
31 Type typeInt64 =BOGUS(4);
33 #ifdef PROVIDE_INTEGER
34 Type typeInteger =BOGUS(5);
37 Type typeWord =BOGUS(6);
40 Type typeAddr =BOGUS(7);
43 Type typePrimArray =BOGUS(8);
44 Type typePrimByteArray =BOGUS(9);
45 Type typeRef =BOGUS(10);
46 Type typePrimMutableArray =BOGUS(11);
47 Type typePrimMutableByteArray =BOGUS(12);
49 Type typeFloat =BOGUS(13);
50 Type typeDouble =BOGUS(14);
52 Type typeStable =BOGUS(15);
55 Type typeWeak =BOGUS(16);
57 #ifdef PROVIDE_FOREIGN
58 Type typeForeign =BOGUS(17);
60 #ifdef PROVIDE_CONCURRENT
61 Type typeThreadId =BOGUS(18);
62 Type typeMVar =BOGUS(19);
65 Type typeList =BOGUS(20);
66 Type typeUnit =BOGUS(21);
67 Type typeString =BOGUS(22);
68 Type typeBool =BOGUS(23);
69 Type typeST =BOGUS(24);
70 Type typeIO =BOGUS(25);
71 Type typeException =BOGUS(26);
73 Class classEq =BOGUS(27); /* `standard' classes */
74 Class classOrd =BOGUS(28);
75 Class classShow =BOGUS(29);
76 Class classRead =BOGUS(30);
77 Class classIx =BOGUS(31);
78 Class classEnum =BOGUS(32);
79 Class classBounded =BOGUS(33);
81 Class classEval =BOGUS(34);
84 Class classReal =BOGUS(35); /* `numeric' classes */
85 Class classIntegral =BOGUS(36);
86 Class classRealFrac =BOGUS(37);
87 Class classRealFloat =BOGUS(38);
88 Class classFractional =BOGUS(39);
89 Class classFloating =BOGUS(40);
90 Class classNum =BOGUS(41);
92 Class classMonad =BOGUS(42); /* Monads and monads with a zero */
93 /*Class classMonad0 =BOGUS();*/
95 List stdDefaults =BOGUS(43); /* standard default values */
97 Name nameTrue =BOGUS(44),
98 nameFalse =BOGUS(45); /* primitive boolean constructors */
99 Name nameNil =BOGUS(46),
100 nameCons =BOGUS(47); /* primitive list constructors */
101 Name nameUnit =BOGUS(48); /* primitive Unit type constructor */
103 Name nameEq =BOGUS(49);
104 Name nameFromInt =BOGUS(50),
105 nameFromDouble =BOGUS(51); /* coercion of numerics */
106 Name nameFromInteger =BOGUS(52);
107 Name nameReturn =BOGUS(53),
108 nameBind =BOGUS(54); /* for translating monad comps */
109 Name nameZero =BOGUS(55); /* for monads with a zero */
111 Name nameStrict =BOGUS(56); /* Members of class Eval */
112 Name nameSeq =BOGUS(57);
115 Name nameId =BOGUS(58);
116 Name nameRunIO =BOGUS(59);
117 Name namePrint =BOGUS(60);
119 Name nameOtherwise =BOGUS(61);
120 Name nameUndefined =BOGUS(62); /* generic undefined value */
122 Name namePmSub =BOGUS(63);
124 Name namePMFail =BOGUS(64);
125 Name nameEqChar =BOGUS(65);
126 Name nameEqInt =BOGUS(66);
127 #if !OVERLOADED_CONSTANTS
128 Name nameEqInteger =BOGUS(67);
130 Name nameEqDouble =BOGUS(68);
131 Name namePmInt =BOGUS(69);
132 Name namePmInteger =BOGUS(70);
133 Name namePmDouble =BOGUS(71);
134 Name namePmLe =BOGUS(72);
135 Name namePmSubtract =BOGUS(73);
136 Name namePmFromInteger =BOGUS(74);
137 Name nameMkIO =BOGUS(75);
138 Name nameUnpackString =BOGUS(76);
139 Name nameError =BOGUS(77);
140 Name nameInd =BOGUS(78);
142 Name nameForce =BOGUS(79);
144 Name nameAnd =BOGUS(80);
145 Name nameConCmp =BOGUS(82);
146 Name nameCompAux =BOGUS(83);
147 Name nameEnFrTh =BOGUS(84);
148 Name nameEnFrTo =BOGUS(85);
149 Name nameEnFrom =BOGUS(86);
150 Name nameEnFrEn =BOGUS(87);
151 Name nameEnToEn =BOGUS(88);
152 Name nameEnInRng =BOGUS(89);
153 Name nameEnIndex =BOGUS(90);
154 Name nameEnRange =BOGUS(91);
155 Name nameRangeSize =BOGUS(92);
156 Name nameComp =BOGUS(93);
157 Name nameShowField =BOGUS(94);
158 Name nameApp =BOGUS(95);
159 Name nameShowParen =BOGUS(96);
160 Name nameReadParen =BOGUS(97);
161 Name nameLex =BOGUS(98);
162 Name nameReadField =BOGUS(99);
163 Name nameFlip =BOGUS(100);
164 Name nameFromTo =BOGUS(101);
165 Name nameFromThen =BOGUS(102);
166 Name nameFrom =BOGUS(103);
167 Name nameFromThenTo =BOGUS(104);
168 Name nameNegate =BOGUS(105);
170 /* these names are required before we've had a chance to do the right thing */
171 Name nameSel =BOGUS(106);
172 Name nameUnsafeUnpackCString =BOGUS(107);
174 /* constructors used during translation and codegen */
175 Name nameMkC =BOGUS(108); /* Char# -> Char */
176 Name nameMkI =BOGUS(109); /* Int# -> Int */
178 Name nameMkInt64 =BOGUS(110); /* Int64# -> Int64 */
180 #ifdef PROVIDE_INTEGER
181 Name nameMkInteger =BOGUS(111); /* Integer# -> Integer */
184 Name nameMkW =BOGUS(112); /* Word# -> Word */
187 Name nameMkA =BOGUS(113); /* Addr# -> Addr */
189 Name nameMkF =BOGUS(114); /* Float# -> Float */
190 Name nameMkD =BOGUS(115); /* Double# -> Double */
192 Name nameMkPrimArray =BOGUS(116);
193 Name nameMkPrimByteArray =BOGUS(117);
194 Name nameMkRef =BOGUS(118);
195 Name nameMkPrimMutableArray =BOGUS(119);
196 Name nameMkPrimMutableByteArray =BOGUS(120);
198 #ifdef PROVIDE_STABLE
199 Name nameMkStable =BOGUS(121); /* StablePtr# a -> StablePtr a */
202 Name nameMkWeak =BOGUS(122); /* Weak# a -> Weak a */
204 #ifdef PROVIDE_FOREIGN
205 Name nameMkForeign =BOGUS(123); /* ForeignObj# -> ForeignObj */
207 #ifdef PROVIDE_CONCURRENT
208 Name nameMkThreadId =BOGUS(124); /* ThreadId# -> ThreadId */
209 Name nameMkMVar =BOGUS(125); /* MVar# -> MVar */
214 Name nameMinBnd =BOGUS(400);
215 Name nameMaxBnd =BOGUS(401);
216 Name nameCompare =BOGUS(402);
217 Name nameShowsPrec =BOGUS(403);
218 Name nameIndex =BOGUS(404);
219 Name nameReadsPrec =BOGUS(405);
220 Name nameRange =BOGUS(406);
221 Name nameEQ =BOGUS(407);
222 Name nameInRange =BOGUS(408);
223 Name nameGt =BOGUS(409);
224 Name nameLe =BOGUS(410);
225 Name namePlus =BOGUS(411);
226 Name nameMult =BOGUS(412);
227 Name nameMFail =BOGUS(413);
228 Type typeOrdering =BOGUS(414);
229 Module modulePrelude =BOGUS(415);
231 #define QQ(lval) assert(lval != 0); assert(lval <= -900000); lval
233 /* --------------------------------------------------------------------------
234 * Frequently used type skeletons:
235 * ------------------------------------------------------------------------*/
237 /* ToDo: move these to link.c and call them 'typeXXXX' */
238 Type arrow=BOGUS(500); /* mkOffset(0) -> mkOffset(1) */
239 Type boundPair=BOGUS(500);; /* (mkOffset(0),mkOffset(0)) */
240 Type listof=BOGUS(500);; /* [ mkOffset(0) ] */
241 Type typeVarToVar=BOGUS(500);; /* mkOffset(0) -> mkOffset(0) */
243 Cell predNum=BOGUS(500);; /* Num (mkOffset(0)) */
244 Cell predFractional=BOGUS(500);; /* Fractional (mkOffset(0)) */
245 Cell predIntegral=BOGUS(500);; /* Integral (mkOffset(0)) */
246 Kind starToStar=BOGUS(500);; /* Type -> Type */
247 Cell predMonad=BOGUS(500);; /* Monad (mkOffset(0)) */
249 /* --------------------------------------------------------------------------
251 * ------------------------------------------------------------------------*/
253 static Tycon linkTycon ( String s );
254 static Tycon linkClass ( String s );
255 static Name linkName ( String s );
256 static Void mkTypes ( void );
259 static Tycon linkTycon( String s )
261 Tycon tc = findTycon(findText(s));
265 ERRMSG(0) "Prelude does not define standard type \"%s\"", s
269 static Class linkClass( String s )
271 Class cc = findClass(findText(s));
275 ERRMSG(0) "Prelude does not define standard class \"%s\"", s
279 static Name linkName( String s )
281 Name n = findName(findText(s));
285 ERRMSG(0) "Prelude does not define standard name \"%s\"", s
289 /* ToDo: kill this! */
290 static Name predefinePrim ( String s );
291 static Name predefinePrim ( String s )
293 Name nm = newName(findText(s),NIL);
294 name(nm).defn=PREDEFINED;
298 Void linkPreludeTC(void) { /* Hook to tycons and classes in */
299 static Bool initialised = FALSE; /* prelude when first loaded */
303 ////setCurrModule(modulePreludeHugs);
304 setCurrModule(modulePrelude);
306 QQ(typeChar ) = linkTycon("Char");
307 QQ(typeInt ) = linkTycon("Int");
309 QQ(typeInt64 ) = linkTycon("Int64");
311 #ifdef PROVIDE_INTEGER
312 QQ(typeInteger ) = linkTycon("Integer");
315 QQ(typeWord ) = linkTycon("Word");
318 QQ(typeAddr ) = linkTycon("Addr");
321 QQ(typePrimArray ) = linkTycon("PrimArray");
322 QQ(typePrimByteArray) = linkTycon("PrimByteArray");
323 QQ(typeRef ) = linkTycon("Ref");
324 QQ(typePrimMutableArray) = linkTycon("PrimMutableArray");
325 QQ(typePrimMutableByteArray) = linkTycon("PrimMutableByteArray");
327 QQ(typeFloat ) = linkTycon("Float");
328 QQ(typeDouble ) = linkTycon("Double");
329 #ifdef PROVIDE_STABLE
330 QQ(typeStable ) = linkTycon("StablePtr");
333 QQ(typeWeak ) = linkTycon("Weak");
335 #ifdef PROVIDE_FOREIGN
336 QQ(typeForeign ) = linkTycon("ForeignObj");
338 #ifdef PROVIDE_CONCURRENT
339 QQ(typeThreadId ) = linkTycon("ThreadId");
340 QQ(typeMVar ) = linkTycon("MVar");
343 QQ(typeBool ) = linkTycon("Bool");
344 QQ(typeST ) = linkTycon("ST");
345 QQ(typeIO ) = linkTycon("IO");
346 QQ(typeException ) = linkTycon("Exception");
347 //qqfail QQ(typeList ) = linkTycon("[]");
348 //qqfail QQ(typeUnit ) = linkTycon("()");
349 QQ(typeString ) = linkTycon("String");
350 QQ(typeOrdering ) = linkTycon("Ordering");
352 QQ(classEq ) = linkClass("Eq");
353 QQ(classOrd ) = linkClass("Ord");
354 QQ(classIx ) = linkClass("Ix");
355 QQ(classEnum ) = linkClass("Enum");
356 QQ(classShow ) = linkClass("Show");
357 QQ(classRead ) = linkClass("Read");
358 QQ(classBounded ) = linkClass("Bounded");
360 classEval = linkClass("Eval");
362 QQ(classReal ) = linkClass("Real");
363 QQ(classIntegral ) = linkClass("Integral");
364 QQ(classRealFrac ) = linkClass("RealFrac");
365 QQ(classRealFloat) = linkClass("RealFloat");
366 QQ(classFractional) = linkClass("Fractional");
367 QQ(classFloating ) = linkClass("Floating");
368 QQ(classNum ) = linkClass("Num");
369 QQ(classMonad ) = linkClass("Monad");
372 stdDefaults = cons(typeDouble,stdDefaults);
374 stdDefaults = cons(typeBignum,stdDefaults);
376 stdDefaults = cons(typeInt,stdDefaults);
380 QQ(nameMkC ) = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
381 QQ(nameMkI ) = addPrimCfunREP(findText("I#"),1,0,INT_REP);
383 QQ(nameMkInt64 ) = addPrimCfunREP(findText("Int64#"),1,0,INT64_REP);
386 QQ(nameMkW ) = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
389 QQ(nameMkA ) = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
391 QQ(nameMkF ) = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
392 QQ(nameMkD ) = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
393 #ifdef PROVIDE_STABLE
394 QQ(nameMkStable ) = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
397 #ifdef PROVIDE_INTEGER
398 QQ(nameMkInteger ) = addPrimCfunREP(findText("Integer#"),1,0,0);
400 #ifdef PROVIDE_FOREIGN
401 QQ(nameMkForeign ) = addPrimCfunREP(findText("Foreign#"),1,0,0);
404 QQ(nameMkWeak ) = addPrimCfunREP(findText("Weak#"),1,0,0);
407 QQ(nameMkPrimArray ) = addPrimCfunREP(findText("PrimArray#"),1,0,0);
408 QQ(nameMkPrimByteArray ) = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
409 QQ(nameMkRef ) = addPrimCfunREP(findText("Ref#"),1,0,0);
410 QQ(nameMkPrimMutableArray ) = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
411 QQ(nameMkPrimMutableByteArray) = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
413 #ifdef PROVIDE_CONCURRENT
414 QQ(nameMkThreadId) = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
415 QQ(nameMkMVar ) = addPrimCfun(findTextREP("MVar#"),1,0,0);
418 /* The following primitives are referred to in derived instances and
419 * hence require types; the following types are a little more general
420 * than we might like, but they are the closest we can get without a
421 * special datatype class.
423 name(nameConCmp).type
424 = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering)));
425 name(nameEnRange).type
426 = mkPolyType(starToStar,fn(boundPair,listof));
427 name(nameEnIndex).type
428 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt)));
429 name(nameEnInRng).type
430 = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool)));
431 name(nameEnToEn).type
432 = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar)));
433 name(nameEnFrEn).type
434 = mkPolyType(starToStar,fn(aVar,typeInt));
435 name(nameEnFrom).type
436 = mkPolyType(starToStar,fn(aVar,listof));
437 name(nameEnFrTo).type
438 = name(nameEnFrTh).type
439 = mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
442 addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->) */
445 for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
447 addEvalInst(0,mkTuple(i),i,NIL);
450 addTupInst(classEq,i);
453 addTupInst(classOrd,i);
456 addTupInst(classIx,i);
459 addTupInst(classShow,i);
462 addTupInst(classRead,i);
465 addTupInst(classBounded,i);
471 static Void mkTypes ( void )
473 //qqfail QQ(arrow ) = fn(aVar,mkOffset(1));
474 //qqfail QQ(listof ) = ap(typeList,aVar);
475 QQ(predNum ) = ap(classNum,aVar);
476 QQ(predFractional) = ap(classFractional,aVar);
477 QQ(predIntegral ) = ap(classIntegral,aVar);
478 QQ(predMonad ) = ap(classMonad,aVar);
481 Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
482 static Bool initialised = FALSE; /* prelude when first loaded */
486 ////setCurrModule(modulePreludeHugs);
487 setCurrModule(modulePrelude);
489 QQ(nameFalse ) = linkName("False");
490 QQ(nameTrue ) = linkName("True");
491 //qqfail QQ(nameNil ) = linkName("[]");
492 //qqfail QQ(nameCons ) = linkName(":");
493 //qqfail QQ(nameUnit ) = linkName("()");
495 QQ(nameEq ) = linkName("==");
496 QQ(nameFromInt ) = linkName("fromInt");
497 QQ(nameFromInteger) = linkName("fromInteger");
498 QQ(nameFromDouble) = linkName("fromDouble");
500 nameStrict = linkName("strict");
501 nameSeq = linkName("seq");
503 QQ(nameReturn ) = linkName("return");
504 QQ(nameBind ) = linkName(">>=");
506 QQ(nameLe ) = linkName("<=");
507 QQ(nameGt ) = linkName(">");
508 QQ(nameShowsPrec ) = linkName("showsPrec");
509 QQ(nameReadsPrec ) = linkName("readsPrec");
510 QQ(nameEQ ) = linkName("EQ");
511 QQ(nameCompare ) = linkName("compare");
512 QQ(nameMinBnd ) = linkName("minBound");
513 QQ(nameMaxBnd ) = linkName("maxBound");
514 QQ(nameRange ) = linkName("range");
515 QQ(nameIndex ) = linkName("index");
516 QQ(namePlus ) = linkName("+");
517 QQ(nameMult ) = linkName("*");
518 QQ(nameRangeSize ) = linkName("rangeSize");
519 QQ(nameInRange ) = linkName("inRange");
520 /* These come before calls to implementPrim */
521 for(i=0; i<NUM_TUPLES; ++i) {
527 Void linkPreludeNames(void) { /* Hook to names defined in Prelude */
528 static Bool initialised = FALSE;
533 setCurrModule(modulePrelude);
536 QQ(nameMkIO) = linkName("primMkIO");
537 for (i=0; asmPrimOps[i].name; ++i) {
538 Text t = findText(asmPrimOps[i].name);
539 Name n = findName(t);
545 name(n).type = primType(asmPrimOps[i].monad,
547 asmPrimOps[i].results);
548 name(n).arity = strlen(asmPrimOps[i].args);
549 name(n).primop = &(asmPrimOps[i]);
553 /* hooks for handwritten bytecode */
555 StgVar vv = mkStgVar(NIL,NIL);
556 Text t = findText("primSeq");
557 Name n = newName(t,NIL);
558 name(n).line = name(n).defn = 0;
560 name(n).type = primType(MONAD_Id, "ab", "b");
561 vv = mkStgVar(NIL,NIL);
562 stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
564 stgGlobals=cons(pair(n,vv),stgGlobals);
568 StgVar vv = mkStgVar(NIL,NIL);
569 Text t = findText("primCatch");
570 Name n = newName(t,NIL);
571 name(n).line = name(n).defn = 0;
573 name(n).type = primType(MONAD_Id, "aH", "a");
574 stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
576 stgGlobals=cons(pair(n,vv),stgGlobals);
580 StgVar vv = mkStgVar(NIL,NIL);
581 Text t = findText("primRaise");
582 Name n = newName(t,NIL);
583 name(n).line = name(n).defn = 0;
585 name(n).type = primType(MONAD_Id, "E", "a");
586 stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
588 stgGlobals=cons(pair(n,vv),stgGlobals);
591 /* static(tidyInfix) */
592 QQ(nameNegate ) = linkName("negate");
594 QQ(nameRunIO ) = linkName("primRunIO");
595 QQ(namePrint ) = linkName("print");
596 /* typechecker (undefined member functions) */
597 //qqfail QQ(nameError ) = linkName("error");
599 //qqfail QQ(nameId ) = linkName("id");
600 QQ(nameOtherwise ) = linkName("otherwise");
601 QQ(nameUndefined ) = linkName("undefined");
604 namePmSub = linkName("primPmSub");
607 ////nameUnpackString = linkName("primUnpackString");
608 ////namePMFail = linkName("primPmFail");
609 QQ(nameEqChar ) = linkName("primEqChar");
610 QQ(nameEqInt ) = linkName("primEqInt");
611 #if !OVERLOADED_CONSTANTS
612 QQ(nameEqInteger ) = linkName("primEqInteger");
613 #endif /* !OVERLOADED_CONSTANTS */
614 QQ(nameEqDouble ) = linkName("primEqDouble");
615 QQ(namePmInt ) = linkName("primPmInt");
616 ////namePmInteger = linkName("primPmInteger");
617 ////namePmDouble = linkName("primPmDouble");
618 ////namePmLe = linkName("primPmLe");
619 ////namePmSubtract = linkName("primPmSubtract");
620 ////namePmFromInteger = linkName("primPmFromInteger");
625 /* ToDo: fix pFun (or eliminate its use) */
626 #define pFun(n,s) QQ(n) = predefinePrim(s)
628 Void linkControl(what)
635 case INSTALL : linkControl(RESET);
637 modulePrelude = newModule(textPrelude);
638 setCurrModule(modulePrelude);
640 typeArrow = addPrimTycon(findText("(->)"),
641 pair(STAR,pair(STAR,STAR)),
644 /* newtype and USE_NEWTYPE_FOR_DICTS */
648 pFun(nameInd, "_indirect");
649 name(nameInd).number = DFUNNAME;
652 pFun(nameSel, "_SEL");
654 /* strict constructors */
655 pFun(nameFlip, "flip" );
658 pFun(nameFromTo, "enumFromTo");
659 pFun(nameFromThenTo, "enumFromThenTo");
660 pFun(nameFrom, "enumFrom");
661 pFun(nameFromThen, "enumFromThen");
665 pFun(nameReadParen, "readParen");
666 pFun(nameShowParen, "showParen");
667 pFun(nameLex, "lex");
668 pFun(nameEnToEn, "toEnumPR"); //not sure
669 pFun(nameEnFrEn, "fromEnum"); //not sure
670 pFun(nameEnFrom, "enumFrom"); //not sure
671 pFun(nameEnFrTh, "enumFromThen"); //not sure
672 pFun(nameEnFrTo, "enumFromTo"); //not sure
673 pFun(nameEnRange, "range"); //not sure
674 pFun(nameEnIndex, "index"); //not sure
675 pFun(nameEnInRng, "inRange"); //not sure
676 pFun(nameConCmp, "_concmp"); //very not sure
679 pFun(nameCompAux, "primCompAux");
681 /* implementTagToCon */
682 pFun(namePMFail, "primPmFail");
683 pFun(nameError, "error");
684 pFun(nameUnpackString, "primUnpackString");
692 /*-------------------------------------------------------------------------*/