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/05/26 10:14:33 $
12 * ------------------------------------------------------------------------*/
14 #include "hugsbasictypes.h"
20 #include "Rts.h" /* to make StgPtr visible in Assembler.h */
21 #include "Assembler.h" /* for wrapping GHC objects */
23 /*#define DEBUG_IFACE*/
26 /* --------------------------------------------------------------------------
27 * (This comment is now out of date. JRS, 991216).
28 * The "addGHC*" functions act as "impedence matchers" between GHC
29 * interface files and Hugs. Their main job is to convert abstract
30 * syntax trees into Hugs' internal representations.
32 * The main trick here is how we deal with mutually recursive interface
35 * o As we read an import decl, we add it to a list of required imports
36 * (unless it's already loaded, of course).
38 * o Processing of declarations is split into two phases:
40 * 1) While reading the interface files, we construct all the Names,
41 * Tycons, etc declared in the interface file but we don't try to
42 * resolve references to any entities the declaration mentions.
44 * This is done by the "addGHC*" functions.
46 * 2) After reading all the interface files, we finish processing the
47 * declarations by resolving any references in the declarations
48 * and doing any other processing that may be required.
50 * This is done by the "finishGHC*" functions which use the
51 * "fixup*" functions to assist them.
53 * The interface between these two phases are the "ghc*Decls" which
54 * contain lists of decls that haven't been completed yet.
56 * ------------------------------------------------------------------------*/
60 New comment, 991216, explaining roughly how it all works.
61 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
63 Interfaces can contain references to unboxed types, and these need to
64 be handled carefully. The following is a summary of how the interface
65 loader now works. It is applied to groups of interfaces simultaneously,
66 viz, the entire Prelude at once:
68 0. Parse interfaces, chasing imports until a complete
69 strongly-connected-component of ifaces has been parsed.
70 All interfaces in this scc are processed together, in
73 1. Throw away any entity not mentioned in the export lists.
75 2. Delete type (not data or newtype) definitions which refer to
76 unknown types in their right hand sides. Because Hugs doesn't
77 know of any unboxed types, this has the side effect of removing
78 all type defns referring to unboxed types. Repeat step 2 until
79 a fixed point is reached.
81 3. Make abstract all data/newtype defns which refer to an unknown
82 type. eg, data Word = MkW Word# becomes data Word, because
83 Word# is unknown. Hugs is happy to know about abstract boxed
84 Words, but not about Word#s.
86 4. Step 2 could delete types referred to by values, instances and
87 classes. So filter all entities, and delete those referring to
88 unknown types _or_ classes. This could cause other entities
89 to become invalid, so iterate step 4 to a fixed point.
91 After step 4, the interfaces no longer contain anything
94 5. Steps 1-4 operate purely on the iface syntax trees. We now start
95 creating symbol table entries. First, create a module table
96 entry for each interface, and locate and read in the corresponding
97 object file. This is done by the startGHCModule function.
99 6. Traverse all interfaces. For each entity, create an entry in
100 the name, tycon, class or instance table, and fill in relevant
101 fields, but do not attempt to link tycon/class/instance/name uses
102 to their symbol table entries. This is done by the startGHC*
105 7. Revisit all symbol table entries created in step 6. We should
106 now be able to replace all references to tycons/classes/instances/
107 names with the relevant symbol table entries. This is done by
108 the finishGHC* functions.
110 8. Traverse all interfaces. For each iface, examine the export lists
111 and use it to build export lists in the module table. Do the
112 implicit 'import Prelude' thing if necessary. Finally, resolve
113 references in the object code for this module. This is done
114 by the finishGHCModule function.
117 /* --------------------------------------------------------------------------
118 * local function prototypes:
119 * ------------------------------------------------------------------------*/
121 static Void startGHCValue ( Int,VarId,Type );
122 static Void finishGHCValue ( VarId );
124 static Void startGHCSynonym ( Int,Cell,List,Type );
125 static Void finishGHCSynonym ( Tycon );
127 static Void startGHCClass ( Int,List,Cell,List,List );
128 static Class finishGHCClass ( Class );
130 static Inst startGHCInstance ( Int,List,Pair,VarId );
131 static Void finishGHCInstance ( Inst );
133 static Void startGHCImports ( ConId,List );
134 static Void finishGHCImports ( ConId,List );
136 static Void startGHCExports ( ConId,List );
137 static Void finishGHCExports ( ConId,List );
139 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
141 static Void finishGHCModule ( Cell );
142 static Void startGHCModule ( Text );
144 static Void startGHCDataDecl ( Int,List,Cell,List,List );
145 static List finishGHCDataDecl ( ConId tyc );
146 /* Supporting stuff for {start|finish}GHCDataDecl */
147 static List startGHCConstrs ( Int,List,List );
148 static Name startGHCSel ( Int,Pair );
149 static Name startGHCConstr ( Int,Int,Triple );
151 static Void startGHCNewType ( Int,List,Cell,List,Cell );
152 static Void finishGHCNewType ( ConId tyc );
156 static Kinds tvsToKind ( List );
157 static Int arityFromType ( Type );
158 static Int arityInclDictParams ( Type );
159 static Bool allTypesKnown ( Type type,
160 List aktys /* [QualId] */,
163 static List ifTyvarsIn ( Type );
164 static Type tvsToOffsets ( Int,Type,List );
165 static Type conidcellsToTycons ( Int,Type );
171 /* --------------------------------------------------------------------------
172 * Top-level interface processing
173 * ------------------------------------------------------------------------*/
175 /* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
176 static ConVarId getIEntityName ( Cell c )
179 case I_IMPORT: return NIL;
180 case I_INSTIMPORT: return NIL;
181 case I_EXPORT: return NIL;
182 case I_FIXDECL: return zthd3(unap(I_FIXDECL,c));
183 case I_INSTANCE: return NIL;
184 case I_TYPE: return zsel24(unap(I_TYPE,c));
185 case I_DATA: return zsel35(unap(I_DATA,c));
186 case I_NEWTYPE: return zsel35(unap(I_NEWTYPE,c));
187 case I_CLASS: return zsel35(unap(I_CLASS,c));
188 case I_VALUE: return zsnd3(unap(I_VALUE,c));
189 default: internal("getIEntityName");
194 /* Filter the contents of an interface, using the supplied predicate.
195 For flexibility, the predicate is passed as a second arg the value
196 extraArgs. This is a hack to get round the lack of partial applications
197 in C. Pred should not have any side effects. The dumpaction param
198 gives us the chance to print a message or some such for dumped items.
199 When a named entity is deleted, filterInterface also deletes the name
202 static Cell filterInterface ( Cell root,
203 Bool (*pred)(Cell,Cell),
205 Void (*dumpAction)(Cell) )
208 Cell iface = unap(I_INTERFACE,root);
210 List deleted_ids = NIL; /* :: [ConVarId] */
212 for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
213 if (pred(hd(tops),extraArgs)) {
214 tops2 = cons( hd(tops), tops2 );
216 ConVarId deleted_id = getIEntityName ( hd(tops) );
217 if (nonNull(deleted_id))
218 deleted_ids = cons ( deleted_id, deleted_ids );
220 dumpAction ( hd(tops) );
223 tops2 = reverse(tops2);
225 /* Clean up the export list now. */
226 for (tops=tops2; nonNull(tops); tops=tl(tops)) {
227 if (whatIs(hd(tops))==I_EXPORT) {
228 Cell exdecl = unap(I_EXPORT,hd(tops));
229 List exlist = zsnd(exdecl);
231 for (; nonNull(exlist); exlist=tl(exlist)) {
232 Cell ex = hd(exlist);
233 ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
234 assert (isCon(exid) || isVar(exid));
235 if (!varIsMember(textOf(exid),deleted_ids))
236 exlist2 = cons(ex, exlist2);
238 hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
242 return ap(I_INTERFACE, zpair(zfst(iface),tops2));
246 List /* of CONID */ getInterfaceImports ( Cell iface )
251 for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
252 if (whatIs(hd(tops)) == I_IMPORT) {
253 ZPair imp_decl = unap(I_IMPORT,hd(tops));
254 ConId m_to_imp = zfst(imp_decl);
255 if (textOf(m_to_imp) != findText("PrelGHC")) {
256 imports = cons(m_to_imp,imports);
258 fprintf(stderr, "add iface %s\n",
259 textToStr(textOf(m_to_imp)));
267 /* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
268 static List getExportDeclsInIFace ( Cell root )
270 Cell iface = unap(I_INTERFACE,root);
271 List decls = zsnd(iface);
274 for (ds=decls; nonNull(ds); ds=tl(ds))
275 if (whatIs(hd(ds))==I_EXPORT)
276 exports = cons(hd(ds), exports);
281 /* Does t start with "$dm" ? */
282 static Bool isIfaceDefaultMethodName ( Text t )
284 String s = textToStr(t);
285 return (s && s[0]=='$' && s[1]=='d' && s[2]=='m' && s[3]);
289 static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
291 /* ife :: I_IMPORT..I_VALUE */
292 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
298 ConVarId ife_id = getIEntityName ( ife );
300 if (isNull(ife_id)) return TRUE;
302 tnm = textOf(ife_id);
304 /* Don't junk default methods, even tho the export list doesn't
307 if (isIfaceDefaultMethodName(tnm)) goto retain;
309 /* for each export list ... */
310 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
311 exlist = hd(exlist_list);
313 /* for each entity in an export list ... */
314 for (t=exlist; nonNull(t); t=tl(t)) {
315 if (isZPair(hd(t))) {
316 /* A pair, which means an export entry
317 of the form ClassName(foo,bar). */
318 List subents = cons(zfst(hd(t)),zsnd(hd(t)));
319 for (; nonNull(subents); subents=tl(subents))
320 if (textOf(hd(subents)) == tnm) goto retain;
322 /* Single name in the list. */
323 if (textOf(hd(t)) == tnm) goto retain;
329 fprintf ( stderr, " dump %s\n", textToStr(tnm) );
335 fprintf ( stderr, " retain %s\n", textToStr(tnm) );
341 static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
343 /* ife_id :: ConId */
344 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
349 assert (isCon(ife_id));
350 tnm = textOf(ife_id);
352 /* for each export list ... */
353 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
354 exlist = hd(exlist_list);
356 /* for each entity in an export list ... */
357 for (t=exlist; nonNull(t); t=tl(t)) {
358 if (isZPair(hd(t))) {
359 /* A pair, which means an export entry
360 of the form ClassName(foo,bar). */
361 if (textOf(zfst(hd(t))) == tnm) return FALSE;
363 if (textOf(hd(t)) == tnm) return TRUE;
367 internal("isExportedAbstractly");
368 return FALSE; /*notreached*/
372 /* Remove entities not mentioned in any of the export lists. */
373 static Cell deleteUnexportedIFaceEntities ( Cell root )
375 Cell iface = unap(I_INTERFACE,root);
376 ConId iname = zfst(iface);
377 List decls = zsnd(iface);
379 List exlist_list = NIL;
383 fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
386 exlist_list = getExportDeclsInIFace ( root );
387 /* exlist_list :: [I_EXPORT] */
389 for (t=exlist_list; nonNull(t); t=tl(t))
390 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
391 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
394 if (isNull(exlist_list)) {
395 ERRMSG(0) "Can't find any export lists in interface file"
400 return filterInterface ( root, isExportedIFaceEntity,
405 /* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
406 static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
408 Cell iface = unap(I_INTERFACE,root);
409 Text mname = textOf(zfst(iface));
410 List defns = zsnd(iface);
411 for (; nonNull(defns); defns = tl(defns)) {
412 Cell defn = hd(defns);
413 Cell what = whatIs(defn);
414 if (what==I_TYPE || what==I_DATA
415 || what==I_NEWTYPE || what==I_CLASS) {
416 QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
417 if (!qualidIsMember ( q, aktys ))
418 aktys = cons ( q, aktys );
425 static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
427 ConVarId id = getIEntityName ( entity );
430 "dumping %s because of unknown type(s)\n",
431 isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
436 /* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
437 /* mod is the current module being processed -- so we can qualify unqual'd
438 names. Strange calling convention for aktys and mod is so we can call this
439 from filterInterface.
441 static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
444 List aktys = zfst ( aktys_mod );
445 ConId mod = zsnd ( aktys_mod );
446 switch (whatIs(entity)) {
453 Cell inst = unap(I_INSTANCE,entity);
454 List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
455 Type cls = zsel35 ( inst ); /* :: Type */
456 for (t = ctx; nonNull(t); t=tl(t))
457 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
458 if (!allTypesKnown(cls, aktys,mod)) return FALSE;
462 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
464 Cell data = unap(I_DATA,entity);
465 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
466 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
467 for (t = ctx; nonNull(t); t=tl(t))
468 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
469 for (t = constrs; nonNull(t); t=tl(t))
470 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
471 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
475 Cell newty = unap(I_NEWTYPE,entity);
476 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
477 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
478 for (t = ctx; nonNull(t); t=tl(t))
479 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
481 && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
485 Cell klass = unap(I_CLASS,entity);
486 List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
487 List sigs = zsel55(klass); /* :: [((VarId,Type))] */
488 for (t = ctx; nonNull(t); t=tl(t))
489 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
490 for (t = sigs; nonNull(t); t=tl(t))
491 if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
495 return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
497 internal("ifentityAllTypesKnown");
502 /* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
503 /* mod is the current module being processed -- so we can qualify unqual'd
504 names. Strange calling convention for aktys and mod is so we can call this
505 from filterInterface.
507 static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
510 List aktys = zfst ( aktys_mod );
511 ConId mod = zsnd ( aktys_mod );
512 if (whatIs(entity) != I_TYPE) {
515 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
520 static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
522 ConVarId id = getIEntityName ( entity );
523 assert (whatIs(entity)==I_TYPE);
527 "dumping type %s because of unknown tycon(s)\n",
528 textToStr(textOf(id)) );
533 /* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
535 static List abstractifyExDecl ( Cell root, ConId toabs )
537 ZPair exdecl = unap(I_EXPORT,root);
538 List exlist = zsnd(exdecl);
540 for (; nonNull(exlist); exlist = tl(exlist)) {
541 if (isZPair(hd(exlist))
542 && textOf(toabs) == textOf(zfst(hd(exlist)))) {
543 /* it's toabs, exported non-abstractly */
544 res = cons ( zfst(hd(exlist)), res );
546 res = cons ( hd(exlist), res );
549 return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
553 static Void ppModule ( Text modt )
556 fflush(stderr); fflush(stdout);
557 fprintf(stderr, "---------------- MODULE %s ----------------\n",
563 static void* ifFindItblFor ( Name n )
565 /* n is a constructor for which we want to find the GHC info table.
566 First look for a _con_info symbol. If that doesn't exist, _and_
567 this is a nullary constructor, then it's safe to look for the
568 _static_info symbol instead.
574 sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_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 if (name(n).arity == 0) {
583 sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"),
584 textToStr( module(name(n).mod).text ),
585 textToStr( name(n).text ) );
586 t = enZcodeThenFindText(buf);
587 p = lookupOTabName ( name(n).mod, textToStr(t) );
591 ERRMSG(0) "Can't find info table %s", textToStr(t)
596 void ifLinkConstrItbl ( Name n )
598 /* name(n) is either a constructor or a field name.
599 If the latter, ignore it. If it is a non-nullary constructor,
600 find its info table in the object code. If it's nullary,
601 we can skip the info table, since all accesses will go via
604 if (islower(textToStr(name(n).text)[0])) return;
605 if (name(n).arity == 0) return;
606 name(n).itbl = ifFindItblFor(n);
610 static void ifSetClassDefaultsAndDCon ( Class c )
618 List defs; /* :: [Name] */
619 List mems; /* :: [Name] */
621 assert(isNull(cclass(c).defaults));
623 /* Create the defaults list by more-or-less cloning the members list. */
625 for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
627 s = textToStr( name(hd(mems)).text );
628 assert(strlen(s) < 95);
630 n = findNameInAnyModule(findText(buf));
635 cclass(c).defaults = defs;
637 /* Create a name table entry for the dictionary datacon.
638 Interface files don't mention them, so it had better not
642 s = textToStr( cclass(c).text );
643 assert( strlen(s) < 96 );
646 n = findNameInAnyModule(t);
652 name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
653 name(n).number = cfunNo(0);
656 /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
657 Because this happens right at the end of loading, we know
658 that we should actually be able to find the symbol in this
659 module's object symbol table. Except that if the dictionary
660 has arity 1, we don't bother, since it will be represented as
661 a newtype and not as a data, so its itbl can remain NULL.
663 if (name(n).arity == 1) {
665 name(n).defn = nameId;
667 p = ifFindItblFor ( n );
673 void processInterfaces ( List /* of CONID */ iface_modnames )
684 List all_known_types;
686 List cls_list; /* :: List Class */
687 List constructor_list; /* :: List Name */
689 List ifaces = NIL; /* :: List I_INTERFACE */
691 if (isNull(iface_modnames)) return;
695 "processInterfaces: %d interfaces to process\n",
696 length(ifaces_outstanding) );
699 for (xs = iface_modnames; nonNull(xs); xs=tl(xs)) {
700 mod = findModule(textOf(hd(xs)));
701 assert(nonNull(mod));
702 assert(module(mod).mode == FM_OBJECT);
703 ifaces = cons ( module(mod).tree, ifaces );
705 ifaces = reverse(ifaces);
707 /* Clean up interfaces -- dump non-exported value, class, type decls */
708 for (xs = ifaces; nonNull(xs); xs = tl(xs))
709 hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
712 /* Iteratively delete any type declarations which refer to unknown
715 num_known_types = 999999999;
719 /* Construct a list of all known tycons. This is a list of QualIds.
720 Unfortunately it also has to contain all known class names, since
721 allTypesKnown cannot distinguish between tycons and classes -- a
722 deficiency of the iface abs syntax.
724 all_known_types = getAllKnownTyconsAndClasses();
725 for (xs = ifaces; nonNull(xs); xs=tl(xs))
727 = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
729 /* Have we reached a fixed point? */
730 i = length(all_known_types);
733 "\n============= %d known types =============\n", i );
735 if (num_known_types == i) break;
738 /* Delete all entities which refer to unknown tycons. */
739 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
740 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
741 assert(nonNull(mod));
742 hd(xs) = filterInterface ( hd(xs),
743 ifTypeDoesntRefUnknownTycon,
744 zpair(all_known_types,mod),
745 ifTypeDoesntRefUnknownTycon_dumpmsg );
749 /* Now abstractify any datas and newtypes which refer to unknown tycons
750 -- including, of course, the type decls just deleted.
752 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
753 List absify = NIL; /* :: [ConId] */
754 ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
755 ConId mod = zfst(iface);
756 List aktys = all_known_types; /* just a renaming */
760 /* Compute into absify the list of all ConIds (tycons) we need to
763 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
765 Bool allKnown = TRUE;
767 if (whatIs(ent)==I_DATA) {
768 Cell data = unap(I_DATA,ent);
769 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
770 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
771 for (t = ctx; nonNull(t); t=tl(t))
772 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
773 for (t = constrs; nonNull(t); t=tl(t))
774 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
775 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
777 else if (whatIs(ent)==I_NEWTYPE) {
778 Cell newty = unap(I_NEWTYPE,ent);
779 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
780 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
781 for (t = ctx; nonNull(t); t=tl(t))
782 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
783 if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
787 absify = cons ( getIEntityName(ent), absify );
790 "abstractifying %s because it uses an unknown type\n",
791 textToStr(textOf(getIEntityName(ent))) );
796 /* mark in exports as abstract all names in absify (modifies iface) */
797 for (; nonNull(absify); absify=tl(absify)) {
798 ConId toAbs = hd(absify);
799 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
800 if (whatIs(hd(es)) != I_EXPORT) continue;
801 hd(es) = abstractifyExDecl ( hd(es), toAbs );
805 /* For each data/newtype in the export list marked as abstract,
806 remove the constructor lists. This catches all abstractification
807 caused by the code above, and it also catches tycons which really
808 were exported abstractly.
811 exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
812 /* exlist_list :: [I_EXPORT] */
813 for (t=exlist_list; nonNull(t); t=tl(t))
814 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
815 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
817 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
819 if (whatIs(ent)==I_DATA
820 && isExportedAbstractly ( getIEntityName(ent),
822 Cell data = unap(I_DATA,ent);
823 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
824 zsel45(data), NIL /* the constr list */ );
825 hd(es) = ap(I_DATA,data);
827 fprintf(stderr, "abstractify data %s\n",
828 textToStr(textOf(getIEntityName(ent))) );
831 else if (whatIs(ent)==I_NEWTYPE
832 && isExportedAbstractly ( getIEntityName(ent),
834 Cell data = unap(I_NEWTYPE,ent);
835 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
836 zsel45(data), NIL /* the constr-type pair */ );
837 hd(es) = ap(I_NEWTYPE,data);
839 fprintf(stderr, "abstractify newtype %s\n",
840 textToStr(textOf(getIEntityName(ent))) );
845 /* We've finally finished mashing this iface. Update the iface list. */
846 hd(xs) = ap(I_INTERFACE,iface);
850 /* At this point, the interfaces are cleaned up so that no type, data or
851 newtype defn refers to a non-existant type. However, there still may
852 be value defns, classes and instances which refer to unknown types.
853 Delete iteratively until a fixed point is reached.
856 fprintf(stderr,"\n");
858 num_known_types = 999999999;
862 /* Construct a list of all known tycons. This is a list of QualIds.
863 Unfortunately it also has to contain all known class names, since
864 allTypesKnown cannot distinguish between tycons and classes -- a
865 deficiency of the iface abs syntax.
867 all_known_types = getAllKnownTyconsAndClasses();
868 for (xs = ifaces; nonNull(xs); xs=tl(xs))
869 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
871 /* Have we reached a fixed point? */
872 i = length(all_known_types);
875 "\n------------- %d known types -------------\n", i );
877 if (num_known_types == i) break;
880 /* Delete all entities which refer to unknown tycons. */
881 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
882 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
883 assert(nonNull(mod));
885 hd(xs) = filterInterface ( hd(xs),
886 ifentityAllTypesKnown,
887 zpair(all_known_types,mod),
888 ifentityAllTypesKnown_dumpmsg );
893 /* Allocate module table entries and read in object code. */
894 for (xs=ifaces; nonNull(xs); xs=tl(xs))
895 startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))) );
898 /* Now work through the decl lists of the modules, and call the
899 startGHC* functions on the entities. This creates names in
900 various tables but doesn't bind them to anything.
903 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
904 iface = unap(I_INTERFACE,hd(xs));
905 mname = textOf(zfst(iface));
906 mod = findModule(mname);
907 if (isNull(mod)) internal("processInterfaces(4)");
909 ppModule ( module(mod).text );
911 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
912 Cell decl = hd(decls);
913 switch(whatIs(decl)) {
915 Cell exdecl = unap(I_EXPORT,decl);
916 startGHCExports ( zfst(exdecl), zsnd(exdecl) );
920 Cell imdecl = unap(I_IMPORT,decl);
921 startGHCImports ( zfst(imdecl), zsnd(imdecl) );
928 /* Trying to find the instance table location allocated by
929 startGHCInstance in subsequent processing is a nightmare, so
930 cache it on the tree.
932 Cell instance = unap(I_INSTANCE,decl);
933 Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
934 zsel35(instance), zsel45(instance) );
935 hd(decls) = ap(I_INSTANCE,
936 z5ble( zsel15(instance), zsel25(instance),
937 zsel35(instance), zsel45(instance), in ));
941 Cell tydecl = unap(I_TYPE,decl);
942 startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
943 zsel34(tydecl), zsel44(tydecl) );
947 Cell ddecl = unap(I_DATA,decl);
948 startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
949 zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
953 Cell ntdecl = unap(I_NEWTYPE,decl);
954 startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
955 zsel35(ntdecl), zsel45(ntdecl),
960 Cell klass = unap(I_CLASS,decl);
961 startGHCClass ( zsel15(klass), zsel25(klass),
962 zsel35(klass), zsel45(klass),
967 Cell value = unap(I_VALUE,decl);
968 startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
972 internal("processInterfaces(1)");
978 fprintf(stderr, "\n============================"
979 "=============================\n");
980 fprintf(stderr, "=============================="
981 "===========================\n");
984 /* Traverse again the decl lists of the modules, this time
985 calling the finishGHC* functions. But don't process
986 the export lists; those must wait for later.
989 constructor_list = NIL;
990 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
991 iface = unap(I_INTERFACE,hd(xs));
992 mname = textOf(zfst(iface));
993 mod = findModule(mname);
994 if (isNull(mod)) internal("processInterfaces(3)");
996 ppModule ( module(mod).text );
998 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
999 Cell decl = hd(decls);
1000 switch(whatIs(decl)) {
1008 Cell fixdecl = unap(I_FIXDECL,decl);
1009 finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
1013 Cell instance = unap(I_INSTANCE,decl);
1014 finishGHCInstance ( zsel55(instance) );
1018 Cell tydecl = unap(I_TYPE,decl);
1019 finishGHCSynonym ( zsel24(tydecl) );
1023 Cell ddecl = unap(I_DATA,decl);
1024 List constrs = finishGHCDataDecl ( zsel35(ddecl) );
1025 constructor_list = dupOnto ( constrs, constructor_list );
1029 Cell ntdecl = unap(I_NEWTYPE,decl);
1030 finishGHCNewType ( zsel35(ntdecl) );
1034 Cell klass = unap(I_CLASS,decl);
1035 Class cls = finishGHCClass ( zsel35(klass) );
1036 cls_list = cons(cls,cls_list);
1040 Cell value = unap(I_VALUE,decl);
1041 finishGHCValue ( zsnd3(value) );
1045 internal("processInterfaces(2)");
1050 fprintf(stderr, "\n+++++++++++++++++++++++++++++"
1051 "++++++++++++++++++++++++++++\n");
1052 fprintf(stderr, "+++++++++++++++++++++++++++++++"
1053 "++++++++++++++++++++++++++\n");
1056 /* Build the module(m).export lists for each module, by running
1057 through the export lists in the iface. Also, do the implicit
1058 'import Prelude' thing. And finally, do the object code
1061 for (xs = ifaces; nonNull(xs); xs = tl(xs))
1062 finishGHCModule(hd(xs));
1064 mapProc(visitClass,cls_list);
1065 mapProc(ifSetClassDefaultsAndDCon,cls_list);
1066 mapProc(ifLinkConstrItbl,constructor_list);
1069 ifaces_outstanding = NIL;
1073 /* --------------------------------------------------------------------------
1075 * ------------------------------------------------------------------------*/
1077 static void startGHCModule_errMsg ( char* msg )
1079 fprintf ( stderr, "object error: %s\n", msg );
1082 static void* startGHCModule_clientLookup ( char* sym )
1085 /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
1087 return lookupObjName ( sym );
1090 static int /*Bool*/ startGHCModule_clientWantsSymbol ( char* sym )
1092 if (strcmp(sym,"ghc_cc_ID")==0) return 0;
1096 static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
1099 = ocNew ( startGHCModule_errMsg,
1100 startGHCModule_clientLookup,
1101 startGHCModule_clientWantsSymbol,
1105 ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
1108 if (!ocLoadImage(oc,VERBOSE)) {
1109 ERRMSG(0) "Reading of object file \"%s\" failed", objNm
1112 if (!ocVerifyImage(oc,VERBOSE)) {
1113 ERRMSG(0) "Validation of object file \"%s\" failed", objNm
1116 if (!ocGetNames(oc,VERBOSE)) {
1117 ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
1123 static Void startGHCModule ( Text mname )
1126 Module m = findModule(mname);
1130 fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
1131 textToStr(mname), module(m).objSize );
1134 module(m).fake = FALSE;
1136 /* Get hold of the primary object for the module. */
1138 = startGHCModule_partial_load ( textToStr(module(m).objName),
1139 module(m).objSize );
1141 /* and any extras ... */
1142 for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
1146 String nm = getExtraObjectInfo (
1147 textToStr(module(m).objName),
1152 ERRMSG(0) "Can't find extra object file \"%s\"", nm
1155 oc = startGHCModule_partial_load ( nm, size );
1156 oc->next = module(m).objectExtras;
1157 module(m).objectExtras = oc;
1162 /* For the module mod, augment both the export environment (.exports)
1163 and the eval environment (.names, .tycons, .classes)
1164 with the symbols mentioned in exlist. We don't actually need
1165 to modify the names, tycons, classes or instances in the eval
1166 environment, since previous processing of the
1167 top-level decls in the iface should have done this already.
1169 mn is the module mentioned in the export list; it is the "original"
1170 module for the symbols in the export list. We should also record
1171 this info with the symbols, since references to object code need to
1172 refer to the original module in which a symbol was defined, rather
1173 than to some module it has been imported into and then re-exported.
1175 We take the policy that if something mentioned in an export list
1176 can't be found in the symbol tables, it is simply ignored. After all,
1177 previous processing of the iface syntax trees has already removed
1178 everything which Hugs can't handle, so if there is mention of these
1179 things still lurking in export lists somewhere, about the only thing
1180 to do is to ignore it.
1182 Also do an implicit 'import Prelude' thingy for the module,
1187 static Void finishGHCModule ( Cell root )
1189 /* root :: I_INTERFACE */
1190 Cell iface = unap(I_INTERFACE,root);
1191 ConId iname = zfst(iface);
1192 Module mod = findModule(textOf(iname));
1193 List exlist_list = NIL;
1198 fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1201 if (isNull(mod)) internal("finishExports(1)");
1204 exlist_list = getExportDeclsInIFace ( root );
1205 /* exlist_list :: [I_EXPORT] */
1207 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1208 ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
1209 ConId exmod = zfst(exdecl);
1210 List exlist = zsnd(exdecl);
1211 /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1213 for (; nonNull(exlist); exlist=tl(exlist)) {
1218 Cell ex = hd(exlist);
1220 switch (whatIs(ex)) {
1222 case VARIDCELL: /* variable */
1223 q = mkQualId(exmod,ex);
1224 c = findQualNameWithoutConsultingExportList ( q );
1225 if (isNull(c)) goto notfound;
1227 fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
1229 module(mod).exports = cons(c, module(mod).exports);
1233 case CONIDCELL: /* non data tycon */
1234 q = mkQualId(exmod,ex);
1235 c = findQualTyconWithoutConsultingExportList ( q );
1236 if (isNull(c)) goto notfound;
1238 fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
1240 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1244 case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
1245 subents = zsnd(ex); /* :: [ConVarId] */
1246 ex = zfst(ex); /* :: ConId */
1247 q = mkQualId(exmod,ex);
1248 c = findQualTyconWithoutConsultingExportList ( q );
1250 if (nonNull(c)) { /* data */
1252 fprintf(stderr, " data/newtype %s = { ",
1253 textToStr(textOf(ex)) );
1255 assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1256 abstract = isNull(tycon(c).defn);
1257 /* This data/newtype could be abstract even tho the export list
1258 says to export it non-abstractly. That happens if it was
1259 imported from some other module and is now being re-exported,
1260 and previous cleanup phases have abstractified it in the
1261 original (defining) module.
1264 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1267 fprintf ( stderr, "(abstract) ");
1270 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1272 for (; nonNull(subents); subents = tl(subents)) {
1273 Cell ent2 = hd(subents);
1274 assert(isCon(ent2) || isVar(ent2));
1275 /* isVar since could be a field name */
1276 q = mkQualId(exmod,ent2);
1277 c = findQualNameWithoutConsultingExportList ( q );
1279 fprintf(stderr, "%s ", textToStr(name(c).text));
1282 /* module(mod).exports = cons(c, module(mod).exports); */
1287 fprintf(stderr, "}\n" );
1289 } else { /* class */
1290 q = mkQualId(exmod,ex);
1291 c = findQualClassWithoutConsultingExportList ( q );
1292 if (isNull(c)) goto notfound;
1294 fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
1296 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1298 for (; nonNull(subents); subents = tl(subents)) {
1299 Cell ent2 = hd(subents);
1300 assert(isVar(ent2));
1301 q = mkQualId(exmod,ent2);
1302 c = findQualNameWithoutConsultingExportList ( q );
1304 fprintf(stderr, "%s ", textToStr(name(c).text));
1306 if (isNull(c)) goto notfound;
1307 /* module(mod).exports = cons(c, module(mod).exports); */
1311 fprintf(stderr, "}\n" );
1317 internal("finishExports(2)");
1320 continue; /* so notfound: can be placed after this */
1323 /* q holds what ain't found */
1324 assert(whatIs(q)==QUALIDENT);
1326 fprintf( stderr, " ------ IGNORED: %s.%s\n",
1327 textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1334 if (preludeLoaded) {
1335 /* do the implicit 'import Prelude' thing */
1336 List pxs = module(modulePrelude).exports;
1337 for (; nonNull(pxs); pxs=tl(pxs)) {
1340 switch (whatIs(px)) {
1345 module(mod).names = cons ( px, module(mod).names );
1348 module(mod).tycons = cons ( px, module(mod).tycons );
1351 module(mod).classes = cons ( px, module(mod).classes );
1354 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1355 internal("finishGHCModule -- implicit import Prelude");
1362 /* Last, but by no means least ... */
1363 if (!ocResolve(module(mod).object,VERBOSE))
1364 internal("finishGHCModule: object resolution failed");
1366 for (oc=module(mod).objectExtras; oc; oc=oc->next) {
1367 if (!ocResolve(oc, VERBOSE))
1368 internal("finishGHCModule: extra object resolution failed");
1373 /* --------------------------------------------------------------------------
1375 * ------------------------------------------------------------------------*/
1377 static Void startGHCExports ( ConId mn, List exlist )
1380 fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
1382 /* Nothing to do. */
1385 static Void finishGHCExports ( ConId mn, List exlist )
1388 fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
1390 /* Nothing to do. */
1394 /* --------------------------------------------------------------------------
1396 * ------------------------------------------------------------------------*/
1398 static Void startGHCImports ( ConId mn, List syms )
1399 /* nm the module to import from */
1400 /* syms [ConId | VarId] -- the names to import */
1403 fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
1405 /* Nothing to do. */
1409 static Void finishGHCImports ( ConId nm, List syms )
1410 /* nm the module to import from */
1411 /* syms [ConId | VarId] -- the names to import */
1414 fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
1416 /* Nothing to do. */
1420 /* --------------------------------------------------------------------------
1422 * ------------------------------------------------------------------------*/
1424 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
1426 Int p = intOf(prec);
1427 Int a = intOf(assoc);
1428 Name n = findName(textOf(name));
1429 assert (nonNull(n));
1430 name(n).syntax = mkSyntax ( a, p );
1434 /* --------------------------------------------------------------------------
1436 * ------------------------------------------------------------------------*/
1438 /* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
1439 { C1 a } -> { C2 b } -> T into
1440 ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
1442 static Type dictapsToQualtype ( Type ty )
1445 List preds, dictaps;
1447 /* break ty into pieces at the top-level arrows */
1448 while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
1449 pieces = cons ( arg(fun(ty)), pieces );
1452 pieces = cons ( ty, pieces );
1453 pieces = reverse ( pieces );
1456 while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
1457 dictaps = cons ( hd(pieces), dictaps );
1458 pieces = tl(pieces);
1461 /* dictaps holds the predicates, backwards */
1462 /* pieces holds the remainder of the type, forwards */
1463 assert(nonNull(pieces));
1464 pieces = reverse(pieces);
1466 pieces = tl(pieces);
1467 for (; nonNull(pieces); pieces=tl(pieces))
1468 ty = fn(hd(pieces),ty);
1471 for (; nonNull(dictaps); dictaps=tl(dictaps)) {
1472 Cell da = hd(dictaps);
1473 QualId cl = fst(unap(DICTAP,da));
1474 Cell arg = snd(unap(DICTAP,da));
1475 preds = cons ( pair(cl,arg), preds );
1478 if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
1484 static void startGHCValue ( Int line, VarId vid, Type ty )
1488 Text v = textOf(vid);
1491 fprintf(stderr,"begin startGHCValue %s\n", textToStr(v));
1496 if (nonNull(n) && name(n).defn != PREDEFINED) {
1497 ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
1500 if (isNull(n)) n = newName(v,NIL);
1502 ty = dictapsToQualtype(ty);
1504 tvs = ifTyvarsIn(ty);
1505 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1506 hd(tmp) = zpair(hd(tmp),STAR);
1508 ty = mkPolyType(tvsToKind(tvs),ty);
1510 ty = tvsToOffsets(line,ty,tvs);
1512 name(n).arity = arityInclDictParams(ty);
1513 name(n).line = line;
1518 static void finishGHCValue ( VarId vid )
1520 Name n = findName ( textOf(vid) );
1521 Int line = name(n).line;
1523 fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1525 assert(currentModule == name(n).mod);
1526 name(n).type = conidcellsToTycons(line,name(n).type);
1528 if (isIfaceDefaultMethodName(name(n).text)) {
1529 /* ... we need to set .parent to point to the class
1530 ... once we figure out what the class actually is :-)
1532 Type t = name(n).type;
1533 assert(isPolyType(t));
1534 if (isPolyType(t)) t = monotypeOf(t);
1535 assert(isQualType(t));
1536 t = fst(snd(t)); /* t :: [(Class,Offset)] */
1538 assert(nonNull(hd(t)));
1539 assert(isPair(hd(t)));
1540 t = fst(hd(t)); /* t :: Class */
1543 name(n).parent = t; /* phew! */
1548 /* --------------------------------------------------------------------------
1550 * ------------------------------------------------------------------------*/
1552 static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1554 /* tycon :: ConId */
1555 /* tvs :: [((VarId,Kind))] */
1557 Text t = textOf(tycon);
1559 fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1562 if (nonNull(findTycon(t))) {
1563 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1567 Tycon tc = newTycon(t);
1568 tycon(tc).line = line;
1569 tycon(tc).arity = length(tvs);
1570 tycon(tc).what = SYNONYM;
1571 tycon(tc).kind = tvsToKind(tvs);
1573 /* prepare for finishGHCSynonym */
1574 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
1579 static Void finishGHCSynonym ( ConId tyc )
1581 Tycon tc = findTycon(textOf(tyc));
1582 Int line = tycon(tc).line;
1584 fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1587 assert (currentModule == tycon(tc).mod);
1588 // setCurrModule(tycon(tc).mod);
1589 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1591 /* (ADR) ToDo: can't really do this until I've done all synonyms
1592 * and then I have to do them in order
1593 * tycon(tc).defn = fullExpand(ty);
1594 * (JRS) What?!?! i don't understand
1599 /* --------------------------------------------------------------------------
1601 * ------------------------------------------------------------------------*/
1603 static Type qualifyIfaceType ( Type unqual, List ctx )
1605 /* ctx :: [((QConId,VarId))] */
1606 /* ctx is a list of (class name, tyvar) pairs.
1607 Attach to unqual qualifiers taken from ctx
1608 for each tyvar which appears in unqual.
1610 List tyvarsMentioned; /* :: [VarId] */
1614 if (isPolyType(unqual)) {
1615 kinds = polySigOf(unqual);
1616 unqual = monotypeOf(unqual);
1619 assert(!isQualType(unqual));
1620 tyvarsMentioned = ifTyvarsIn ( unqual );
1621 for (; nonNull(ctx); ctx=tl(ctx)) {
1622 ZPair ctxElem = hd(ctx); /* :: ((QConId, VarId)) */
1623 if (nonNull(varIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1624 ctx2 = cons(ctxElem, ctx2);
1627 unqual = ap(QUAL,pair(reverse(ctx2),unqual));
1629 unqual = mkPolyType(kinds,unqual);
1634 static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1636 List ctx0; /* [((QConId,VarId))] */
1637 Cell tycon; /* ConId */
1638 List ktyvars; /* [((VarId,Kind))] */
1639 List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
1640 /* The Text is an optional field name
1641 The Int indicates strictness */
1642 /* ToDo: worry about being given a decl for (->) ?
1643 * and worry about qualidents for ()
1646 Type ty, resTy, selTy, conArgTy;
1647 List tmp, conArgs, sels, constrs, fields;
1650 Pair conArg, ctxElem;
1652 Int conArgStrictness;
1653 Int conStrictCompCount;
1655 Text t = textOf(tycon);
1657 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1661 if (nonNull(findTycon(t))) {
1662 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1666 Tycon tc = newTycon(t);
1668 tycon(tc).line = line;
1669 tycon(tc).arity = length(ktyvars);
1670 tycon(tc).kind = tvsToKind(ktyvars);
1671 tycon(tc).what = DATATYPE;
1673 /* a list to accumulate selectors in :: [((VarId,Type))] */
1676 /* make resTy the result type of the constr, T v1 ... vn */
1678 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1679 resTy = ap(resTy,zfst(hd(tmp)));
1681 /* for each constructor ... */
1682 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1683 constr = hd(constrs);
1684 conid = zfst(constr);
1685 fields = zsnd(constr);
1687 /* Build type of constr and handle any selectors found. */
1690 conStrictCompCount = 0;
1691 conArgs = reverse(fields);
1692 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1693 conArg = hd(conArgs); /* (Type,Text) */
1694 conArgTy = zfst3(conArg);
1695 conArgNm = zsnd3(conArg);
1696 conArgStrictness = intOf(zthd3(conArg));
1697 if (conArgStrictness > 0) conStrictCompCount++;
1698 ty = fn(conArgTy,ty);
1699 if (nonNull(conArgNm)) {
1700 /* a field name is mentioned too */
1701 selTy = fn(resTy,conArgTy);
1702 if (whatIs(tycon(tc).kind) != STAR)
1703 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1704 selTy = qualifyIfaceType ( selTy, ctx0 );
1705 selTy = tvsToOffsets(line,selTy, ktyvars);
1706 sels = cons( zpair(conArgNm,selTy), sels);
1710 /* Now ty is the constructor's type, not including context.
1711 Throw away any parts of the context not mentioned in ty,
1712 and use it to qualify ty.
1714 ty = qualifyIfaceType ( ty, ctx0 );
1716 /* stick the tycon's kind on, if not simply STAR */
1717 if (whatIs(tycon(tc).kind) != STAR)
1718 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1720 ty = tvsToOffsets(line,ty, ktyvars);
1722 /* Finally, stick the constructor's type onto it. */
1723 hd(constrs) = z4ble(conid,fields,ty,mkInt(conStrictCompCount));
1726 /* Final result is that
1727 constrs :: [((ConId,[((Type,Text))],Type,Int))]
1728 lists the constructors, their types and # strict comps
1729 sels :: [((VarId,Type))]
1730 lists the selectors and their types
1732 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1737 static List startGHCConstrs ( Int line, List cons, List sels )
1739 /* cons :: [((ConId,[((Type,Text,Int))],Type,Int))] */
1740 /* sels :: [((VarId,Type))] */
1741 /* returns [Name] */
1743 Int conNo = length(cons)>1 ? 1 : 0;
1744 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1745 Name c = startGHCConstr(line,conNo,hd(cs));
1748 /* cons :: [Name] */
1750 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1751 hd(ss) = startGHCSel(line,hd(ss));
1753 /* sels :: [Name] */
1754 return appendOnto(cons,sels);
1758 static Name startGHCSel ( Int line, ZPair sel )
1760 /* sel :: ((VarId, Type)) */
1761 Text t = textOf(zfst(sel));
1762 Type type = zsnd(sel);
1764 Name n = findName(t);
1766 ERRMSG(line) "Repeated definition for selector \"%s\"",
1772 name(n).line = line;
1773 name(n).number = SELNAME;
1776 name(n).type = type;
1781 static Name startGHCConstr ( Int line, Int conNo, Z4Ble constr )
1783 /* constr :: ((ConId,[((Type,Text,Int))],Type,Int)) */
1784 /* (ADR) ToDo: add rank2 annotation and existential annotation
1785 * these affect how constr can be used.
1787 Text con = textOf(zsel14(constr));
1788 Type type = zsel34(constr);
1789 Int arity = arityFromType(type);
1790 Int nStrict = intOf(zsel44(constr));
1791 Name n = findName(con); /* Allocate constructor fun name */
1793 n = newName(con,NIL);
1794 } else if (name(n).defn!=PREDEFINED) {
1795 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1799 name(n).arity = arity; /* Save constructor fun details */
1800 name(n).line = line;
1801 name(n).number = cfunNo(conNo);
1802 name(n).type = type;
1803 name(n).hasStrict = nStrict > 0;
1808 static List finishGHCDataDecl ( ConId tyc )
1811 Tycon tc = findTycon(textOf(tyc));
1813 fprintf ( stderr, "begin finishGHCDataDecl %s\n",
1814 textToStr(textOf(tyc)) );
1816 if (isNull(tc)) internal("finishGHCDataDecl");
1818 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1820 Int line = name(n).line;
1821 assert(currentModule == name(n).mod);
1822 name(n).type = conidcellsToTycons(line,name(n).type);
1823 name(n).parent = tc; //---????
1826 return tycon(tc).defn;
1830 /* --------------------------------------------------------------------------
1832 * ------------------------------------------------------------------------*/
1834 static Void startGHCNewType ( Int line, List ctx0,
1835 ConId tycon, List tvs, Cell constr )
1837 /* ctx0 :: [((QConId,VarId))] */
1838 /* tycon :: ConId */
1839 /* tvs :: [((VarId,Kind))] */
1840 /* constr :: ((ConId,Type)) or NIL if abstract */
1843 Text t = textOf(tycon);
1845 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1850 if (nonNull(findTycon(t))) {
1851 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1855 Tycon tc = newTycon(t);
1856 tycon(tc).line = line;
1857 tycon(tc).arity = length(tvs);
1858 tycon(tc).what = NEWTYPE;
1859 tycon(tc).kind = tvsToKind(tvs);
1860 /* can't really do this until I've read in all synonyms */
1862 if (isNull(constr)) {
1863 tycon(tc).defn = NIL;
1865 /* constr :: ((ConId,Type)) */
1866 Text con = textOf(zfst(constr));
1867 Type type = zsnd(constr);
1868 Name n = findName(con); /* Allocate constructor fun name */
1870 n = newName(con,NIL);
1871 } else if (name(n).defn!=PREDEFINED) {
1872 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1876 name(n).arity = 1; /* Save constructor fun details */
1877 name(n).line = line;
1878 name(n).number = cfunNo(0);
1879 name(n).defn = nameId;
1880 tycon(tc).defn = singleton(n);
1882 /* make resTy the result type of the constr, T v1 ... vn */
1884 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1885 resTy = ap(resTy,zfst(hd(tmp)));
1886 type = fn(type,resTy);
1888 type = ap(QUAL,pair(ctx0,type));
1889 type = tvsToOffsets(line,type,tvs);
1890 name(n).type = type;
1896 static Void finishGHCNewType ( ConId tyc )
1898 Tycon tc = findTycon(textOf(tyc));
1900 fprintf ( stderr, "begin finishGHCNewType %s\n",
1901 textToStr(textOf(tyc)) );
1904 if (isNull(tc)) internal("finishGHCNewType");
1906 if (isNull(tycon(tc).defn)) {
1907 /* it's an abstract type */
1909 else if (length(tycon(tc).defn) == 1) {
1910 /* As we expect, has a single constructor */
1911 Name n = hd(tycon(tc).defn);
1912 Int line = name(n).line;
1913 assert(currentModule == name(n).mod);
1914 name(n).type = conidcellsToTycons(line,name(n).type);
1916 internal("finishGHCNewType(2)");
1921 /* --------------------------------------------------------------------------
1922 * Class declarations
1923 * ------------------------------------------------------------------------*/
1925 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1927 List ctxt; /* [((QConId, VarId))] */
1928 ConId tc_name; /* ConId */
1929 List kinded_tvs; /* [((VarId, Kind))] */
1930 List mems0; { /* [((VarId, Type))] */
1932 List mems; /* [((VarId, Type))] */
1933 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1934 List tvs; /* [((VarId,Kind))] */
1935 List ns; /* [Name] */
1938 ZPair kinded_tv = hd(kinded_tvs);
1939 Text ct = textOf(tc_name);
1940 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1942 fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
1946 if (length(kinded_tvs) != 1) {
1947 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1951 if (nonNull(findClass(ct))) {
1952 ERRMSG(line) "Repeated definition of class \"%s\"",
1955 } else if (nonNull(findTycon(ct))) {
1956 ERRMSG(line) "\"%s\" used as both class and type constructor",
1960 Class nw = newClass(ct);
1961 cclass(nw).text = ct;
1962 cclass(nw).line = line;
1963 cclass(nw).arity = 1;
1964 cclass(nw).head = ap(nw,mkOffset(0));
1965 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1966 cclass(nw).instances = NIL;
1967 cclass(nw).numSupers = length(ctxt);
1969 /* Kludge to map the single tyvar in the context to Offset 0.
1970 Need to do something better for multiparam type classes.
1972 cclass(nw).supers = tvsToOffsets(line,ctxt,
1973 singleton(kinded_tv));
1976 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1977 ZPair mem = hd(mems);
1978 Type memT = zsnd(mem);
1979 Text mnt = textOf(zfst(mem));
1982 /* Stick the new context on the member type */
1983 memT = dictapsToQualtype(memT);
1984 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1985 if (whatIs(memT)==QUAL) {
1987 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1990 pair(singleton(newCtx),memT));
1993 /* Cook up a kind for the type. */
1994 tvsInT = ifTyvarsIn(memT);
1995 /* tvsInT :: [VarId] */
1997 /* ToDo: maximally bogus. We allow the class tyvar to
1998 have the kind as supplied by the parser, but we just
1999 assume that all others have kind *. It's a kludge.
2001 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
2003 if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
2004 k = zsnd(kinded_tv); else
2006 hd(tvs) = zpair(hd(tvs),k);
2008 /* tvsIntT :: [((VarId,Kind))] */
2010 memT = mkPolyType(tvsToKind(tvsInT),memT);
2011 memT = tvsToOffsets(line,memT,tvsInT);
2013 /* Park the type back on the member */
2014 mem = zpair(zfst(mem),memT);
2016 /* Bind code to the member */
2020 "Repeated definition for class method \"%s\"",
2024 mn = newName(mnt,NIL);
2029 cclass(nw).members = mems0;
2030 cclass(nw).numMembers = length(mems0);
2033 for (mno=0; mno<cclass(nw).numSupers; mno++) {
2034 ns = cons(newDSel(nw,mno),ns);
2036 cclass(nw).dsels = rev(ns);
2041 static Class finishGHCClass ( Tycon cls_tyc )
2046 Class nw = findClass ( textOf(cls_tyc) );
2048 fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
2050 if (isNull(nw)) internal("finishGHCClass");
2052 line = cclass(nw).line;
2054 assert (currentModule == cclass(nw).mod);
2056 cclass(nw).level = 0;
2057 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
2058 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
2059 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
2061 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2062 Pair mem = hd(mems); /* (VarId, Type) */
2063 Text txt = textOf(fst(mem));
2065 Name n = findName(txt);
2068 name(n).line = cclass(nw).line;
2070 name(n).number = ctr--;
2071 name(n).arity = arityInclDictParams(name(n).type);
2072 name(n).parent = nw;
2080 /* --------------------------------------------------------------------------
2082 * ------------------------------------------------------------------------*/
2084 static Inst startGHCInstance (line,ktyvars,cls,var)
2086 List ktyvars; /* [((VarId,Kind))] */
2087 Type cls; /* Type */
2088 VarId var; { /* VarId */
2089 List tmp, tvs, ks, spec;
2094 Inst in = newInst();
2096 fprintf ( stderr, "begin startGHCInstance\n" );
2101 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2103 The order of tvs is important for tvsToOffsets.
2104 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2105 out of ktyvars and attach them to tvs.
2107 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2109 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2110 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2112 if (isNull(k)) internal("startGHCInstance: finding kinds");
2113 hd(xs1) = zpair(hd(xs1),k);
2116 cls = tvsToOffsets(line,cls,tvs);
2119 spec = cons(fun(cls),spec);
2122 spec = reverse(spec);
2124 inst(in).line = line;
2125 inst(in).implements = NIL;
2126 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2127 inst(in).specifics = spec;
2128 inst(in).numSpecifics = length(spec);
2129 inst(in).head = cls;
2131 /* Figure out the name of the class being instanced, and store it
2132 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2134 Cell cl = inst(in).head;
2135 assert(whatIs(cl)==DICTAP);
2136 cl = unap(DICTAP,cl);
2138 assert ( isQCon(cl) );
2143 Name b = newName( /*inventText()*/ textOf(var),NIL);
2144 name(b).line = line;
2145 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2146 name(b).number = DFUNNAME;
2147 name(b).parent = in;
2148 inst(in).builder = b;
2149 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2156 static Void finishGHCInstance ( Inst in )
2163 fprintf ( stderr, "begin finishGHCInstance\n" );
2166 assert (nonNull(in));
2167 line = inst(in).line;
2168 assert (currentModule==inst(in).mod);
2170 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2171 since startGHCInstance couldn't possibly have resolved it to
2172 a Class at that point. We convert it to a Class now.
2176 c = findQualClassWithoutConsultingExportList(c);
2180 inst(in).head = conidcellsToTycons(line,inst(in).head);
2181 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2182 cclass(c).instances = cons(in,cclass(c).instances);
2186 /* --------------------------------------------------------------------------
2188 * ------------------------------------------------------------------------*/
2190 /* This is called from the startGHC* functions. It traverses a structure
2191 and converts varidcells, ie, type variables parsed by the interface
2192 parser, into Offsets, which is how Hugs wants to see them internally.
2193 The Offset for a type variable is determined by its place in the list
2194 passed as the second arg; the associated kinds are irrelevant.
2196 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2199 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2200 static Type tvsToOffsets(line,type,ktyvars)
2203 List ktyvars; { /* [((VarId,Kind))] */
2204 switch (whatIs(type)) {
2211 case ZTUP2: /* convert to the untyped representation */
2212 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2213 tvsToOffsets(line,zsnd(type),ktyvars) );
2215 return ap( tvsToOffsets(line,fun(type),ktyvars),
2216 tvsToOffsets(line,arg(type),ktyvars) );
2220 tvsToOffsets(line,monotypeOf(type),ktyvars)
2224 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2225 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2226 case DICTAP: /* bogus ?? */
2227 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2228 case UNBOXEDTUP: /* bogus?? */
2229 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2230 case BANG: /* bogus?? */
2231 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2232 case VARIDCELL: /* Ha! some real work to do! */
2234 Text tv = textOf(type);
2235 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2238 assert(isZPair(hd(ktyvars)));
2239 varid = zfst(hd(ktyvars));
2241 if (tv == tt) return mkOffset(i);
2243 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2248 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2250 fprintf(stderr,"\n");
2254 return NIL; /* NOTREACHED */
2258 /* This is called from the finishGHC* functions. It traverses a structure
2259 and converts conidcells, ie, type constructors parsed by the interface
2260 parser, into Tycons (or Classes), which is how Hugs wants to see them
2261 internally. Calls to this fn have to be deferred to the second phase
2262 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2263 Tycons or Classes have been loaded into the symbol tables and can be
2266 static Type conidcellsToTycons ( Int line, Type type )
2268 switch (whatIs(type)) {
2278 { Cell t; /* Tycon or Class */
2279 Text m = qmodOf(type);
2280 Module mod = findModule(m);
2283 "Undefined module in qualified name \"%s\"",
2288 t = findQualTyconWithoutConsultingExportList(type);
2289 if (nonNull(t)) return t;
2290 t = findQualClassWithoutConsultingExportList(type);
2291 if (nonNull(t)) return t;
2293 "Undefined qualified class or type \"%s\"",
2301 cl = findQualClass(type);
2302 if (nonNull(cl)) return cl;
2303 if (textOf(type)==findText("[]"))
2304 /* a hack; magically qualify [] into PrelBase.[] */
2305 return conidcellsToTycons(line,
2306 mkQualId(mkCon(findText("PrelBase")),type));
2307 tc = findQualTycon(type);
2308 if (nonNull(tc)) return tc;
2310 "Undefined class or type constructor \"%s\"",
2316 return ap( conidcellsToTycons(line,fun(type)),
2317 conidcellsToTycons(line,arg(type)) );
2318 case ZTUP2: /* convert to std pair */
2319 return ap( conidcellsToTycons(line,zfst(type)),
2320 conidcellsToTycons(line,zsnd(type)) );
2325 conidcellsToTycons(line,monotypeOf(type))
2329 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2330 conidcellsToTycons(line,snd(snd(type)))));
2331 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2332 Not sure if this is really the right place to
2333 convert it to the form Hugs wants, but will do so anyway.
2335 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2337 Class cl = fst(unap(DICTAP,type));
2338 List args = snd(unap(DICTAP,type));
2340 conidcellsToTycons(line,pair(cl,args));
2343 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2345 return ap(BANG, conidcellsToTycons(line, snd(type)));
2347 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2350 fprintf(stderr,"\n");
2354 return NIL; /* NOTREACHED */
2358 /* Find out if a type mentions a type constructor not present in
2359 the supplied list of qualified tycons.
2361 static Bool allTypesKnown ( Type type,
2362 List aktys /* [QualId] */,
2365 switch (whatIs(type)) {
2372 return allTypesKnown(fun(type),aktys,thisMod)
2373 && allTypesKnown(arg(type),aktys,thisMod);
2375 return allTypesKnown(zfst(type),aktys,thisMod)
2376 && allTypesKnown(zsnd(type),aktys,thisMod);
2378 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2381 if (textOf(type)==findText("[]"))
2382 /* a hack; magically qualify [] into PrelBase.[] */
2383 type = mkQualId(mkCon(findText("PrelBase")),type); else
2384 type = mkQualId(thisMod,type);
2387 if (isNull(qualidIsMember(type,aktys))) goto missing;
2393 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2394 print(type,10);printf("\n");
2395 internal("allTypesKnown");
2396 return TRUE; /*notreached*/
2400 fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
2401 fprintf(stderr,"\n");
2407 /* --------------------------------------------------------------------------
2410 * None of these do lookups or require that lookups have been resolved
2411 * so they can be performed while reading interfaces.
2412 * ------------------------------------------------------------------------*/
2414 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2415 static Kinds tvsToKind(tvs)
2416 List tvs; { /* [((VarId,Kind))] */
2419 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2420 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2421 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2422 r = ap(zsnd(hd(rs)),r);
2428 static Int arityInclDictParams ( Type type )
2431 if (isPolyType(type)) type = monotypeOf(type);
2433 if (whatIs(type) == QUAL)
2435 arity += length ( fst(snd(type)) );
2436 type = snd(snd(type));
2438 while (isAp(type) && getHead(type)==typeArrow) {
2445 /* arity of a constructor with this type */
2446 static Int arityFromType(type)
2449 if (isPolyType(type)) {
2450 type = monotypeOf(type);
2452 if (whatIs(type) == QUAL) {
2453 type = snd(snd(type));
2455 if (whatIs(type) == EXIST) {
2456 type = snd(snd(type));
2458 if (whatIs(type)==RANK2) {
2459 type = snd(snd(type));
2461 while (isAp(type) && getHead(type)==typeArrow) {
2469 /* ifTyvarsIn :: Type -> [VarId]
2470 The returned list has no duplicates -- is a set.
2472 static List ifTyvarsIn(type)
2474 List vs = typeVarsIn(type,NIL,NIL,NIL);
2476 for (; nonNull(vs2); vs2=tl(vs2))
2477 if (whatIs(hd(vs2)) != VARIDCELL)
2478 internal("ifTyvarsIn");
2484 /* --------------------------------------------------------------------------
2485 * General object symbol query stuff
2486 * ------------------------------------------------------------------------*/
2488 #define EXTERN_SYMS_ALLPLATFORMS \
2489 SymX(MainRegTable) \
2490 Sym(stg_gc_enter_1) \
2491 Sym(stg_gc_noregs) \
2499 SymX(stg_update_PAP) \
2500 SymX(stg_error_entry) \
2501 SymX(__ap_2_upd_info) \
2502 SymX(__ap_3_upd_info) \
2503 SymX(__ap_4_upd_info) \
2504 SymX(__ap_5_upd_info) \
2505 SymX(__ap_6_upd_info) \
2506 SymX(__ap_7_upd_info) \
2507 SymX(__ap_8_upd_info) \
2508 SymX(__sel_0_upd_info) \
2509 SymX(__sel_1_upd_info) \
2510 SymX(__sel_2_upd_info) \
2511 SymX(__sel_3_upd_info) \
2512 SymX(__sel_4_upd_info) \
2513 SymX(__sel_5_upd_info) \
2514 SymX(__sel_6_upd_info) \
2515 SymX(__sel_7_upd_info) \
2516 SymX(__sel_8_upd_info) \
2517 SymX(__sel_9_upd_info) \
2518 SymX(__sel_10_upd_info) \
2519 SymX(__sel_11_upd_info) \
2520 SymX(__sel_12_upd_info) \
2521 SymX(upd_frame_info) \
2522 SymX(seq_frame_info) \
2523 SymX(CAF_BLACKHOLE_info) \
2524 SymX(IND_STATIC_info) \
2525 SymX(EMPTY_MVAR_info) \
2526 SymX(MUT_ARR_PTRS_FROZEN_info) \
2528 SymX(putMVarzh_fast) \
2529 SymX(newMVarzh_fast) \
2530 SymX(takeMVarzh_fast) \
2531 SymX(catchzh_fast) \
2532 SymX(raisezh_fast) \
2533 SymX(delayzh_fast) \
2534 SymX(yieldzh_fast) \
2535 SymX(killThreadzh_fast) \
2536 SymX(waitReadzh_fast) \
2537 SymX(waitWritezh_fast) \
2538 SymX(CHARLIKE_closure) \
2539 SymX(INTLIKE_closure) \
2540 SymX(suspendThread) \
2541 SymX(resumeThread) \
2542 SymX(stackOverflow) \
2543 SymX(int2Integerzh_fast) \
2544 Sym(stg_gc_unbx_r1) \
2545 SymX(ErrorHdrHook) \
2546 SymX(mkForeignObjzh_fast) \
2547 SymX(__encodeDouble) \
2548 SymX(decodeDoublezh_fast) \
2550 SymX(isDoubleInfinite) \
2551 SymX(isDoubleDenormalized) \
2552 SymX(isDoubleNegativeZero) \
2553 SymX(__encodeFloat) \
2554 SymX(decodeFloatzh_fast) \
2556 SymX(isFloatInfinite) \
2557 SymX(isFloatDenormalized) \
2558 SymX(isFloatNegativeZero) \
2559 SymX(__int_encodeFloat) \
2560 SymX(__int_encodeDouble) \
2564 SymX(gcdIntegerzh_fast) \
2565 SymX(newArrayzh_fast) \
2566 SymX(unsafeThawArrayzh_fast) \
2567 SymX(newDoubleArrayzh_fast) \
2568 SymX(newFloatArrayzh_fast) \
2569 SymX(newAddrArrayzh_fast) \
2570 SymX(newWordArrayzh_fast) \
2571 SymX(newIntArrayzh_fast) \
2572 SymX(newCharArrayzh_fast) \
2573 SymX(newMutVarzh_fast) \
2574 SymX(quotRemIntegerzh_fast) \
2575 SymX(quotIntegerzh_fast) \
2576 SymX(remIntegerzh_fast) \
2577 SymX(divExactIntegerzh_fast) \
2578 SymX(divModIntegerzh_fast) \
2579 SymX(timesIntegerzh_fast) \
2580 SymX(minusIntegerzh_fast) \
2581 SymX(plusIntegerzh_fast) \
2582 SymX(addr2Integerzh_fast) \
2583 SymX(mkWeakzh_fast) \
2586 Sym(resetNonBlockingFd) \
2587 SymX(getStablePtr) \
2588 SymX(stable_ptr_table) \
2589 Sym(createAdjThunk) \
2590 SymX(shutdownHaskellAndExit) \
2591 Sym(stg_enterStackTop) \
2592 SymX(CAF_UNENTERED_entry) \
2593 Sym(stg_yield_to_Hugs) \
2596 SymX(blockAsyncExceptionszh_fast) \
2597 SymX(unblockAsyncExceptionszh_fast) \
2599 /* needed by libHS_cbits */ \
2624 #define EXTERN_SYMS_cygwin32 \
2625 SymX(GetCurrentProcess) \
2626 SymX(GetProcessTimes) \
2635 SymX(__imp__tzname) \
2636 SymX(__imp__timezone) \
2662 #define EXTERN_SYMS_linux \
2663 SymX(__errno_location) \
2690 #define EXTERN_SYMS_solaris2 \
2691 SymX(gettimeofday) \
2694 #if defined(linux_TARGET_OS)
2695 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
2698 #if defined(solaris2_TARGET_OS)
2699 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
2702 #if defined(cygwin32_TARGET_OS)
2703 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
2706 #if defined(mingw32_TARGET_OS)
2707 #define EXTERN_SYMS_THISPLATFORM /* */
2712 /* entirely bogus claims about types of these symbols */
2713 #define Sym(vvv) extern void (vvv);
2714 #define SymX(vvv) /**/
2715 EXTERN_SYMS_ALLPLATFORMS
2716 EXTERN_SYMS_THISPLATFORM
2721 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2723 #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2727 EXTERN_SYMS_ALLPLATFORMS
2728 EXTERN_SYMS_THISPLATFORM
2737 /* A kludge to assist Win32 debugging. */
2738 char* nameFromStaticOPtr ( void* ptr )
2741 for (k = 0; rtsTab[k].nm; k++)
2742 if (ptr == rtsTab[k].ad)
2743 return rtsTab[k].nm;
2748 void* lookupObjName ( char* nm )
2756 int first_real_char;
2759 strncpy(nm2,nm,200);
2761 /* first see if it's an RTS name */
2762 for (k = 0; rtsTab[k].nm; k++)
2763 if (0==strcmp(nm2,rtsTab[k].nm))
2764 return rtsTab[k].ad;
2766 /* perhaps an extra-symbol ? */
2767 a = lookupOExtraTabName ( nm );
2770 # if LEADING_UNDERSCORE
2771 first_real_char = 1;
2773 first_real_char = 0;
2776 /* Maybe it's an __init_Module thing? */
2777 if (strlen(nm2+first_real_char) > 7
2778 && strncmp(nm2+first_real_char, "__init_", 7)==0) {
2779 t = unZcodeThenFindText(nm2+first_real_char+7);
2780 if (t == findText("PrelGHC")) return (4+(char*)NULL); /* kludge */
2782 if (isNull(m)) goto dire_straits;
2783 a = lookupOTabName ( m, nm );
2788 /* if not an RTS name, look in the
2789 relevant module's object symbol table
2791 pp = strchr(nm2+first_real_char, '_');
2792 if (!pp || !isupper(nm2[first_real_char])) goto dire_straits;
2794 t = unZcodeThenFindText(nm2+first_real_char);
2796 if (isNull(m)) goto dire_straits;
2798 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2802 /* make a desperate, last-ditch attempt to find it */
2803 a = lookupOTabNameAbsolutelyEverywhere ( nm );
2807 "lookupObjName: can't resolve name `%s'\n",
2814 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2816 OSectionKind sk = lookupSection(p);
2817 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2818 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2822 int is_dynamically_loaded_rwdata_ptr ( char* p )
2824 OSectionKind sk = lookupSection(p);
2825 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2826 return (sk == HUGS_SECTIONKIND_RWDATA);
2830 int is_not_dynamically_loaded_ptr ( char* p )
2832 OSectionKind sk = lookupSection(p);
2833 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2834 return (sk == HUGS_SECTIONKIND_OTHER);
2838 /* --------------------------------------------------------------------------
2840 * ------------------------------------------------------------------------*/
2842 Void interfayce(what)
2845 case POSTPREL: break;
2849 ifaces_outstanding = NIL;
2852 mark(ifaces_outstanding);
2857 /*-------------------------------------------------------------------------*/