2 /* --------------------------------------------------------------------------
3 * GHC interface file processing for Hugs
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
9 * $RCSfile: interface.c,v $
11 * $Date: 2000/03/02 10:10:33 $
12 * ------------------------------------------------------------------------*/
20 #include "Assembler.h" /* for wrapping GHC objects */
24 /*#define DEBUG_IFACE*/
27 extern void print ( Cell, Int );
29 /* --------------------------------------------------------------------------
30 * (This comment is now out of date. JRS, 991216).
31 * The "addGHC*" functions act as "impedence matchers" between GHC
32 * interface files and Hugs. Their main job is to convert abstract
33 * syntax trees into Hugs' internal representations.
35 * The main trick here is how we deal with mutually recursive interface
38 * o As we read an import decl, we add it to a list of required imports
39 * (unless it's already loaded, of course).
41 * o Processing of declarations is split into two phases:
43 * 1) While reading the interface files, we construct all the Names,
44 * Tycons, etc declared in the interface file but we don't try to
45 * resolve references to any entities the declaration mentions.
47 * This is done by the "addGHC*" functions.
49 * 2) After reading all the interface files, we finish processing the
50 * declarations by resolving any references in the declarations
51 * and doing any other processing that may be required.
53 * This is done by the "finishGHC*" functions which use the
54 * "fixup*" functions to assist them.
56 * The interface between these two phases are the "ghc*Decls" which
57 * contain lists of decls that haven't been completed yet.
59 * ------------------------------------------------------------------------*/
63 New comment, 991216, explaining roughly how it all works.
64 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
66 Interfaces can contain references to unboxed types, and these need to
67 be handled carefully. The following is a summary of how the interface
68 loader now works. It is applied to groups of interfaces simultaneously,
69 viz, the entire Prelude at once:
71 0. Parse interfaces, chasing imports until a complete
72 strongly-connected-component of ifaces has been parsed.
73 All interfaces in this scc are processed together, in
76 1. Throw away any entity not mentioned in the export lists.
78 2. Delete type (not data or newtype) definitions which refer to
79 unknown types in their right hand sides. Because Hugs doesn't
80 know of any unboxed types, this has the side effect of removing
81 all type defns referring to unboxed types. Repeat step 2 until
82 a fixed point is reached.
84 3. Make abstract all data/newtype defns which refer to an unknown
85 type. eg, data Word = MkW Word# becomes data Word, because
86 Word# is unknown. Hugs is happy to know about abstract boxed
87 Words, but not about Word#s.
89 4. Step 2 could delete types referred to by values, instances and
90 classes. So filter all entities, and delete those referring to
91 unknown types _or_ classes. This could cause other entities
92 to become invalid, so iterate step 4 to a fixed point.
94 After step 4, the interfaces no longer contain anything
97 5. Steps 1-4 operate purely on the iface syntax trees. We now start
98 creating symbol table entries. First, create a module table
99 entry for each interface, and locate and read in the corresponding
100 object file. This is done by the startGHCModule function.
102 6. Traverse all interfaces. For each entity, create an entry in
103 the name, tycon, class or instance table, and fill in relevant
104 fields, but do not attempt to link tycon/class/instance/name uses
105 to their symbol table entries. This is done by the startGHC*
108 7. Revisit all symbol table entries created in step 6. We should
109 now be able to replace all references to tycons/classes/instances/
110 names with the relevant symbol table entries. This is done by
111 the finishGHC* functions.
113 8. Traverse all interfaces. For each iface, examine the export lists
114 and use it to build export lists in the module table. Do the
115 implicit 'import Prelude' thing if necessary. Finally, resolve
116 references in the object code for this module. This is done
117 by the finishGHCModule function.
120 /* --------------------------------------------------------------------------
121 * local function prototypes:
122 * ------------------------------------------------------------------------*/
124 static Void startGHCValue Args((Int,VarId,Type));
125 static Void finishGHCValue Args((VarId));
127 static Void startGHCSynonym Args((Int,Cell,List,Type));
128 static Void finishGHCSynonym Args((Tycon));
130 static Void startGHCClass Args((Int,List,Cell,List,List));
131 static Class finishGHCClass Args((Class));
133 static Inst startGHCInstance Args((Int,List,Pair,VarId));
134 static Void finishGHCInstance Args((Inst));
136 static Void startGHCImports Args((ConId,List));
137 static Void finishGHCImports Args((ConId,List));
139 static Void startGHCExports Args((ConId,List));
140 static Void finishGHCExports Args((ConId,List));
142 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
144 static Void finishGHCModule Args((Cell));
145 static Void startGHCModule Args((Text, Int, Text));
147 static Void startGHCDataDecl Args((Int,List,Cell,List,List));
148 static List finishGHCDataDecl ( ConId tyc );
150 static Void startGHCNewType Args((Int,List,Cell,List,Cell));
151 static Void finishGHCNewType ( ConId tyc );
154 /* Supporting stuff for {start|finish}GHCDataDecl */
155 static List startGHCConstrs Args((Int,List,List));
156 static Name startGHCSel Args((Int,Pair));
157 static Name startGHCConstr Args((Int,Int,Triple));
161 static Kinds tvsToKind Args((List));
162 static Int arityFromType Args((Type));
163 static Int arityInclDictParams Args((Type));
164 static Bool allTypesKnown ( Type type, List aktys /* [QualId] */, ConId thisMod );
166 static List ifTyvarsIn Args((Type));
168 static Type tvsToOffsets Args((Int,Type,List));
169 static Type conidcellsToTycons Args((Int,Type));
171 static void* lookupObjName ( char* );
177 /* --------------------------------------------------------------------------
178 * Top-level interface processing
179 * ------------------------------------------------------------------------*/
181 /* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
182 static ConVarId getIEntityName ( Cell c )
185 case I_IMPORT: return NIL;
186 case I_INSTIMPORT: return NIL;
187 case I_EXPORT: return NIL;
188 case I_FIXDECL: return zthd3(unap(I_FIXDECL,c));
189 case I_INSTANCE: return NIL;
190 case I_TYPE: return zsel24(unap(I_TYPE,c));
191 case I_DATA: return zsel35(unap(I_DATA,c));
192 case I_NEWTYPE: return zsel35(unap(I_NEWTYPE,c));
193 case I_CLASS: return zsel35(unap(I_CLASS,c));
194 case I_VALUE: return zsnd3(unap(I_VALUE,c));
195 default: internal("getIEntityName");
200 /* Filter the contents of an interface, using the supplied predicate.
201 For flexibility, the predicate is passed as a second arg the value
202 extraArgs. This is a hack to get round the lack of partial applications
203 in C. Pred should not have any side effects. The dumpaction param
204 gives us the chance to print a message or some such for dumped items.
205 When a named entity is deleted, filterInterface also deletes the name
208 static Cell filterInterface ( Cell root,
209 Bool (*pred)(Cell,Cell),
211 Void (*dumpAction)(Cell) )
214 Cell iface = unap(I_INTERFACE,root);
216 List deleted_ids = NIL; /* :: [ConVarId] */
218 for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
219 if (pred(hd(tops),extraArgs)) {
220 tops2 = cons( hd(tops), tops2 );
222 ConVarId deleted_id = getIEntityName ( hd(tops) );
223 if (nonNull(deleted_id))
224 deleted_ids = cons ( deleted_id, deleted_ids );
226 dumpAction ( hd(tops) );
229 tops2 = reverse(tops2);
231 /* Clean up the export list now. */
232 for (tops=tops2; nonNull(tops); tops=tl(tops)) {
233 if (whatIs(hd(tops))==I_EXPORT) {
234 Cell exdecl = unap(I_EXPORT,hd(tops));
235 List exlist = zsnd(exdecl);
237 for (; nonNull(exlist); exlist=tl(exlist)) {
238 Cell ex = hd(exlist);
239 ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
240 assert (isCon(exid) || isVar(exid));
241 if (!varIsMember(textOf(exid),deleted_ids))
242 exlist2 = cons(ex, exlist2);
244 hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
248 return ap(I_INTERFACE, zpair(zfst(iface),tops2));
252 ZPair readInterface(String fname, Long fileSize)
256 ZPair iface = parseInterface(fname,fileSize);
257 assert (whatIs(iface)==I_INTERFACE);
259 for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
260 if (whatIs(hd(tops)) == I_IMPORT) {
261 ZPair imp_decl = unap(I_IMPORT,hd(tops));
262 ConId m_to_imp = zfst(imp_decl);
263 if (textOf(m_to_imp) != findText("PrelGHC")) {
264 imports = cons(m_to_imp,imports);
265 /* fprintf(stderr, "add iface %s\n", textToStr(textOf(m_to_imp))); */
268 return zpair(iface,imports);
272 /* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
273 static List getExportDeclsInIFace ( Cell root )
275 Cell iface = unap(I_INTERFACE,root);
276 List decls = zsnd(iface);
279 for (ds=decls; nonNull(ds); ds=tl(ds))
280 if (whatIs(hd(ds))==I_EXPORT)
281 exports = cons(hd(ds), exports);
286 /* Does t start with "$dm" ? */
287 static Bool isIfaceDefaultMethodName ( Text t )
289 String s = textToStr(t);
290 return (s && s[0]=='$' && s[1]=='d' && s[2]=='m' && s[3]);
294 static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
296 /* ife :: I_IMPORT..I_VALUE */
297 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
303 ConVarId ife_id = getIEntityName ( ife );
305 if (isNull(ife_id)) return TRUE;
307 tnm = textOf(ife_id);
309 /* Don't junk default methods, even tho the export list doesn't
312 if (isIfaceDefaultMethodName(tnm)) goto retain;
314 /* for each export list ... */
315 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
316 exlist = hd(exlist_list);
318 /* for each entity in an export list ... */
319 for (t=exlist; nonNull(t); t=tl(t)) {
320 if (isZPair(hd(t))) {
321 /* A pair, which means an export entry
322 of the form ClassName(foo,bar). */
323 List subents = cons(zfst(hd(t)),zsnd(hd(t)));
324 for (; nonNull(subents); subents=tl(subents))
325 if (textOf(hd(subents)) == tnm) goto retain;
327 /* Single name in the list. */
328 if (textOf(hd(t)) == tnm) goto retain;
333 fprintf ( stderr, " dump %s\n", textToStr(tnm) );
337 fprintf ( stderr, " retain %s\n", textToStr(tnm) );
342 static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
344 /* ife_id :: ConId */
345 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
350 assert (isCon(ife_id));
351 tnm = textOf(ife_id);
353 /* for each export list ... */
354 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
355 exlist = hd(exlist_list);
357 /* for each entity in an export list ... */
358 for (t=exlist; nonNull(t); t=tl(t)) {
359 if (isZPair(hd(t))) {
360 /* A pair, which means an export entry
361 of the form ClassName(foo,bar). */
362 if (textOf(zfst(hd(t))) == tnm) return FALSE;
364 if (textOf(hd(t)) == tnm) return TRUE;
368 internal("isExportedAbstractly");
369 return FALSE; /*notreached*/
373 /* Remove entities not mentioned in any of the export lists. */
374 static Cell deleteUnexportedIFaceEntities ( Cell root )
376 Cell iface = unap(I_INTERFACE,root);
377 ConId iname = zfst(iface);
378 List decls = zsnd(iface);
380 List exlist_list = NIL;
383 fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
385 exlist_list = getExportDeclsInIFace ( root );
386 /* exlist_list :: [I_EXPORT] */
388 for (t=exlist_list; nonNull(t); t=tl(t))
389 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
390 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
392 if (isNull(exlist_list)) {
393 ERRMSG(0) "Can't find any export lists in interface file"
397 return filterInterface ( root, isExportedIFaceEntity,
402 /* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
403 static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
405 Cell iface = unap(I_INTERFACE,root);
406 Text mname = textOf(zfst(iface));
407 List defns = zsnd(iface);
408 for (; nonNull(defns); defns = tl(defns)) {
409 Cell defn = hd(defns);
410 Cell what = whatIs(defn);
411 if (what==I_TYPE || what==I_DATA
412 || what==I_NEWTYPE || what==I_CLASS) {
413 QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
414 if (!qualidIsMember ( q, aktys ))
415 aktys = cons ( q, aktys );
422 static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
424 ConVarId id = getIEntityName ( entity );
426 "dumping %s because of unknown type(s)\n",
427 isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
431 /* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
432 /* mod is the current module being processed -- so we can qualify unqual'd
433 names. Strange calling convention for aktys and mod is so we can call this
434 from filterInterface.
436 static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
439 List aktys = zfst ( aktys_mod );
440 ConId mod = zsnd ( aktys_mod );
441 switch (whatIs(entity)) {
448 Cell inst = unap(I_INSTANCE,entity);
449 List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
450 Type cls = zsel35 ( inst ); /* :: Type */
451 for (t = ctx; nonNull(t); t=tl(t))
452 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
453 if (!allTypesKnown(cls, aktys,mod)) return FALSE;
457 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
459 Cell data = unap(I_DATA,entity);
460 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
461 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
462 for (t = ctx; nonNull(t); t=tl(t))
463 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
464 for (t = constrs; nonNull(t); t=tl(t))
465 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
466 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
470 Cell newty = unap(I_NEWTYPE,entity);
471 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
472 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
473 for (t = ctx; nonNull(t); t=tl(t))
474 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
476 && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
480 Cell klass = unap(I_CLASS,entity);
481 List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
482 List sigs = zsel55(klass); /* :: [((VarId,Type))] */
483 for (t = ctx; nonNull(t); t=tl(t))
484 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
485 for (t = sigs; nonNull(t); t=tl(t))
486 if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
490 return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
492 internal("ifentityAllTypesKnown");
497 /* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
498 /* mod is the current module being processed -- so we can qualify unqual'd
499 names. Strange calling convention for aktys and mod is so we can call this
500 from filterInterface.
502 static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
505 List aktys = zfst ( aktys_mod );
506 ConId mod = zsnd ( aktys_mod );
507 if (whatIs(entity) != I_TYPE) {
510 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
515 static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
517 ConVarId id = getIEntityName ( entity );
518 assert (whatIs(entity)==I_TYPE);
521 "dumping type %s because of unknown tycon(s)\n",
522 textToStr(textOf(id)) );
526 /* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
528 static List abstractifyExDecl ( Cell root, ConId toabs )
530 ZPair exdecl = unap(I_EXPORT,root);
531 List exlist = zsnd(exdecl);
533 for (; nonNull(exlist); exlist = tl(exlist)) {
534 if (isZPair(hd(exlist))
535 && textOf(toabs) == textOf(zfst(hd(exlist)))) {
536 /* it's toabs, exported non-abstractly */
537 res = cons ( zfst(hd(exlist)), res );
539 res = cons ( hd(exlist), res );
542 return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
546 static Void ppModule ( Text modt )
548 fflush(stderr); fflush(stdout);
549 fprintf(stderr, "---------------- MODULE %s ----------------\n",
554 static void* ifFindItblFor ( Name n )
556 /* n is a constructor for which we want to find the GHC info table.
557 First look for a _con_info symbol. If that doesn't exist, _and_
558 this is a nullary constructor, then it's safe to look for the
559 _static_info symbol instead.
565 sprintf ( buf, "%s_%s_con_info",
566 textToStr( module(name(n).mod).text ),
567 textToStr( name(n).text ) );
568 t = enZcodeThenFindText(buf);
569 p = lookupOTabName ( name(n).mod, textToStr(t) );
573 if (name(n).arity == 0) {
574 sprintf ( buf, "%s_%s_static_info",
575 textToStr( module(name(n).mod).text ),
576 textToStr( name(n).text ) );
577 t = enZcodeThenFindText(buf);
578 p = lookupOTabName ( name(n).mod, textToStr(t) );
582 ERRMSG(0) "Can't find info table %s", textToStr(t)
587 void ifLinkConstrItbl ( Name n )
589 /* name(n) is either a constructor or a field name.
590 If the latter, ignore it. If it is a non-nullary constructor,
591 find its info table in the object code. If it's nullary,
592 we can skip the info table, since all accesses will go via
595 if (islower(textToStr(name(n).text)[0])) return;
596 if (name(n).arity == 0) return;
597 name(n).itbl = ifFindItblFor(n);
601 static void ifSetClassDefaultsAndDCon ( Class c )
609 List defs; /* :: [Name] */
610 List mems; /* :: [Name] */
612 assert(isNull(cclass(c).defaults));
614 /* Create the defaults list by more-or-less cloning the members list. */
616 for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
618 s = textToStr( name(hd(mems)).text );
619 assert(strlen(s) < 95);
621 n = findNameInAnyModule(findText(buf));
626 cclass(c).defaults = defs;
628 /* Create a name table entry for the dictionary datacon.
629 Interface files don't mention them, so it had better not
633 s = textToStr( cclass(c).text );
634 assert( strlen(s) < 96 );
637 n = findNameInAnyModule(t);
643 name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
644 name(n).number = cfunNo(0);
647 /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
648 Because this happens right at the end of loading, we know
649 that we should actually be able to find the symbol in this
650 module's object symbol table. Except that if the dictionary
651 has arity 1, we don't bother, since it will be represented as
652 a newtype and not as a data, so its itbl can remain NULL.
654 if (name(n).arity == 1) {
656 name(n).defn = nameId;
658 p = ifFindItblFor ( n );
664 /* ifaces_outstanding holds a list of parsed interfaces
665 for which we need to load objects and create symbol
668 Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
670 Bool processInterfaces ( void )
681 List all_known_types;
684 List cls_list; /* :: List Class */
685 List constructor_list; /* :: List Name */
687 List ifaces = NIL; /* :: List I_INTERFACE */
688 List iface_sizes = NIL; /* :: List Int */
689 List iface_onames = NIL; /* :: List Text */
691 if (isNull(ifaces_outstanding)) return FALSE;
694 "processInterfaces: %d interfaces to process\n",
695 length(ifaces_outstanding) );
697 /* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
698 for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
699 ifaces = cons ( zfst3(hd(xs)), ifaces );
700 iface_onames = cons ( zsnd3(hd(xs)), iface_onames );
701 iface_sizes = cons ( zthd3(hd(xs)), iface_sizes );
704 ifaces = reverse(ifaces);
705 iface_onames = reverse(iface_onames);
706 iface_sizes = reverse(iface_sizes);
708 /* Clean up interfaces -- dump non-exported value, class, type decls */
709 for (xs = ifaces; nonNull(xs); xs = tl(xs))
710 hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
713 /* Iteratively delete any type declarations which refer to unknown
716 num_known_types = 999999999;
720 /* Construct a list of all known tycons. This is a list of QualIds.
721 Unfortunately it also has to contain all known class names, since
722 allTypesKnown cannot distinguish between tycons and classes -- a
723 deficiency of the iface abs syntax.
725 all_known_types = getAllKnownTyconsAndClasses();
726 for (xs = ifaces; nonNull(xs); xs=tl(xs))
727 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
729 /* Have we reached a fixed point? */
730 i = length(all_known_types);
731 printf ( "\n============= %d known types =============\n", i );
732 if (num_known_types == i) break;
735 /* Delete all entities which refer to unknown tycons. */
736 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
737 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
738 assert(nonNull(mod));
739 hd(xs) = filterInterface ( hd(xs),
740 ifTypeDoesntRefUnknownTycon,
741 zpair(all_known_types,mod),
742 ifTypeDoesntRefUnknownTycon_dumpmsg );
746 /* Now abstractify any datas and newtypes which refer to unknown tycons
747 -- including, of course, the type decls just deleted.
749 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
750 List absify = NIL; /* :: [ConId] */
751 ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
752 ConId mod = zfst(iface);
753 List aktys = all_known_types; /* just a renaming */
757 /* Compute into absify the list of all ConIds (tycons) we need to
760 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
762 Bool allKnown = TRUE;
764 if (whatIs(ent)==I_DATA) {
765 Cell data = unap(I_DATA,ent);
766 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
767 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
768 for (t = ctx; nonNull(t); t=tl(t))
769 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
770 for (t = constrs; nonNull(t); t=tl(t))
771 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
772 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
774 else if (whatIs(ent)==I_NEWTYPE) {
775 Cell newty = unap(I_NEWTYPE,ent);
776 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
777 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
778 for (t = ctx; nonNull(t); t=tl(t))
779 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
780 if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
784 absify = cons ( getIEntityName(ent), absify );
786 "abstractifying %s because it uses an unknown type\n",
787 textToStr(textOf(getIEntityName(ent))) );
791 /* mark in exports as abstract all names in absify (modifies iface) */
792 for (; nonNull(absify); absify=tl(absify)) {
793 ConId toAbs = hd(absify);
794 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
795 if (whatIs(hd(es)) != I_EXPORT) continue;
796 hd(es) = abstractifyExDecl ( hd(es), toAbs );
800 /* For each data/newtype in the export list marked as abstract,
801 remove the constructor lists. This catches all abstractification
802 caused by the code above, and it also catches tycons which really
803 were exported abstractly.
806 exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
807 /* exlist_list :: [I_EXPORT] */
808 for (t=exlist_list; nonNull(t); t=tl(t))
809 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
810 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
812 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
814 if (whatIs(ent)==I_DATA
815 && isExportedAbstractly ( getIEntityName(ent),
817 Cell data = unap(I_DATA,ent);
818 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
819 zsel45(data), NIL /* the constr list */ );
820 hd(es) = ap(I_DATA,data);
821 fprintf(stderr, "abstractify data %s\n", textToStr(textOf(getIEntityName(ent))) );
823 else if (whatIs(ent)==I_NEWTYPE
824 && isExportedAbstractly ( getIEntityName(ent),
826 Cell data = unap(I_NEWTYPE,ent);
827 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
828 zsel45(data), NIL /* the constr-type pair */ );
829 hd(es) = ap(I_NEWTYPE,data);
830 fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent))) );
834 /* We've finally finished mashing this iface. Update the iface list. */
835 hd(xs) = ap(I_INTERFACE,iface);
839 /* At this point, the interfaces are cleaned up so that no type, data or
840 newtype defn refers to a non-existant type. However, there still may
841 be value defns, classes and instances which refer to unknown types.
842 Delete iteratively until a fixed point is reached.
846 num_known_types = 999999999;
850 /* Construct a list of all known tycons. This is a list of QualIds.
851 Unfortunately it also has to contain all known class names, since
852 allTypesKnown cannot distinguish between tycons and classes -- a
853 deficiency of the iface abs syntax.
855 all_known_types = getAllKnownTyconsAndClasses();
856 for (xs = ifaces; nonNull(xs); xs=tl(xs))
857 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
859 /* Have we reached a fixed point? */
860 i = length(all_known_types);
861 printf ( "\n------------- %d known types -------------\n", i );
862 if (num_known_types == i) break;
865 /* Delete all entities which refer to unknown tycons. */
866 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
867 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
868 assert(nonNull(mod));
870 hd(xs) = filterInterface ( hd(xs),
871 ifentityAllTypesKnown,
872 zpair(all_known_types,mod),
873 ifentityAllTypesKnown_dumpmsg );
878 /* Allocate module table entries and read in object code. */
881 xs=tl(xs), iface_sizes=tl(iface_sizes), iface_onames=tl(iface_onames)) {
882 startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))),
883 intOf(hd(iface_sizes)),
886 assert (isNull(iface_sizes));
887 assert (isNull(iface_onames));
890 /* Now work through the decl lists of the modules, and call the
891 startGHC* functions on the entities. This creates names in
892 various tables but doesn't bind them to anything.
895 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
896 iface = unap(I_INTERFACE,hd(xs));
897 mname = textOf(zfst(iface));
898 mod = findModule(mname);
899 if (isNull(mod)) internal("processInterfaces(4)");
901 ppModule ( module(mod).text );
903 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
904 Cell decl = hd(decls);
905 switch(whatIs(decl)) {
907 Cell exdecl = unap(I_EXPORT,decl);
908 startGHCExports ( zfst(exdecl), zsnd(exdecl) );
912 Cell imdecl = unap(I_IMPORT,decl);
913 startGHCImports ( zfst(imdecl), zsnd(imdecl) );
920 /* Trying to find the instance table location allocated by
921 startGHCInstance in subsequent processing is a nightmare, so
922 cache it on the tree.
924 Cell instance = unap(I_INSTANCE,decl);
925 Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
926 zsel35(instance), zsel45(instance) );
927 hd(decls) = ap(I_INSTANCE,
928 z5ble( zsel15(instance), zsel25(instance),
929 zsel35(instance), zsel45(instance), in ));
933 Cell tydecl = unap(I_TYPE,decl);
934 startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
935 zsel34(tydecl), zsel44(tydecl) );
939 Cell ddecl = unap(I_DATA,decl);
940 startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
941 zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
945 Cell ntdecl = unap(I_NEWTYPE,decl);
946 startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
947 zsel35(ntdecl), zsel45(ntdecl),
952 Cell klass = unap(I_CLASS,decl);
953 startGHCClass ( zsel15(klass), zsel25(klass),
954 zsel35(klass), zsel45(klass),
959 Cell value = unap(I_VALUE,decl);
960 startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
964 internal("processInterfaces(1)");
969 fprintf(stderr, "\n=========================================================\n");
970 fprintf(stderr, "=========================================================\n");
972 /* Traverse again the decl lists of the modules, this time
973 calling the finishGHC* functions. But don't process
974 the export lists; those must wait for later.
978 constructor_list = NIL;
979 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
980 iface = unap(I_INTERFACE,hd(xs));
981 mname = textOf(zfst(iface));
982 mod = findModule(mname);
983 if (isNull(mod)) internal("processInterfaces(3)");
985 ppModule ( module(mod).text );
987 if (mname == textPrelude) didPrelude = TRUE;
989 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
990 Cell decl = hd(decls);
991 switch(whatIs(decl)) {
999 Cell fixdecl = unap(I_FIXDECL,decl);
1000 finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
1004 Cell instance = unap(I_INSTANCE,decl);
1005 finishGHCInstance ( zsel55(instance) );
1009 Cell tydecl = unap(I_TYPE,decl);
1010 finishGHCSynonym ( zsel24(tydecl) );
1014 Cell ddecl = unap(I_DATA,decl);
1015 List constrs = finishGHCDataDecl ( zsel35(ddecl) );
1016 constructor_list = appendOnto ( constrs, constructor_list );
1020 Cell ntdecl = unap(I_NEWTYPE,decl);
1021 finishGHCNewType ( zsel35(ntdecl) );
1025 Cell klass = unap(I_CLASS,decl);
1026 Class cls = finishGHCClass ( zsel35(klass) );
1027 cls_list = cons(cls,cls_list);
1031 Cell value = unap(I_VALUE,decl);
1032 finishGHCValue ( zsnd3(value) );
1036 internal("processInterfaces(2)");
1040 fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
1041 fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
1043 /* Build the module(m).export lists for each module, by running
1044 through the export lists in the iface. Also, do the implicit
1045 'import Prelude' thing. And finally, do the object code
1048 for (xs = ifaces; nonNull(xs); xs = tl(xs))
1049 finishGHCModule(hd(xs));
1051 mapProc(visitClass,cls_list);
1052 mapProc(ifSetClassDefaultsAndDCon,cls_list);
1053 mapProc(ifLinkConstrItbl,constructor_list);
1056 ifaces_outstanding = NIL;
1062 /* --------------------------------------------------------------------------
1064 * ------------------------------------------------------------------------*/
1066 static void startGHCModule_errMsg ( char* msg )
1068 fprintf ( stderr, "object error: %s\n", msg );
1071 static void* startGHCModule_clientLookup ( char* sym )
1073 /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
1074 return lookupObjName ( sym );
1077 static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
1080 = ocNew ( startGHCModule_errMsg,
1081 startGHCModule_clientLookup,
1085 ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
1088 if (!ocLoadImage(oc,VERBOSE)) {
1089 ERRMSG(0) "Reading of object file \"%s\" failed", objNm
1092 if (!ocVerifyImage(oc,VERBOSE)) {
1093 ERRMSG(0) "Validation of object file \"%s\" failed", objNm
1096 if (!ocGetNames(oc,VERBOSE)) {
1097 ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
1103 static Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
1106 Module m = findModule(mname);
1109 m = newModule(mname);
1110 fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
1111 textToStr(mname), sizeObj );
1113 if (module(m).fake) {
1114 module(m).fake = FALSE;
1116 ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
1121 /* Get hold of the primary object for the module. */
1123 = startGHCModule_partial_load ( textToStr(nameObj), sizeObj );
1125 /* and any extras ... */
1126 for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
1130 String nm = getExtraObjectInfo ( textToStr(nameObj),
1134 ERRMSG(0) "Can't find extra object file \"%s\"", nm
1137 oc = startGHCModule_partial_load ( nm, size );
1138 oc->next = module(m).objectExtras;
1139 module(m).objectExtras = oc;
1144 /* For the module mod, augment both the export environment (.exports)
1145 and the eval environment (.names, .tycons, .classes)
1146 with the symbols mentioned in exlist. We don't actually need
1147 to modify the names, tycons, classes or instances in the eval
1148 environment, since previous processing of the
1149 top-level decls in the iface should have done this already.
1151 mn is the module mentioned in the export list; it is the "original"
1152 module for the symbols in the export list. We should also record
1153 this info with the symbols, since references to object code need to
1154 refer to the original module in which a symbol was defined, rather
1155 than to some module it has been imported into and then re-exported.
1157 We take the policy that if something mentioned in an export list
1158 can't be found in the symbol tables, it is simply ignored. After all,
1159 previous processing of the iface syntax trees has already removed
1160 everything which Hugs can't handle, so if there is mention of these
1161 things still lurking in export lists somewhere, about the only thing
1162 to do is to ignore it.
1164 Also do an implicit 'import Prelude' thingy for the module,
1169 static Void finishGHCModule ( Cell root )
1171 /* root :: I_INTERFACE */
1172 Cell iface = unap(I_INTERFACE,root);
1173 ConId iname = zfst(iface);
1174 Module mod = findModule(textOf(iname));
1175 List exlist_list = NIL;
1179 fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1181 if (isNull(mod)) internal("finishExports(1)");
1184 exlist_list = getExportDeclsInIFace ( root );
1185 /* exlist_list :: [I_EXPORT] */
1187 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1188 ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
1189 ConId exmod = zfst(exdecl);
1190 List exlist = zsnd(exdecl);
1191 /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1193 for (; nonNull(exlist); exlist=tl(exlist)) {
1198 Cell ex = hd(exlist);
1200 switch (whatIs(ex)) {
1202 case VARIDCELL: /* variable */
1203 q = mkQualId(exmod,ex);
1204 c = findQualNameWithoutConsultingExportList ( q );
1205 if (isNull(c)) goto notfound;
1206 fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
1207 module(mod).exports = cons(c, module(mod).exports);
1211 case CONIDCELL: /* non data tycon */
1212 q = mkQualId(exmod,ex);
1213 c = findQualTyconWithoutConsultingExportList ( q );
1214 if (isNull(c)) goto notfound;
1215 fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
1216 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1220 case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
1221 subents = zsnd(ex); /* :: [ConVarId] */
1222 ex = zfst(ex); /* :: ConId */
1223 q = mkQualId(exmod,ex);
1224 c = findQualTyconWithoutConsultingExportList ( q );
1226 if (nonNull(c)) { /* data */
1227 fprintf(stderr, " data/newtype %s = { ", textToStr(textOf(ex)) );
1228 assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1229 abstract = isNull(tycon(c).defn);
1230 /* This data/newtype could be abstract even tho the export list
1231 says to export it non-abstractly. That happens if it was
1232 imported from some other module and is now being re-exported,
1233 and previous cleanup phases have abstractified it in the
1234 original (defining) module.
1237 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1239 fprintf ( stderr, "(abstract) ");
1241 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1243 for (; nonNull(subents); subents = tl(subents)) {
1244 Cell ent2 = hd(subents);
1245 assert(isCon(ent2) || isVar(ent2));
1246 /* isVar since could be a field name */
1247 q = mkQualId(exmod,ent2);
1248 c = findQualNameWithoutConsultingExportList ( q );
1249 fprintf(stderr, "%s ", textToStr(name(c).text));
1251 /* module(mod).exports = cons(c, module(mod).exports); */
1255 fprintf(stderr, "}\n" );
1256 } else { /* class */
1257 q = mkQualId(exmod,ex);
1258 c = findQualClassWithoutConsultingExportList ( q );
1259 if (isNull(c)) goto notfound;
1260 fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
1261 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1263 for (; nonNull(subents); subents = tl(subents)) {
1264 Cell ent2 = hd(subents);
1265 assert(isVar(ent2));
1266 q = mkQualId(exmod,ent2);
1267 c = findQualNameWithoutConsultingExportList ( q );
1268 fprintf(stderr, "%s ", textToStr(name(c).text));
1269 if (isNull(c)) goto notfound;
1270 /* module(mod).exports = cons(c, module(mod).exports); */
1273 fprintf(stderr, "}\n" );
1278 internal("finishExports(2)");
1281 continue; /* so notfound: can be placed after this */
1284 /* q holds what ain't found */
1285 assert(whatIs(q)==QUALIDENT);
1286 fprintf( stderr, " ------ IGNORED: %s.%s\n",
1287 textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1293 if (preludeLoaded) {
1294 /* do the implicit 'import Prelude' thing */
1295 List pxs = module(modulePrelude).exports;
1296 for (; nonNull(pxs); pxs=tl(pxs)) {
1299 switch (whatIs(px)) {
1304 module(mod).names = cons ( px, module(mod).names );
1307 module(mod).tycons = cons ( px, module(mod).tycons );
1310 module(mod).classes = cons ( px, module(mod).classes );
1313 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1314 internal("finishGHCModule -- implicit import Prelude");
1321 /* Last, but by no means least ... */
1322 if (!ocResolve(module(mod).object,VERBOSE))
1323 internal("finishGHCModule: object resolution failed");
1325 for (oc=module(mod).objectExtras; oc; oc=oc->next) {
1326 if (!ocResolve(oc, VERBOSE))
1327 internal("finishGHCModule: extra object resolution failed");
1332 /* --------------------------------------------------------------------------
1334 * ------------------------------------------------------------------------*/
1336 static Void startGHCExports ( ConId mn, List exlist )
1339 printf("startGHCExports %s\n", textToStr(textOf(mn)) );
1341 /* Nothing to do. */
1344 static Void finishGHCExports ( ConId mn, List exlist )
1347 printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
1349 /* Nothing to do. */
1353 /* --------------------------------------------------------------------------
1355 * ------------------------------------------------------------------------*/
1357 static Void startGHCImports ( ConId mn, List syms )
1358 /* nm the module to import from */
1359 /* syms [ConId | VarId] -- the names to import */
1362 printf("startGHCImports %s\n", textToStr(textOf(mn)) );
1364 /* Nothing to do. */
1368 static Void finishGHCImports ( ConId nm, List syms )
1369 /* nm the module to import from */
1370 /* syms [ConId | VarId] -- the names to import */
1373 printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
1375 /* Nothing to do. */
1379 /* --------------------------------------------------------------------------
1381 * ------------------------------------------------------------------------*/
1383 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
1385 Int p = intOf(prec);
1386 Int a = intOf(assoc);
1387 Name n = findName(textOf(name));
1388 assert (nonNull(n));
1389 name(n).syntax = mkSyntax ( a, p );
1393 /* --------------------------------------------------------------------------
1395 * ------------------------------------------------------------------------*/
1397 /* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
1398 { C1 a } -> { C2 b } -> T into
1399 ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
1401 static Type dictapsToQualtype ( Type ty )
1404 List preds, dictaps;
1406 /* break ty into pieces at the top-level arrows */
1407 while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
1408 pieces = cons ( arg(fun(ty)), pieces );
1411 pieces = cons ( ty, pieces );
1412 pieces = reverse ( pieces );
1415 while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
1416 dictaps = cons ( hd(pieces), dictaps );
1417 pieces = tl(pieces);
1420 /* dictaps holds the predicates, backwards */
1421 /* pieces holds the remainder of the type, forwards */
1422 assert(nonNull(pieces));
1423 pieces = reverse(pieces);
1425 pieces = tl(pieces);
1426 for (; nonNull(pieces); pieces=tl(pieces))
1427 ty = fn(hd(pieces),ty);
1430 for (; nonNull(dictaps); dictaps=tl(dictaps)) {
1431 Cell da = hd(dictaps);
1432 QualId cl = fst(unap(DICTAP,da));
1433 Cell arg = snd(unap(DICTAP,da));
1434 preds = cons ( pair(cl,arg), preds );
1437 if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
1443 static void startGHCValue ( Int line, VarId vid, Type ty )
1447 Text v = textOf(vid);
1450 printf("begin startGHCValue %s\n", textToStr(v));
1455 if (nonNull(n) && name(n).defn != PREDEFINED) {
1456 ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
1459 if (isNull(n)) n = newName(v,NIL);
1461 ty = dictapsToQualtype(ty);
1463 tvs = ifTyvarsIn(ty);
1464 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1465 hd(tmp) = zpair(hd(tmp),STAR);
1467 ty = mkPolyType(tvsToKind(tvs),ty);
1469 ty = tvsToOffsets(line,ty,tvs);
1471 name(n).arity = arityInclDictParams(ty);
1472 name(n).line = line;
1477 static void finishGHCValue ( VarId vid )
1479 Name n = findName ( textOf(vid) );
1480 Int line = name(n).line;
1482 fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1484 assert(currentModule == name(n).mod);
1485 name(n).type = conidcellsToTycons(line,name(n).type);
1487 if (isIfaceDefaultMethodName(name(n).text)) {
1488 /* ... we need to set .parent to point to the class
1489 ... once we figure out what the class actually is :-)
1491 Type t = name(n).type;
1492 assert(isPolyType(t));
1493 if (isPolyType(t)) t = monotypeOf(t);
1494 assert(isQualType(t));
1495 t = fst(snd(t)); /* t :: [(Class,Offset)] */
1497 assert(nonNull(hd(t)));
1498 assert(isPair(hd(t)));
1499 t = fst(hd(t)); /* t :: Class */
1502 name(n).parent = t; /* phew! */
1507 /* --------------------------------------------------------------------------
1509 * ------------------------------------------------------------------------*/
1511 static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1513 /* tycon :: ConId */
1514 /* tvs :: [((VarId,Kind))] */
1516 Text t = textOf(tycon);
1518 fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1521 if (nonNull(findTycon(t))) {
1522 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1526 Tycon tc = newTycon(t);
1527 tycon(tc).line = line;
1528 tycon(tc).arity = length(tvs);
1529 tycon(tc).what = SYNONYM;
1530 tycon(tc).kind = tvsToKind(tvs);
1532 /* prepare for finishGHCSynonym */
1533 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
1538 static Void finishGHCSynonym ( ConId tyc )
1540 Tycon tc = findTycon(textOf(tyc));
1541 Int line = tycon(tc).line;
1543 fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1546 assert (currentModule == tycon(tc).mod);
1547 // setCurrModule(tycon(tc).mod);
1548 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1550 /* (ADR) ToDo: can't really do this until I've done all synonyms
1551 * and then I have to do them in order
1552 * tycon(tc).defn = fullExpand(ty);
1553 * (JRS) What?!?! i don't understand
1558 /* --------------------------------------------------------------------------
1560 * ------------------------------------------------------------------------*/
1562 static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1564 List ctx0; /* [((QConId,VarId))] */
1565 Cell tycon; /* ConId */
1566 List ktyvars; /* [((VarId,Kind))] */
1567 List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
1568 /* The Text is an optional field name
1569 The Int indicates strictness */
1570 /* ToDo: worry about being given a decl for (->) ?
1571 * and worry about qualidents for ()
1574 Type ty, resTy, selTy, conArgTy;
1575 List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
1579 Pair conArg, ctxElem;
1581 Int conArgStrictness;
1583 Text t = textOf(tycon);
1585 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1589 if (nonNull(findTycon(t))) {
1590 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1594 Tycon tc = newTycon(t);
1596 tycon(tc).line = line;
1597 tycon(tc).arity = length(ktyvars);
1598 tycon(tc).kind = tvsToKind(ktyvars);
1599 tycon(tc).what = DATATYPE;
1601 /* a list to accumulate selectors in :: [((VarId,Type))] */
1604 /* make resTy the result type of the constr, T v1 ... vn */
1606 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1607 resTy = ap(resTy,zfst(hd(tmp)));
1609 /* for each constructor ... */
1610 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1611 constr = hd(constrs);
1612 conid = zfst(constr);
1613 fields = zsnd(constr);
1615 /* Build type of constr and handle any selectors found.
1616 Also collect up tyvars occurring in the constr's arg
1617 types, so we can throw away irrelevant parts of the
1621 tyvarsMentioned = NIL;
1622 /* tyvarsMentioned :: [VarId] */
1624 conArgs = reverse(fields);
1625 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1626 conArg = hd(conArgs); /* (Type,Text) */
1627 conArgTy = zfst3(conArg);
1628 conArgNm = zsnd3(conArg);
1629 conArgStrictness = intOf(zthd3(conArg));
1630 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1632 if (conArgStrictness > 0) conArgTy = bang(conArgTy);
1633 ty = fn(conArgTy,ty);
1634 if (nonNull(conArgNm)) {
1635 /* a field name is mentioned too */
1636 selTy = fn(resTy,conArgTy);
1637 if (whatIs(tycon(tc).kind) != STAR)
1638 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1639 selTy = tvsToOffsets(line,selTy, ktyvars);
1640 sels = cons( zpair(conArgNm,selTy), sels);
1644 /* Now ty is the constructor's type, not including context.
1645 Throw away any parts of the context not mentioned in
1646 tyvarsMentioned, and use it to qualify ty.
1649 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1651 /* ctxElem :: ((QConId,VarId)) */
1652 if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1653 ctx2 = cons(ctxElem, ctx2);
1656 ty = ap(QUAL,pair(ctx2,ty));
1658 /* stick the tycon's kind on, if not simply STAR */
1659 if (whatIs(tycon(tc).kind) != STAR)
1660 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1662 ty = tvsToOffsets(line,ty, ktyvars);
1664 /* Finally, stick the constructor's type onto it. */
1665 hd(constrs) = ztriple(conid,fields,ty);
1668 /* Final result is that
1669 constrs :: [((ConId,[((Type,Text))],Type))]
1670 lists the constructors and their types
1671 sels :: [((VarId,Type))]
1672 lists the selectors and their types
1674 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1679 static List startGHCConstrs ( Int line, List cons, List sels )
1681 /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1682 /* sels :: [((VarId,Type))] */
1683 /* returns [Name] */
1685 Int conNo = length(cons)>1 ? 1 : 0;
1686 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1687 Name c = startGHCConstr(line,conNo,hd(cs));
1690 /* cons :: [Name] */
1692 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1693 hd(ss) = startGHCSel(line,hd(ss));
1695 /* sels :: [Name] */
1696 return appendOnto(cons,sels);
1700 static Name startGHCSel ( Int line, ZPair sel )
1702 /* sel :: ((VarId, Type)) */
1703 Text t = textOf(zfst(sel));
1704 Type type = zsnd(sel);
1706 Name n = findName(t);
1708 ERRMSG(line) "Repeated definition for selector \"%s\"",
1714 name(n).line = line;
1715 name(n).number = SELNAME;
1718 name(n).type = type;
1723 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1725 /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1726 /* (ADR) ToDo: add rank2 annotation and existential annotation
1727 * these affect how constr can be used.
1729 Text con = textOf(zfst3(constr));
1730 Type type = zthd3(constr);
1731 Int arity = arityFromType(type);
1732 Name n = findName(con); /* Allocate constructor fun name */
1734 n = newName(con,NIL);
1735 } else if (name(n).defn!=PREDEFINED) {
1736 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1740 name(n).arity = arity; /* Save constructor fun details */
1741 name(n).line = line;
1742 name(n).number = cfunNo(conNo);
1743 name(n).type = type;
1748 static List finishGHCDataDecl ( ConId tyc )
1751 Tycon tc = findTycon(textOf(tyc));
1753 printf ( "begin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
1755 if (isNull(tc)) internal("finishGHCDataDecl");
1757 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1759 Int line = name(n).line;
1760 assert(currentModule == name(n).mod);
1761 name(n).type = conidcellsToTycons(line,name(n).type);
1762 name(n).parent = tc; //---????
1765 return tycon(tc).defn;
1769 /* --------------------------------------------------------------------------
1771 * ------------------------------------------------------------------------*/
1773 static Void startGHCNewType ( Int line, List ctx0,
1774 ConId tycon, List tvs, Cell constr )
1776 /* ctx0 :: [((QConId,VarId))] */
1777 /* tycon :: ConId */
1778 /* tvs :: [((VarId,Kind))] */
1779 /* constr :: ((ConId,Type)) or NIL if abstract */
1782 Text t = textOf(tycon);
1784 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1789 if (nonNull(findTycon(t))) {
1790 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1794 Tycon tc = newTycon(t);
1795 tycon(tc).line = line;
1796 tycon(tc).arity = length(tvs);
1797 tycon(tc).what = NEWTYPE;
1798 tycon(tc).kind = tvsToKind(tvs);
1799 /* can't really do this until I've read in all synonyms */
1801 if (isNull(constr)) {
1802 tycon(tc).defn = NIL;
1804 /* constr :: ((ConId,Type)) */
1805 Text con = textOf(zfst(constr));
1806 Type type = zsnd(constr);
1807 Name n = findName(con); /* Allocate constructor fun name */
1809 n = newName(con,NIL);
1810 } else if (name(n).defn!=PREDEFINED) {
1811 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1815 name(n).arity = 1; /* Save constructor fun details */
1816 name(n).line = line;
1817 name(n).number = cfunNo(0);
1818 name(n).defn = nameId;
1819 tycon(tc).defn = singleton(n);
1821 /* make resTy the result type of the constr, T v1 ... vn */
1823 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1824 resTy = ap(resTy,zfst(hd(tmp)));
1825 type = fn(type,resTy);
1827 type = ap(QUAL,pair(ctx0,type));
1828 type = tvsToOffsets(line,type,tvs);
1829 name(n).type = type;
1835 static Void finishGHCNewType ( ConId tyc )
1837 Tycon tc = findTycon(textOf(tyc));
1839 printf ( "begin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
1842 if (isNull(tc)) internal("finishGHCNewType");
1844 if (isNull(tycon(tc).defn)) {
1845 /* it's an abstract type */
1847 else if (length(tycon(tc).defn) == 1) {
1848 /* As we expect, has a single constructor */
1849 Name n = hd(tycon(tc).defn);
1850 Int line = name(n).line;
1851 assert(currentModule == name(n).mod);
1852 name(n).type = conidcellsToTycons(line,name(n).type);
1854 internal("finishGHCNewType(2)");
1859 /* --------------------------------------------------------------------------
1860 * Class declarations
1861 * ------------------------------------------------------------------------*/
1863 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1865 List ctxt; /* [((QConId, VarId))] */
1866 ConId tc_name; /* ConId */
1867 List kinded_tvs; /* [((VarId, Kind))] */
1868 List mems0; { /* [((VarId, Type))] */
1870 List mems; /* [((VarId, Type))] */
1871 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1872 List tvs; /* [((VarId,Kind))] */
1873 List ns; /* [Name] */
1876 ZPair kinded_tv = hd(kinded_tvs);
1877 Text ct = textOf(tc_name);
1878 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1880 printf ( "begin startGHCClass %s\n", textToStr(ct) );
1884 if (length(kinded_tvs) != 1) {
1885 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1889 if (nonNull(findClass(ct))) {
1890 ERRMSG(line) "Repeated definition of class \"%s\"",
1893 } else if (nonNull(findTycon(ct))) {
1894 ERRMSG(line) "\"%s\" used as both class and type constructor",
1898 Class nw = newClass(ct);
1899 cclass(nw).text = ct;
1900 cclass(nw).line = line;
1901 cclass(nw).arity = 1;
1902 cclass(nw).head = ap(nw,mkOffset(0));
1903 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1904 cclass(nw).instances = NIL;
1905 cclass(nw).numSupers = length(ctxt);
1907 /* Kludge to map the single tyvar in the context to Offset 0.
1908 Need to do something better for multiparam type classes.
1910 cclass(nw).supers = tvsToOffsets(line,ctxt,
1911 singleton(kinded_tv));
1914 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1915 ZPair mem = hd(mems);
1916 Type memT = zsnd(mem);
1917 Text mnt = textOf(zfst(mem));
1920 /* Stick the new context on the member type */
1921 memT = dictapsToQualtype(memT);
1922 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1923 if (whatIs(memT)==QUAL) {
1925 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1928 pair(singleton(newCtx),memT));
1931 /* Cook up a kind for the type. */
1932 tvsInT = ifTyvarsIn(memT);
1933 /* tvsInT :: [VarId] */
1935 /* ToDo: maximally bogus. We allow the class tyvar to
1936 have the kind as supplied by the parser, but we just
1937 assume that all others have kind *. It's a kludge.
1939 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
1941 if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
1942 k = zsnd(kinded_tv); else
1944 hd(tvs) = zpair(hd(tvs),k);
1946 /* tvsIntT :: [((VarId,Kind))] */
1948 memT = mkPolyType(tvsToKind(tvsInT),memT);
1949 memT = tvsToOffsets(line,memT,tvsInT);
1951 /* Park the type back on the member */
1952 mem = zpair(zfst(mem),memT);
1954 /* Bind code to the member */
1958 "Repeated definition for class method \"%s\"",
1962 mn = newName(mnt,NIL);
1967 cclass(nw).members = mems0;
1968 cclass(nw).numMembers = length(mems0);
1971 for (mno=0; mno<cclass(nw).numSupers; mno++) {
1972 ns = cons(newDSel(nw,mno),ns);
1974 cclass(nw).dsels = rev(ns);
1979 static Class finishGHCClass ( Tycon cls_tyc )
1984 Class nw = findClass ( textOf(cls_tyc) );
1986 printf ( "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
1988 if (isNull(nw)) internal("finishGHCClass");
1990 line = cclass(nw).line;
1992 assert (currentModule == cclass(nw).mod);
1994 cclass(nw).level = 0;
1995 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
1996 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
1997 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
1999 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2000 Pair mem = hd(mems); /* (VarId, Type) */
2001 Text txt = textOf(fst(mem));
2003 Name n = findName(txt);
2006 name(n).line = cclass(nw).line;
2008 name(n).number = ctr--;
2009 name(n).arity = arityInclDictParams(name(n).type);
2010 name(n).parent = nw;
2018 /* --------------------------------------------------------------------------
2020 * ------------------------------------------------------------------------*/
2022 static Inst startGHCInstance (line,ktyvars,cls,var)
2024 List ktyvars; /* [((VarId,Kind))] */
2025 Type cls; /* Type */
2026 VarId var; { /* VarId */
2027 List tmp, tvs, ks, spec;
2032 Inst in = newInst();
2034 printf ( "begin startGHCInstance\n" );
2039 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2041 The order of tvs is important for tvsToOffsets.
2042 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2043 out of ktyvars and attach them to tvs.
2045 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2047 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2048 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2050 if (isNull(k)) internal("startGHCInstance: finding kinds");
2051 hd(xs1) = zpair(hd(xs1),k);
2054 cls = tvsToOffsets(line,cls,tvs);
2057 spec = cons(fun(cls),spec);
2060 spec = reverse(spec);
2062 inst(in).line = line;
2063 inst(in).implements = NIL;
2064 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2065 inst(in).specifics = spec;
2066 inst(in).numSpecifics = length(spec);
2067 inst(in).head = cls;
2069 /* Figure out the name of the class being instanced, and store it
2070 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2072 Cell cl = inst(in).head;
2073 assert(whatIs(cl)==DICTAP);
2074 cl = unap(DICTAP,cl);
2076 assert ( isQCon(cl) );
2081 Name b = newName( /*inventText()*/ textOf(var),NIL);
2082 name(b).line = line;
2083 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2084 name(b).number = DFUNNAME;
2085 name(b).parent = in;
2086 inst(in).builder = b;
2087 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2094 static Void finishGHCInstance ( Inst in )
2101 printf ( "begin finishGHCInstance\n" );
2104 assert (nonNull(in));
2105 line = inst(in).line;
2106 assert (currentModule==inst(in).mod);
2108 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2109 since startGHCInstance couldn't possibly have resolved it to
2110 a Class at that point. We convert it to a Class now.
2114 c = findQualClassWithoutConsultingExportList(c);
2118 inst(in).head = conidcellsToTycons(line,inst(in).head);
2119 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2120 cclass(c).instances = cons(in,cclass(c).instances);
2124 /* --------------------------------------------------------------------------
2126 * ------------------------------------------------------------------------*/
2128 /* This is called from the startGHC* functions. It traverses a structure
2129 and converts varidcells, ie, type variables parsed by the interface
2130 parser, into Offsets, which is how Hugs wants to see them internally.
2131 The Offset for a type variable is determined by its place in the list
2132 passed as the second arg; the associated kinds are irrelevant.
2134 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2137 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2138 static Type tvsToOffsets(line,type,ktyvars)
2141 List ktyvars; { /* [((VarId,Kind))] */
2142 switch (whatIs(type)) {
2149 case ZTUP2: /* convert to the untyped representation */
2150 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2151 tvsToOffsets(line,zsnd(type),ktyvars) );
2153 return ap( tvsToOffsets(line,fun(type),ktyvars),
2154 tvsToOffsets(line,arg(type),ktyvars) );
2158 tvsToOffsets(line,monotypeOf(type),ktyvars)
2162 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2163 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2164 case DICTAP: /* bogus ?? */
2165 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2166 case UNBOXEDTUP: /* bogus?? */
2167 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2168 case BANG: /* bogus?? */
2169 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2170 case VARIDCELL: /* Ha! some real work to do! */
2172 Text tv = textOf(type);
2173 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2176 assert(isZPair(hd(ktyvars)));
2177 varid = zfst(hd(ktyvars));
2179 if (tv == tt) return mkOffset(i);
2181 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2186 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2188 fprintf(stderr,"\n");
2192 return NIL; /* NOTREACHED */
2196 /* This is called from the finishGHC* functions. It traverses a structure
2197 and converts conidcells, ie, type constructors parsed by the interface
2198 parser, into Tycons (or Classes), which is how Hugs wants to see them
2199 internally. Calls to this fn have to be deferred to the second phase
2200 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2201 Tycons or Classes have been loaded into the symbol tables and can be
2204 static Type conidcellsToTycons ( Int line, Type type )
2206 switch (whatIs(type)) {
2216 { Cell t; /* Tycon or Class */
2217 Text m = qmodOf(type);
2218 Module mod = findModule(m);
2221 "Undefined module in qualified name \"%s\"",
2226 t = findQualTyconWithoutConsultingExportList(type);
2227 if (nonNull(t)) return t;
2228 t = findQualClassWithoutConsultingExportList(type);
2229 if (nonNull(t)) return t;
2231 "Undefined qualified class or type \"%s\"",
2239 cl = findQualClass(type);
2240 if (nonNull(cl)) return cl;
2241 if (textOf(type)==findText("[]"))
2242 /* a hack; magically qualify [] into PrelBase.[] */
2243 return conidcellsToTycons(line,
2244 mkQualId(mkCon(findText("PrelBase")),type));
2245 tc = findQualTycon(type);
2246 if (nonNull(tc)) return tc;
2248 "Undefined class or type constructor \"%s\"",
2254 return ap( conidcellsToTycons(line,fun(type)),
2255 conidcellsToTycons(line,arg(type)) );
2256 case ZTUP2: /* convert to std pair */
2257 return ap( conidcellsToTycons(line,zfst(type)),
2258 conidcellsToTycons(line,zsnd(type)) );
2263 conidcellsToTycons(line,monotypeOf(type))
2267 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2268 conidcellsToTycons(line,snd(snd(type)))));
2269 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2270 Not sure if this is really the right place to
2271 convert it to the form Hugs wants, but will do so anyway.
2273 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2275 Class cl = fst(unap(DICTAP,type));
2276 List args = snd(unap(DICTAP,type));
2278 conidcellsToTycons(line,pair(cl,args));
2281 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2283 return ap(BANG, conidcellsToTycons(line, snd(type)));
2285 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2288 fprintf(stderr,"\n");
2292 return NIL; /* NOTREACHED */
2296 /* Find out if a type mentions a type constructor not present in
2297 the supplied list of qualified tycons.
2299 static Bool allTypesKnown ( Type type,
2300 List aktys /* [QualId] */,
2303 switch (whatIs(type)) {
2310 return allTypesKnown(fun(type),aktys,thisMod)
2311 && allTypesKnown(arg(type),aktys,thisMod);
2313 return allTypesKnown(zfst(type),aktys,thisMod)
2314 && allTypesKnown(zsnd(type),aktys,thisMod);
2316 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2319 if (textOf(type)==findText("[]"))
2320 /* a hack; magically qualify [] into PrelBase.[] */
2321 type = mkQualId(mkCon(findText("PrelBase")),type); else
2322 type = mkQualId(thisMod,type);
2325 if (isNull(qualidIsMember(type,aktys))) goto missing;
2331 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2332 print(type,10);printf("\n");
2333 internal("allTypesKnown");
2334 return TRUE; /*notreached*/
2337 printf ( "allTypesKnown: unknown " ); print(type,10); printf("\n");
2342 /* --------------------------------------------------------------------------
2345 * None of these do lookups or require that lookups have been resolved
2346 * so they can be performed while reading interfaces.
2347 * ------------------------------------------------------------------------*/
2349 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2350 static Kinds tvsToKind(tvs)
2351 List tvs; { /* [((VarId,Kind))] */
2354 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2355 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2356 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2357 r = ap(zsnd(hd(rs)),r);
2363 static Int arityInclDictParams ( Type type )
2366 if (isPolyType(type)) type = monotypeOf(type);
2368 if (whatIs(type) == QUAL)
2370 arity += length ( fst(snd(type)) );
2371 type = snd(snd(type));
2373 while (isAp(type) && getHead(type)==typeArrow) {
2380 /* arity of a constructor with this type */
2381 static Int arityFromType(type)
2384 if (isPolyType(type)) {
2385 type = monotypeOf(type);
2387 if (whatIs(type) == QUAL) {
2388 type = snd(snd(type));
2390 if (whatIs(type) == EXIST) {
2391 type = snd(snd(type));
2393 if (whatIs(type)==RANK2) {
2394 type = snd(snd(type));
2396 while (isAp(type) && getHead(type)==typeArrow) {
2404 /* ifTyvarsIn :: Type -> [VarId]
2405 The returned list has no duplicates -- is a set.
2407 static List ifTyvarsIn(type)
2409 List vs = typeVarsIn(type,NIL,NIL,NIL);
2411 for (; nonNull(vs2); vs2=tl(vs2))
2412 if (whatIs(hd(vs2)) != VARIDCELL)
2413 internal("ifTyvarsIn");
2419 /* --------------------------------------------------------------------------
2420 * General object symbol query stuff
2421 * ------------------------------------------------------------------------*/
2423 #define EXTERN_SYMS \
2424 Sym(stg_gc_enter_1) \
2425 Sym(stg_gc_noregs) \
2433 Sym(stg_update_PAP) \
2434 Sym(stg_error_entry) \
2435 Sym(__ap_2_upd_info) \
2436 Sym(__ap_3_upd_info) \
2437 Sym(__ap_4_upd_info) \
2438 Sym(__ap_5_upd_info) \
2439 Sym(__ap_6_upd_info) \
2440 Sym(__ap_7_upd_info) \
2441 Sym(__ap_8_upd_info) \
2442 Sym(__sel_0_upd_info) \
2443 Sym(__sel_1_upd_info) \
2444 Sym(__sel_2_upd_info) \
2445 Sym(__sel_3_upd_info) \
2446 Sym(__sel_4_upd_info) \
2447 Sym(__sel_5_upd_info) \
2448 Sym(__sel_6_upd_info) \
2449 Sym(__sel_7_upd_info) \
2450 Sym(__sel_8_upd_info) \
2451 Sym(__sel_9_upd_info) \
2452 Sym(__sel_10_upd_info) \
2453 Sym(__sel_11_upd_info) \
2454 Sym(__sel_12_upd_info) \
2456 Sym(Upd_frame_info) \
2457 Sym(seq_frame_info) \
2458 Sym(CAF_BLACKHOLE_info) \
2459 Sym(IND_STATIC_info) \
2460 Sym(EMPTY_MVAR_info) \
2461 Sym(MUT_ARR_PTRS_FROZEN_info) \
2463 Sym(putMVarzh_fast) \
2464 Sym(newMVarzh_fast) \
2465 Sym(takeMVarzh_fast) \
2470 Sym(killThreadzh_fast) \
2471 Sym(waitReadzh_fast) \
2472 Sym(waitWritezh_fast) \
2473 Sym(CHARLIKE_closure) \
2474 Sym(INTLIKE_closure) \
2475 Sym(suspendThread) \
2477 Sym(stackOverflow) \
2478 Sym(int2Integerzh_fast) \
2479 Sym(stg_gc_unbx_r1) \
2481 Sym(makeForeignObjzh_fast) \
2482 Sym(__encodeDouble) \
2483 Sym(decodeDoublezh_fast) \
2485 Sym(isDoubleInfinite) \
2486 Sym(isDoubleDenormalized) \
2487 Sym(isDoubleNegativeZero) \
2488 Sym(__encodeFloat) \
2489 Sym(decodeFloatzh_fast) \
2491 Sym(isFloatInfinite) \
2492 Sym(isFloatDenormalized) \
2493 Sym(isFloatNegativeZero) \
2494 Sym(__int_encodeFloat) \
2495 Sym(__int_encodeDouble) \
2499 Sym(gcdIntegerzh_fast) \
2500 Sym(newArrayzh_fast) \
2501 Sym(unsafeThawArrayzh_fast) \
2502 Sym(newDoubleArrayzh_fast) \
2503 Sym(newFloatArrayzh_fast) \
2504 Sym(newAddrArrayzh_fast) \
2505 Sym(newWordArrayzh_fast) \
2506 Sym(newIntArrayzh_fast) \
2507 Sym(newCharArrayzh_fast) \
2508 Sym(newMutVarzh_fast) \
2509 Sym(quotRemIntegerzh_fast) \
2510 Sym(quotIntegerzh_fast) \
2511 Sym(remIntegerzh_fast) \
2512 Sym(divExactIntegerzh_fast) \
2513 Sym(divModIntegerzh_fast) \
2514 Sym(timesIntegerzh_fast) \
2515 Sym(minusIntegerzh_fast) \
2516 Sym(plusIntegerzh_fast) \
2517 Sym(addr2Integerzh_fast) \
2518 Sym(mkWeakzh_fast) \
2521 Sym(resetNonBlockingFd) \
2523 Sym(stable_ptr_table) \
2524 Sym(createAdjThunk) \
2526 /* needed by libHS_cbits */ \
2528 Sym(__errno_location) \
2573 Sym(shutdownHaskellAndExit) \
2576 /* AJG Hack; for the moment, make EXTERN_SYMS vanish on Win32 */
2582 /* entirely bogus claims about types of these symbols */
2583 #define Sym(vvv) extern int vvv;
2584 #define SymX(vvv) /* nothing */
2589 #define Sym(vvv) { #vvv, &vvv },
2590 #define SymX(vvv) { #vvv, &vvv },
2599 static void* lookupObjName ( char* nm )
2609 strncpy(nm2,nm,200);
2611 /* first see if it's an RTS name */
2612 for (k = 0; rtsTab[k].nm; k++)
2613 if (0==strcmp(nm2,rtsTab[k].nm))
2614 return rtsTab[k].ad;
2616 /* perhaps an extra-symbol ? */
2617 a = lookupOExtraTabName ( nm );
2620 /* if not an RTS name, look in the
2621 relevant module's object symbol table
2623 pp = strchr(nm2, '_');
2624 if (!pp || !isupper(nm2[0])) goto not_found;
2626 t = unZcodeThenFindText(nm2);
2628 if (isNull(m)) goto not_found;
2630 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2635 "lookupObjName: can't resolve name `%s'\n",
2642 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2644 OSectionKind sk = lookupSection(p);
2645 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2646 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2650 int is_dynamically_loaded_rwdata_ptr ( char* p )
2652 OSectionKind sk = lookupSection(p);
2653 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2654 return (sk == HUGS_SECTIONKIND_RWDATA);
2658 int is_not_dynamically_loaded_ptr ( char* p )
2660 OSectionKind sk = lookupSection(p);
2661 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2662 return (sk == HUGS_SECTIONKIND_OTHER);
2666 /* --------------------------------------------------------------------------
2668 * ------------------------------------------------------------------------*/
2670 Void interface(what)
2673 case POSTPREL: break;
2677 ifaces_outstanding = NIL;
2680 mark(ifaces_outstanding);
2685 /*-------------------------------------------------------------------------*/