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/04/25 17:43:49 $
12 * ------------------------------------------------------------------------*/
14 #include "hugsbasictypes.h"
20 #include "Assembler.h" /* for wrapping GHC objects */
22 /*#define DEBUG_IFACE*/
25 /* --------------------------------------------------------------------------
26 * (This comment is now out of date. JRS, 991216).
27 * The "addGHC*" functions act as "impedence matchers" between GHC
28 * interface files and Hugs. Their main job is to convert abstract
29 * syntax trees into Hugs' internal representations.
31 * The main trick here is how we deal with mutually recursive interface
34 * o As we read an import decl, we add it to a list of required imports
35 * (unless it's already loaded, of course).
37 * o Processing of declarations is split into two phases:
39 * 1) While reading the interface files, we construct all the Names,
40 * Tycons, etc declared in the interface file but we don't try to
41 * resolve references to any entities the declaration mentions.
43 * This is done by the "addGHC*" functions.
45 * 2) After reading all the interface files, we finish processing the
46 * declarations by resolving any references in the declarations
47 * and doing any other processing that may be required.
49 * This is done by the "finishGHC*" functions which use the
50 * "fixup*" functions to assist them.
52 * The interface between these two phases are the "ghc*Decls" which
53 * contain lists of decls that haven't been completed yet.
55 * ------------------------------------------------------------------------*/
59 New comment, 991216, explaining roughly how it all works.
60 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
62 Interfaces can contain references to unboxed types, and these need to
63 be handled carefully. The following is a summary of how the interface
64 loader now works. It is applied to groups of interfaces simultaneously,
65 viz, the entire Prelude at once:
67 0. Parse interfaces, chasing imports until a complete
68 strongly-connected-component of ifaces has been parsed.
69 All interfaces in this scc are processed together, in
72 1. Throw away any entity not mentioned in the export lists.
74 2. Delete type (not data or newtype) definitions which refer to
75 unknown types in their right hand sides. Because Hugs doesn't
76 know of any unboxed types, this has the side effect of removing
77 all type defns referring to unboxed types. Repeat step 2 until
78 a fixed point is reached.
80 3. Make abstract all data/newtype defns which refer to an unknown
81 type. eg, data Word = MkW Word# becomes data Word, because
82 Word# is unknown. Hugs is happy to know about abstract boxed
83 Words, but not about Word#s.
85 4. Step 2 could delete types referred to by values, instances and
86 classes. So filter all entities, and delete those referring to
87 unknown types _or_ classes. This could cause other entities
88 to become invalid, so iterate step 4 to a fixed point.
90 After step 4, the interfaces no longer contain anything
93 5. Steps 1-4 operate purely on the iface syntax trees. We now start
94 creating symbol table entries. First, create a module table
95 entry for each interface, and locate and read in the corresponding
96 object file. This is done by the startGHCModule function.
98 6. Traverse all interfaces. For each entity, create an entry in
99 the name, tycon, class or instance table, and fill in relevant
100 fields, but do not attempt to link tycon/class/instance/name uses
101 to their symbol table entries. This is done by the startGHC*
104 7. Revisit all symbol table entries created in step 6. We should
105 now be able to replace all references to tycons/classes/instances/
106 names with the relevant symbol table entries. This is done by
107 the finishGHC* functions.
109 8. Traverse all interfaces. For each iface, examine the export lists
110 and use it to build export lists in the module table. Do the
111 implicit 'import Prelude' thing if necessary. Finally, resolve
112 references in the object code for this module. This is done
113 by the finishGHCModule function.
116 /* --------------------------------------------------------------------------
117 * local function prototypes:
118 * ------------------------------------------------------------------------*/
120 static Void startGHCValue ( Int,VarId,Type );
121 static Void finishGHCValue ( VarId );
123 static Void startGHCSynonym ( Int,Cell,List,Type );
124 static Void finishGHCSynonym ( Tycon );
126 static Void startGHCClass ( Int,List,Cell,List,List );
127 static Class finishGHCClass ( Class );
129 static Inst startGHCInstance ( Int,List,Pair,VarId );
130 static Void finishGHCInstance ( Inst );
132 static Void startGHCImports ( ConId,List );
133 static Void finishGHCImports ( ConId,List );
135 static Void startGHCExports ( ConId,List );
136 static Void finishGHCExports ( ConId,List );
138 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
140 static Void finishGHCModule ( Cell );
141 static Void startGHCModule ( Text );
143 static Void startGHCDataDecl ( Int,List,Cell,List,List );
144 static List finishGHCDataDecl ( ConId tyc );
145 /* Supporting stuff for {start|finish}GHCDataDecl */
146 static List startGHCConstrs ( Int,List,List );
147 static Name startGHCSel ( Int,Pair );
148 static Name startGHCConstr ( Int,Int,Triple );
150 static Void startGHCNewType ( Int,List,Cell,List,Cell );
151 static Void finishGHCNewType ( ConId tyc );
155 static Kinds tvsToKind ( List );
156 static Int arityFromType ( Type );
157 static Int arityInclDictParams ( Type );
158 static Bool allTypesKnown ( Type type,
159 List aktys /* [QualId] */,
162 static List ifTyvarsIn ( Type );
163 static Type tvsToOffsets ( Int,Type,List );
164 static Type conidcellsToTycons ( Int,Type );
170 /* --------------------------------------------------------------------------
171 * Top-level interface processing
172 * ------------------------------------------------------------------------*/
174 /* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
175 static ConVarId getIEntityName ( Cell c )
178 case I_IMPORT: return NIL;
179 case I_INSTIMPORT: return NIL;
180 case I_EXPORT: return NIL;
181 case I_FIXDECL: return zthd3(unap(I_FIXDECL,c));
182 case I_INSTANCE: return NIL;
183 case I_TYPE: return zsel24(unap(I_TYPE,c));
184 case I_DATA: return zsel35(unap(I_DATA,c));
185 case I_NEWTYPE: return zsel35(unap(I_NEWTYPE,c));
186 case I_CLASS: return zsel35(unap(I_CLASS,c));
187 case I_VALUE: return zsnd3(unap(I_VALUE,c));
188 default: internal("getIEntityName");
193 /* Filter the contents of an interface, using the supplied predicate.
194 For flexibility, the predicate is passed as a second arg the value
195 extraArgs. This is a hack to get round the lack of partial applications
196 in C. Pred should not have any side effects. The dumpaction param
197 gives us the chance to print a message or some such for dumped items.
198 When a named entity is deleted, filterInterface also deletes the name
201 static Cell filterInterface ( Cell root,
202 Bool (*pred)(Cell,Cell),
204 Void (*dumpAction)(Cell) )
207 Cell iface = unap(I_INTERFACE,root);
209 List deleted_ids = NIL; /* :: [ConVarId] */
211 for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
212 if (pred(hd(tops),extraArgs)) {
213 tops2 = cons( hd(tops), tops2 );
215 ConVarId deleted_id = getIEntityName ( hd(tops) );
216 if (nonNull(deleted_id))
217 deleted_ids = cons ( deleted_id, deleted_ids );
219 dumpAction ( hd(tops) );
222 tops2 = reverse(tops2);
224 /* Clean up the export list now. */
225 for (tops=tops2; nonNull(tops); tops=tl(tops)) {
226 if (whatIs(hd(tops))==I_EXPORT) {
227 Cell exdecl = unap(I_EXPORT,hd(tops));
228 List exlist = zsnd(exdecl);
230 for (; nonNull(exlist); exlist=tl(exlist)) {
231 Cell ex = hd(exlist);
232 ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
233 assert (isCon(exid) || isVar(exid));
234 if (!varIsMember(textOf(exid),deleted_ids))
235 exlist2 = cons(ex, exlist2);
237 hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
241 return ap(I_INTERFACE, zpair(zfst(iface),tops2));
245 List /* of CONID */ getInterfaceImports ( Cell iface )
250 for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
251 if (whatIs(hd(tops)) == I_IMPORT) {
252 ZPair imp_decl = unap(I_IMPORT,hd(tops));
253 ConId m_to_imp = zfst(imp_decl);
254 if (textOf(m_to_imp) != findText("PrelGHC")) {
255 imports = cons(m_to_imp,imports);
257 fprintf(stderr, "add iface %s\n",
258 textToStr(textOf(m_to_imp)));
266 /* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
267 static List getExportDeclsInIFace ( Cell root )
269 Cell iface = unap(I_INTERFACE,root);
270 List decls = zsnd(iface);
273 for (ds=decls; nonNull(ds); ds=tl(ds))
274 if (whatIs(hd(ds))==I_EXPORT)
275 exports = cons(hd(ds), exports);
280 /* Does t start with "$dm" ? */
281 static Bool isIfaceDefaultMethodName ( Text t )
283 String s = textToStr(t);
284 return (s && s[0]=='$' && s[1]=='d' && s[2]=='m' && s[3]);
288 static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
290 /* ife :: I_IMPORT..I_VALUE */
291 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
297 ConVarId ife_id = getIEntityName ( ife );
299 if (isNull(ife_id)) return TRUE;
301 tnm = textOf(ife_id);
303 /* Don't junk default methods, even tho the export list doesn't
306 if (isIfaceDefaultMethodName(tnm)) goto retain;
308 /* for each export list ... */
309 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
310 exlist = hd(exlist_list);
312 /* for each entity in an export list ... */
313 for (t=exlist; nonNull(t); t=tl(t)) {
314 if (isZPair(hd(t))) {
315 /* A pair, which means an export entry
316 of the form ClassName(foo,bar). */
317 List subents = cons(zfst(hd(t)),zsnd(hd(t)));
318 for (; nonNull(subents); subents=tl(subents))
319 if (textOf(hd(subents)) == tnm) goto retain;
321 /* Single name in the list. */
322 if (textOf(hd(t)) == tnm) goto retain;
328 fprintf ( stderr, " dump %s\n", textToStr(tnm) );
334 fprintf ( stderr, " retain %s\n", textToStr(tnm) );
340 static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
342 /* ife_id :: ConId */
343 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
348 assert (isCon(ife_id));
349 tnm = textOf(ife_id);
351 /* for each export list ... */
352 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
353 exlist = hd(exlist_list);
355 /* for each entity in an export list ... */
356 for (t=exlist; nonNull(t); t=tl(t)) {
357 if (isZPair(hd(t))) {
358 /* A pair, which means an export entry
359 of the form ClassName(foo,bar). */
360 if (textOf(zfst(hd(t))) == tnm) return FALSE;
362 if (textOf(hd(t)) == tnm) return TRUE;
366 internal("isExportedAbstractly");
367 return FALSE; /*notreached*/
371 /* Remove entities not mentioned in any of the export lists. */
372 static Cell deleteUnexportedIFaceEntities ( Cell root )
374 Cell iface = unap(I_INTERFACE,root);
375 ConId iname = zfst(iface);
376 List decls = zsnd(iface);
378 List exlist_list = NIL;
382 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])) ]] */
393 if (isNull(exlist_list)) {
394 ERRMSG(0) "Can't find any export lists in interface file"
399 return filterInterface ( root, isExportedIFaceEntity,
404 /* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
405 static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
407 Cell iface = unap(I_INTERFACE,root);
408 Text mname = textOf(zfst(iface));
409 List defns = zsnd(iface);
410 for (; nonNull(defns); defns = tl(defns)) {
411 Cell defn = hd(defns);
412 Cell what = whatIs(defn);
413 if (what==I_TYPE || what==I_DATA
414 || what==I_NEWTYPE || what==I_CLASS) {
415 QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
416 if (!qualidIsMember ( q, aktys ))
417 aktys = cons ( q, aktys );
424 static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
426 ConVarId id = getIEntityName ( entity );
429 "dumping %s because of unknown type(s)\n",
430 isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
435 /* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
436 /* mod is the current module being processed -- so we can qualify unqual'd
437 names. Strange calling convention for aktys and mod is so we can call this
438 from filterInterface.
440 static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
443 List aktys = zfst ( aktys_mod );
444 ConId mod = zsnd ( aktys_mod );
445 switch (whatIs(entity)) {
452 Cell inst = unap(I_INSTANCE,entity);
453 List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
454 Type cls = zsel35 ( inst ); /* :: Type */
455 for (t = ctx; nonNull(t); t=tl(t))
456 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
457 if (!allTypesKnown(cls, aktys,mod)) return FALSE;
461 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
463 Cell data = unap(I_DATA,entity);
464 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
465 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
466 for (t = ctx; nonNull(t); t=tl(t))
467 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
468 for (t = constrs; nonNull(t); t=tl(t))
469 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
470 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
474 Cell newty = unap(I_NEWTYPE,entity);
475 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
476 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
477 for (t = ctx; nonNull(t); t=tl(t))
478 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
480 && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
484 Cell klass = unap(I_CLASS,entity);
485 List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
486 List sigs = zsel55(klass); /* :: [((VarId,Type))] */
487 for (t = ctx; nonNull(t); t=tl(t))
488 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
489 for (t = sigs; nonNull(t); t=tl(t))
490 if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
494 return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
496 internal("ifentityAllTypesKnown");
501 /* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
502 /* mod is the current module being processed -- so we can qualify unqual'd
503 names. Strange calling convention for aktys and mod is so we can call this
504 from filterInterface.
506 static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
509 List aktys = zfst ( aktys_mod );
510 ConId mod = zsnd ( aktys_mod );
511 if (whatIs(entity) != I_TYPE) {
514 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
519 static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
521 ConVarId id = getIEntityName ( entity );
522 assert (whatIs(entity)==I_TYPE);
526 "dumping type %s because of unknown tycon(s)\n",
527 textToStr(textOf(id)) );
532 /* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
534 static List abstractifyExDecl ( Cell root, ConId toabs )
536 ZPair exdecl = unap(I_EXPORT,root);
537 List exlist = zsnd(exdecl);
539 for (; nonNull(exlist); exlist = tl(exlist)) {
540 if (isZPair(hd(exlist))
541 && textOf(toabs) == textOf(zfst(hd(exlist)))) {
542 /* it's toabs, exported non-abstractly */
543 res = cons ( zfst(hd(exlist)), res );
545 res = cons ( hd(exlist), res );
548 return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
552 static Void ppModule ( Text modt )
555 fflush(stderr); fflush(stdout);
556 fprintf(stderr, "---------------- MODULE %s ----------------\n",
562 static void* ifFindItblFor ( Name n )
564 /* n is a constructor for which we want to find the GHC info table.
565 First look for a _con_info symbol. If that doesn't exist, _and_
566 this is a nullary constructor, then it's safe to look for the
567 _static_info symbol instead.
573 sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_info"),
574 textToStr( module(name(n).mod).text ),
575 textToStr( name(n).text ) );
576 t = enZcodeThenFindText(buf);
577 p = lookupOTabName ( name(n).mod, textToStr(t) );
581 if (name(n).arity == 0) {
582 sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"),
583 textToStr( module(name(n).mod).text ),
584 textToStr( name(n).text ) );
585 t = enZcodeThenFindText(buf);
586 p = lookupOTabName ( name(n).mod, textToStr(t) );
590 ERRMSG(0) "Can't find info table %s", textToStr(t)
595 void ifLinkConstrItbl ( Name n )
597 /* name(n) is either a constructor or a field name.
598 If the latter, ignore it. If it is a non-nullary constructor,
599 find its info table in the object code. If it's nullary,
600 we can skip the info table, since all accesses will go via
603 if (islower(textToStr(name(n).text)[0])) return;
604 if (name(n).arity == 0) return;
605 name(n).itbl = ifFindItblFor(n);
609 static void ifSetClassDefaultsAndDCon ( Class c )
617 List defs; /* :: [Name] */
618 List mems; /* :: [Name] */
620 assert(isNull(cclass(c).defaults));
622 /* Create the defaults list by more-or-less cloning the members list. */
624 for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
626 s = textToStr( name(hd(mems)).text );
627 assert(strlen(s) < 95);
629 n = findNameInAnyModule(findText(buf));
634 cclass(c).defaults = defs;
636 /* Create a name table entry for the dictionary datacon.
637 Interface files don't mention them, so it had better not
641 s = textToStr( cclass(c).text );
642 assert( strlen(s) < 96 );
645 n = findNameInAnyModule(t);
651 name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
652 name(n).number = cfunNo(0);
655 /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
656 Because this happens right at the end of loading, we know
657 that we should actually be able to find the symbol in this
658 module's object symbol table. Except that if the dictionary
659 has arity 1, we don't bother, since it will be represented as
660 a newtype and not as a data, so its itbl can remain NULL.
662 if (name(n).arity == 1) {
664 name(n).defn = nameId;
666 p = ifFindItblFor ( n );
672 void processInterfaces ( List /* of CONID */ iface_modnames )
683 List all_known_types;
685 List cls_list; /* :: List Class */
686 List constructor_list; /* :: List Name */
688 List ifaces = NIL; /* :: List I_INTERFACE */
690 if (isNull(iface_modnames)) return;
694 "processInterfaces: %d interfaces to process\n",
695 length(ifaces_outstanding) );
698 for (xs = iface_modnames; nonNull(xs); xs=tl(xs)) {
699 mod = findModule(textOf(hd(xs)));
700 assert(nonNull(mod));
701 assert(module(mod).mode == FM_OBJECT);
702 ifaces = cons ( module(mod).tree, ifaces );
704 ifaces = reverse(ifaces);
706 /* Clean up interfaces -- dump non-exported value, class, type decls */
707 for (xs = ifaces; nonNull(xs); xs = tl(xs))
708 hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
711 /* Iteratively delete any type declarations which refer to unknown
714 num_known_types = 999999999;
718 /* Construct a list of all known tycons. This is a list of QualIds.
719 Unfortunately it also has to contain all known class names, since
720 allTypesKnown cannot distinguish between tycons and classes -- a
721 deficiency of the iface abs syntax.
723 all_known_types = getAllKnownTyconsAndClasses();
724 for (xs = ifaces; nonNull(xs); xs=tl(xs))
726 = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
728 /* Have we reached a fixed point? */
729 i = length(all_known_types);
732 "\n============= %d known types =============\n", i );
734 if (num_known_types == i) break;
737 /* Delete all entities which refer to unknown tycons. */
738 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
739 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
740 assert(nonNull(mod));
741 hd(xs) = filterInterface ( hd(xs),
742 ifTypeDoesntRefUnknownTycon,
743 zpair(all_known_types,mod),
744 ifTypeDoesntRefUnknownTycon_dumpmsg );
748 /* Now abstractify any datas and newtypes which refer to unknown tycons
749 -- including, of course, the type decls just deleted.
751 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
752 List absify = NIL; /* :: [ConId] */
753 ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
754 ConId mod = zfst(iface);
755 List aktys = all_known_types; /* just a renaming */
759 /* Compute into absify the list of all ConIds (tycons) we need to
762 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
764 Bool allKnown = TRUE;
766 if (whatIs(ent)==I_DATA) {
767 Cell data = unap(I_DATA,ent);
768 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
769 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
770 for (t = ctx; nonNull(t); t=tl(t))
771 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
772 for (t = constrs; nonNull(t); t=tl(t))
773 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
774 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
776 else if (whatIs(ent)==I_NEWTYPE) {
777 Cell newty = unap(I_NEWTYPE,ent);
778 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
779 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
780 for (t = ctx; nonNull(t); t=tl(t))
781 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
782 if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
786 absify = cons ( getIEntityName(ent), absify );
789 "abstractifying %s because it uses an unknown type\n",
790 textToStr(textOf(getIEntityName(ent))) );
795 /* mark in exports as abstract all names in absify (modifies iface) */
796 for (; nonNull(absify); absify=tl(absify)) {
797 ConId toAbs = hd(absify);
798 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
799 if (whatIs(hd(es)) != I_EXPORT) continue;
800 hd(es) = abstractifyExDecl ( hd(es), toAbs );
804 /* For each data/newtype in the export list marked as abstract,
805 remove the constructor lists. This catches all abstractification
806 caused by the code above, and it also catches tycons which really
807 were exported abstractly.
810 exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
811 /* exlist_list :: [I_EXPORT] */
812 for (t=exlist_list; nonNull(t); t=tl(t))
813 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
814 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
816 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
818 if (whatIs(ent)==I_DATA
819 && isExportedAbstractly ( getIEntityName(ent),
821 Cell data = unap(I_DATA,ent);
822 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
823 zsel45(data), NIL /* the constr list */ );
824 hd(es) = ap(I_DATA,data);
826 fprintf(stderr, "abstractify data %s\n",
827 textToStr(textOf(getIEntityName(ent))) );
830 else if (whatIs(ent)==I_NEWTYPE
831 && isExportedAbstractly ( getIEntityName(ent),
833 Cell data = unap(I_NEWTYPE,ent);
834 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
835 zsel45(data), NIL /* the constr-type pair */ );
836 hd(es) = ap(I_NEWTYPE,data);
838 fprintf(stderr, "abstractify newtype %s\n",
839 textToStr(textOf(getIEntityName(ent))) );
844 /* We've finally finished mashing this iface. Update the iface list. */
845 hd(xs) = ap(I_INTERFACE,iface);
849 /* At this point, the interfaces are cleaned up so that no type, data or
850 newtype defn refers to a non-existant type. However, there still may
851 be value defns, classes and instances which refer to unknown types.
852 Delete iteratively until a fixed point is reached.
855 fprintf(stderr,"\n");
857 num_known_types = 999999999;
861 /* Construct a list of all known tycons. This is a list of QualIds.
862 Unfortunately it also has to contain all known class names, since
863 allTypesKnown cannot distinguish between tycons and classes -- a
864 deficiency of the iface abs syntax.
866 all_known_types = getAllKnownTyconsAndClasses();
867 for (xs = ifaces; nonNull(xs); xs=tl(xs))
868 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
870 /* Have we reached a fixed point? */
871 i = length(all_known_types);
874 "\n------------- %d known types -------------\n", i );
876 if (num_known_types == i) break;
879 /* Delete all entities which refer to unknown tycons. */
880 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
881 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
882 assert(nonNull(mod));
884 hd(xs) = filterInterface ( hd(xs),
885 ifentityAllTypesKnown,
886 zpair(all_known_types,mod),
887 ifentityAllTypesKnown_dumpmsg );
892 /* Allocate module table entries and read in object code. */
893 for (xs=ifaces; nonNull(xs); xs=tl(xs))
894 startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))) );
897 /* Now work through the decl lists of the modules, and call the
898 startGHC* functions on the entities. This creates names in
899 various tables but doesn't bind them to anything.
902 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
903 iface = unap(I_INTERFACE,hd(xs));
904 mname = textOf(zfst(iface));
905 mod = findModule(mname);
906 if (isNull(mod)) internal("processInterfaces(4)");
908 ppModule ( module(mod).text );
910 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
911 Cell decl = hd(decls);
912 switch(whatIs(decl)) {
914 Cell exdecl = unap(I_EXPORT,decl);
915 startGHCExports ( zfst(exdecl), zsnd(exdecl) );
919 Cell imdecl = unap(I_IMPORT,decl);
920 startGHCImports ( zfst(imdecl), zsnd(imdecl) );
927 /* Trying to find the instance table location allocated by
928 startGHCInstance in subsequent processing is a nightmare, so
929 cache it on the tree.
931 Cell instance = unap(I_INSTANCE,decl);
932 Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
933 zsel35(instance), zsel45(instance) );
934 hd(decls) = ap(I_INSTANCE,
935 z5ble( zsel15(instance), zsel25(instance),
936 zsel35(instance), zsel45(instance), in ));
940 Cell tydecl = unap(I_TYPE,decl);
941 startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
942 zsel34(tydecl), zsel44(tydecl) );
946 Cell ddecl = unap(I_DATA,decl);
947 startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
948 zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
952 Cell ntdecl = unap(I_NEWTYPE,decl);
953 startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
954 zsel35(ntdecl), zsel45(ntdecl),
959 Cell klass = unap(I_CLASS,decl);
960 startGHCClass ( zsel15(klass), zsel25(klass),
961 zsel35(klass), zsel45(klass),
966 Cell value = unap(I_VALUE,decl);
967 startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
971 internal("processInterfaces(1)");
977 fprintf(stderr, "\n============================"
978 "=============================\n");
979 fprintf(stderr, "=============================="
980 "===========================\n");
983 /* Traverse again the decl lists of the modules, this time
984 calling the finishGHC* functions. But don't process
985 the export lists; those must wait for later.
988 constructor_list = NIL;
989 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
990 iface = unap(I_INTERFACE,hd(xs));
991 mname = textOf(zfst(iface));
992 mod = findModule(mname);
993 if (isNull(mod)) internal("processInterfaces(3)");
995 ppModule ( module(mod).text );
997 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
998 Cell decl = hd(decls);
999 switch(whatIs(decl)) {
1007 Cell fixdecl = unap(I_FIXDECL,decl);
1008 finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
1012 Cell instance = unap(I_INSTANCE,decl);
1013 finishGHCInstance ( zsel55(instance) );
1017 Cell tydecl = unap(I_TYPE,decl);
1018 finishGHCSynonym ( zsel24(tydecl) );
1022 Cell ddecl = unap(I_DATA,decl);
1023 List constrs = finishGHCDataDecl ( zsel35(ddecl) );
1024 constructor_list = dupOnto ( constrs, constructor_list );
1028 Cell ntdecl = unap(I_NEWTYPE,decl);
1029 finishGHCNewType ( zsel35(ntdecl) );
1033 Cell klass = unap(I_CLASS,decl);
1034 Class cls = finishGHCClass ( zsel35(klass) );
1035 cls_list = cons(cls,cls_list);
1039 Cell value = unap(I_VALUE,decl);
1040 finishGHCValue ( zsnd3(value) );
1044 internal("processInterfaces(2)");
1049 fprintf(stderr, "\n+++++++++++++++++++++++++++++"
1050 "++++++++++++++++++++++++++++\n");
1051 fprintf(stderr, "+++++++++++++++++++++++++++++++"
1052 "++++++++++++++++++++++++++\n");
1055 /* Build the module(m).export lists for each module, by running
1056 through the export lists in the iface. Also, do the implicit
1057 'import Prelude' thing. And finally, do the object code
1060 for (xs = ifaces; nonNull(xs); xs = tl(xs))
1061 finishGHCModule(hd(xs));
1063 mapProc(visitClass,cls_list);
1064 mapProc(ifSetClassDefaultsAndDCon,cls_list);
1065 mapProc(ifLinkConstrItbl,constructor_list);
1068 ifaces_outstanding = NIL;
1072 /* --------------------------------------------------------------------------
1074 * ------------------------------------------------------------------------*/
1076 static void startGHCModule_errMsg ( char* msg )
1078 fprintf ( stderr, "object error: %s\n", msg );
1081 static void* startGHCModule_clientLookup ( char* sym )
1084 /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
1086 return lookupObjName ( sym );
1089 static int /*Bool*/ startGHCModule_clientWantsSymbol ( char* sym )
1091 if (strcmp(sym,"ghc_cc_ID")==0) return 0;
1095 static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
1098 = ocNew ( startGHCModule_errMsg,
1099 startGHCModule_clientLookup,
1100 startGHCModule_clientWantsSymbol,
1104 ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
1107 if (!ocLoadImage(oc,VERBOSE)) {
1108 ERRMSG(0) "Reading of object file \"%s\" failed", objNm
1111 if (!ocVerifyImage(oc,VERBOSE)) {
1112 ERRMSG(0) "Validation of object file \"%s\" failed", objNm
1115 if (!ocGetNames(oc,VERBOSE)) {
1116 ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
1122 static Void startGHCModule ( Text mname )
1125 Module m = findModule(mname);
1129 fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
1130 textToStr(mname), module(m).objSize );
1133 module(m).fake = FALSE;
1135 /* Get hold of the primary object for the module. */
1137 = startGHCModule_partial_load ( textToStr(module(m).objName),
1138 module(m).objSize );
1140 /* and any extras ... */
1141 for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
1145 String nm = getExtraObjectInfo (
1146 textToStr(module(m).objName),
1151 ERRMSG(0) "Can't find extra object file \"%s\"", nm
1154 oc = startGHCModule_partial_load ( nm, size );
1155 oc->next = module(m).objectExtras;
1156 module(m).objectExtras = oc;
1161 /* For the module mod, augment both the export environment (.exports)
1162 and the eval environment (.names, .tycons, .classes)
1163 with the symbols mentioned in exlist. We don't actually need
1164 to modify the names, tycons, classes or instances in the eval
1165 environment, since previous processing of the
1166 top-level decls in the iface should have done this already.
1168 mn is the module mentioned in the export list; it is the "original"
1169 module for the symbols in the export list. We should also record
1170 this info with the symbols, since references to object code need to
1171 refer to the original module in which a symbol was defined, rather
1172 than to some module it has been imported into and then re-exported.
1174 We take the policy that if something mentioned in an export list
1175 can't be found in the symbol tables, it is simply ignored. After all,
1176 previous processing of the iface syntax trees has already removed
1177 everything which Hugs can't handle, so if there is mention of these
1178 things still lurking in export lists somewhere, about the only thing
1179 to do is to ignore it.
1181 Also do an implicit 'import Prelude' thingy for the module,
1186 static Void finishGHCModule ( Cell root )
1188 /* root :: I_INTERFACE */
1189 Cell iface = unap(I_INTERFACE,root);
1190 ConId iname = zfst(iface);
1191 Module mod = findModule(textOf(iname));
1192 List exlist_list = NIL;
1197 fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1200 if (isNull(mod)) internal("finishExports(1)");
1203 exlist_list = getExportDeclsInIFace ( root );
1204 /* exlist_list :: [I_EXPORT] */
1206 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1207 ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
1208 ConId exmod = zfst(exdecl);
1209 List exlist = zsnd(exdecl);
1210 /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1212 for (; nonNull(exlist); exlist=tl(exlist)) {
1217 Cell ex = hd(exlist);
1219 switch (whatIs(ex)) {
1221 case VARIDCELL: /* variable */
1222 q = mkQualId(exmod,ex);
1223 c = findQualNameWithoutConsultingExportList ( q );
1224 if (isNull(c)) goto notfound;
1226 fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
1228 module(mod).exports = cons(c, module(mod).exports);
1232 case CONIDCELL: /* non data tycon */
1233 q = mkQualId(exmod,ex);
1234 c = findQualTyconWithoutConsultingExportList ( q );
1235 if (isNull(c)) goto notfound;
1237 fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
1239 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1243 case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
1244 subents = zsnd(ex); /* :: [ConVarId] */
1245 ex = zfst(ex); /* :: ConId */
1246 q = mkQualId(exmod,ex);
1247 c = findQualTyconWithoutConsultingExportList ( q );
1249 if (nonNull(c)) { /* data */
1251 fprintf(stderr, " data/newtype %s = { ",
1252 textToStr(textOf(ex)) );
1254 assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1255 abstract = isNull(tycon(c).defn);
1256 /* This data/newtype could be abstract even tho the export list
1257 says to export it non-abstractly. That happens if it was
1258 imported from some other module and is now being re-exported,
1259 and previous cleanup phases have abstractified it in the
1260 original (defining) module.
1263 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1266 fprintf ( stderr, "(abstract) ");
1269 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1271 for (; nonNull(subents); subents = tl(subents)) {
1272 Cell ent2 = hd(subents);
1273 assert(isCon(ent2) || isVar(ent2));
1274 /* isVar since could be a field name */
1275 q = mkQualId(exmod,ent2);
1276 c = findQualNameWithoutConsultingExportList ( q );
1278 fprintf(stderr, "%s ", textToStr(name(c).text));
1281 /* module(mod).exports = cons(c, module(mod).exports); */
1286 fprintf(stderr, "}\n" );
1288 } else { /* class */
1289 q = mkQualId(exmod,ex);
1290 c = findQualClassWithoutConsultingExportList ( q );
1291 if (isNull(c)) goto notfound;
1293 fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
1295 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1297 for (; nonNull(subents); subents = tl(subents)) {
1298 Cell ent2 = hd(subents);
1299 assert(isVar(ent2));
1300 q = mkQualId(exmod,ent2);
1301 c = findQualNameWithoutConsultingExportList ( q );
1303 fprintf(stderr, "%s ", textToStr(name(c).text));
1305 if (isNull(c)) goto notfound;
1306 /* module(mod).exports = cons(c, module(mod).exports); */
1310 fprintf(stderr, "}\n" );
1316 internal("finishExports(2)");
1319 continue; /* so notfound: can be placed after this */
1322 /* q holds what ain't found */
1323 assert(whatIs(q)==QUALIDENT);
1325 fprintf( stderr, " ------ IGNORED: %s.%s\n",
1326 textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1333 if (preludeLoaded) {
1334 /* do the implicit 'import Prelude' thing */
1335 List pxs = module(modulePrelude).exports;
1336 for (; nonNull(pxs); pxs=tl(pxs)) {
1339 switch (whatIs(px)) {
1344 module(mod).names = cons ( px, module(mod).names );
1347 module(mod).tycons = cons ( px, module(mod).tycons );
1350 module(mod).classes = cons ( px, module(mod).classes );
1353 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1354 internal("finishGHCModule -- implicit import Prelude");
1361 /* Last, but by no means least ... */
1362 if (!ocResolve(module(mod).object,VERBOSE))
1363 internal("finishGHCModule: object resolution failed");
1365 for (oc=module(mod).objectExtras; oc; oc=oc->next) {
1366 if (!ocResolve(oc, VERBOSE))
1367 internal("finishGHCModule: extra object resolution failed");
1372 /* --------------------------------------------------------------------------
1374 * ------------------------------------------------------------------------*/
1376 static Void startGHCExports ( ConId mn, List exlist )
1379 fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
1381 /* Nothing to do. */
1384 static Void finishGHCExports ( ConId mn, List exlist )
1387 fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
1389 /* Nothing to do. */
1393 /* --------------------------------------------------------------------------
1395 * ------------------------------------------------------------------------*/
1397 static Void startGHCImports ( ConId mn, List syms )
1398 /* nm the module to import from */
1399 /* syms [ConId | VarId] -- the names to import */
1402 fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
1404 /* Nothing to do. */
1408 static Void finishGHCImports ( ConId nm, List syms )
1409 /* nm the module to import from */
1410 /* syms [ConId | VarId] -- the names to import */
1413 fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
1415 /* Nothing to do. */
1419 /* --------------------------------------------------------------------------
1421 * ------------------------------------------------------------------------*/
1423 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
1425 Int p = intOf(prec);
1426 Int a = intOf(assoc);
1427 Name n = findName(textOf(name));
1428 assert (nonNull(n));
1429 name(n).syntax = mkSyntax ( a, p );
1433 /* --------------------------------------------------------------------------
1435 * ------------------------------------------------------------------------*/
1437 /* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
1438 { C1 a } -> { C2 b } -> T into
1439 ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
1441 static Type dictapsToQualtype ( Type ty )
1444 List preds, dictaps;
1446 /* break ty into pieces at the top-level arrows */
1447 while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
1448 pieces = cons ( arg(fun(ty)), pieces );
1451 pieces = cons ( ty, pieces );
1452 pieces = reverse ( pieces );
1455 while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
1456 dictaps = cons ( hd(pieces), dictaps );
1457 pieces = tl(pieces);
1460 /* dictaps holds the predicates, backwards */
1461 /* pieces holds the remainder of the type, forwards */
1462 assert(nonNull(pieces));
1463 pieces = reverse(pieces);
1465 pieces = tl(pieces);
1466 for (; nonNull(pieces); pieces=tl(pieces))
1467 ty = fn(hd(pieces),ty);
1470 for (; nonNull(dictaps); dictaps=tl(dictaps)) {
1471 Cell da = hd(dictaps);
1472 QualId cl = fst(unap(DICTAP,da));
1473 Cell arg = snd(unap(DICTAP,da));
1474 preds = cons ( pair(cl,arg), preds );
1477 if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
1483 static void startGHCValue ( Int line, VarId vid, Type ty )
1487 Text v = textOf(vid);
1490 fprintf(stderr,"begin startGHCValue %s\n", textToStr(v));
1495 if (nonNull(n) && name(n).defn != PREDEFINED) {
1496 ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
1499 if (isNull(n)) n = newName(v,NIL);
1501 ty = dictapsToQualtype(ty);
1503 tvs = ifTyvarsIn(ty);
1504 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1505 hd(tmp) = zpair(hd(tmp),STAR);
1507 ty = mkPolyType(tvsToKind(tvs),ty);
1509 ty = tvsToOffsets(line,ty,tvs);
1511 name(n).arity = arityInclDictParams(ty);
1512 name(n).line = line;
1517 static void finishGHCValue ( VarId vid )
1519 Name n = findName ( textOf(vid) );
1520 Int line = name(n).line;
1522 fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1524 assert(currentModule == name(n).mod);
1525 name(n).type = conidcellsToTycons(line,name(n).type);
1527 if (isIfaceDefaultMethodName(name(n).text)) {
1528 /* ... we need to set .parent to point to the class
1529 ... once we figure out what the class actually is :-)
1531 Type t = name(n).type;
1532 assert(isPolyType(t));
1533 if (isPolyType(t)) t = monotypeOf(t);
1534 assert(isQualType(t));
1535 t = fst(snd(t)); /* t :: [(Class,Offset)] */
1537 assert(nonNull(hd(t)));
1538 assert(isPair(hd(t)));
1539 t = fst(hd(t)); /* t :: Class */
1542 name(n).parent = t; /* phew! */
1547 /* --------------------------------------------------------------------------
1549 * ------------------------------------------------------------------------*/
1551 static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1553 /* tycon :: ConId */
1554 /* tvs :: [((VarId,Kind))] */
1556 Text t = textOf(tycon);
1558 fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1561 if (nonNull(findTycon(t))) {
1562 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1566 Tycon tc = newTycon(t);
1567 tycon(tc).line = line;
1568 tycon(tc).arity = length(tvs);
1569 tycon(tc).what = SYNONYM;
1570 tycon(tc).kind = tvsToKind(tvs);
1572 /* prepare for finishGHCSynonym */
1573 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
1578 static Void finishGHCSynonym ( ConId tyc )
1580 Tycon tc = findTycon(textOf(tyc));
1581 Int line = tycon(tc).line;
1583 fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1586 assert (currentModule == tycon(tc).mod);
1587 // setCurrModule(tycon(tc).mod);
1588 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1590 /* (ADR) ToDo: can't really do this until I've done all synonyms
1591 * and then I have to do them in order
1592 * tycon(tc).defn = fullExpand(ty);
1593 * (JRS) What?!?! i don't understand
1598 /* --------------------------------------------------------------------------
1600 * ------------------------------------------------------------------------*/
1602 static Type qualifyIfaceType ( Type unqual, List ctx )
1604 /* ctx :: [((QConId,VarId))] */
1605 /* ctx is a list of (class name, tyvar) pairs.
1606 Attach to unqual qualifiers taken from ctx
1607 for each tyvar which appears in unqual.
1609 List tyvarsMentioned; /* :: [VarId] */
1613 if (isPolyType(unqual)) {
1614 kinds = polySigOf(unqual);
1615 unqual = monotypeOf(unqual);
1618 assert(!isQualType(unqual));
1619 tyvarsMentioned = ifTyvarsIn ( unqual );
1620 for (; nonNull(ctx); ctx=tl(ctx)) {
1621 ZPair ctxElem = hd(ctx); /* :: ((QConId, VarId)) */
1622 if (nonNull(varIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1623 ctx2 = cons(ctxElem, ctx2);
1626 unqual = ap(QUAL,pair(reverse(ctx2),unqual));
1628 unqual = mkPolyType(kinds,unqual);
1633 static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1635 List ctx0; /* [((QConId,VarId))] */
1636 Cell tycon; /* ConId */
1637 List ktyvars; /* [((VarId,Kind))] */
1638 List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
1639 /* The Text is an optional field name
1640 The Int indicates strictness */
1641 /* ToDo: worry about being given a decl for (->) ?
1642 * and worry about qualidents for ()
1645 Type ty, resTy, selTy, conArgTy;
1646 List tmp, conArgs, sels, constrs, fields;
1649 Pair conArg, ctxElem;
1651 Int conArgStrictness;
1652 Int conStrictCompCount;
1654 Text t = textOf(tycon);
1656 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1660 if (nonNull(findTycon(t))) {
1661 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1665 Tycon tc = newTycon(t);
1667 tycon(tc).line = line;
1668 tycon(tc).arity = length(ktyvars);
1669 tycon(tc).kind = tvsToKind(ktyvars);
1670 tycon(tc).what = DATATYPE;
1672 /* a list to accumulate selectors in :: [((VarId,Type))] */
1675 /* make resTy the result type of the constr, T v1 ... vn */
1677 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1678 resTy = ap(resTy,zfst(hd(tmp)));
1680 /* for each constructor ... */
1681 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1682 constr = hd(constrs);
1683 conid = zfst(constr);
1684 fields = zsnd(constr);
1686 /* Build type of constr and handle any selectors found. */
1689 conStrictCompCount = 0;
1690 conArgs = reverse(fields);
1691 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1692 conArg = hd(conArgs); /* (Type,Text) */
1693 conArgTy = zfst3(conArg);
1694 conArgNm = zsnd3(conArg);
1695 conArgStrictness = intOf(zthd3(conArg));
1696 if (conArgStrictness > 0) conStrictCompCount++;
1697 ty = fn(conArgTy,ty);
1698 if (nonNull(conArgNm)) {
1699 /* a field name is mentioned too */
1700 selTy = fn(resTy,conArgTy);
1701 if (whatIs(tycon(tc).kind) != STAR)
1702 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1703 selTy = qualifyIfaceType ( selTy, ctx0 );
1704 selTy = tvsToOffsets(line,selTy, ktyvars);
1705 sels = cons( zpair(conArgNm,selTy), sels);
1709 /* Now ty is the constructor's type, not including context.
1710 Throw away any parts of the context not mentioned in ty,
1711 and use it to qualify ty.
1713 ty = qualifyIfaceType ( ty, ctx0 );
1715 /* stick the tycon's kind on, if not simply STAR */
1716 if (whatIs(tycon(tc).kind) != STAR)
1717 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1719 ty = tvsToOffsets(line,ty, ktyvars);
1721 /* Finally, stick the constructor's type onto it. */
1722 hd(constrs) = z4ble(conid,fields,ty,mkInt(conStrictCompCount));
1725 /* Final result is that
1726 constrs :: [((ConId,[((Type,Text))],Type,Int))]
1727 lists the constructors, their types and # strict comps
1728 sels :: [((VarId,Type))]
1729 lists the selectors and their types
1731 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1736 static List startGHCConstrs ( Int line, List cons, List sels )
1738 /* cons :: [((ConId,[((Type,Text,Int))],Type,Int))] */
1739 /* sels :: [((VarId,Type))] */
1740 /* returns [Name] */
1742 Int conNo = length(cons)>1 ? 1 : 0;
1743 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1744 Name c = startGHCConstr(line,conNo,hd(cs));
1747 /* cons :: [Name] */
1749 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1750 hd(ss) = startGHCSel(line,hd(ss));
1752 /* sels :: [Name] */
1753 return appendOnto(cons,sels);
1757 static Name startGHCSel ( Int line, ZPair sel )
1759 /* sel :: ((VarId, Type)) */
1760 Text t = textOf(zfst(sel));
1761 Type type = zsnd(sel);
1763 Name n = findName(t);
1765 ERRMSG(line) "Repeated definition for selector \"%s\"",
1771 name(n).line = line;
1772 name(n).number = SELNAME;
1775 name(n).type = type;
1780 static Name startGHCConstr ( Int line, Int conNo, Z4Ble constr )
1782 /* constr :: ((ConId,[((Type,Text,Int))],Type,Int)) */
1783 /* (ADR) ToDo: add rank2 annotation and existential annotation
1784 * these affect how constr can be used.
1786 Text con = textOf(zsel14(constr));
1787 Type type = zsel34(constr);
1788 Int arity = arityFromType(type);
1789 Int nStrict = intOf(zsel44(constr));
1790 Name n = findName(con); /* Allocate constructor fun name */
1792 n = newName(con,NIL);
1793 } else if (name(n).defn!=PREDEFINED) {
1794 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1798 name(n).arity = arity; /* Save constructor fun details */
1799 name(n).line = line;
1800 name(n).number = cfunNo(conNo);
1801 name(n).type = type;
1802 name(n).hasStrict = nStrict > 0;
1807 static List finishGHCDataDecl ( ConId tyc )
1810 Tycon tc = findTycon(textOf(tyc));
1812 fprintf ( stderr, "begin finishGHCDataDecl %s\n",
1813 textToStr(textOf(tyc)) );
1815 if (isNull(tc)) internal("finishGHCDataDecl");
1817 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1819 Int line = name(n).line;
1820 assert(currentModule == name(n).mod);
1821 name(n).type = conidcellsToTycons(line,name(n).type);
1822 name(n).parent = tc; //---????
1825 return tycon(tc).defn;
1829 /* --------------------------------------------------------------------------
1831 * ------------------------------------------------------------------------*/
1833 static Void startGHCNewType ( Int line, List ctx0,
1834 ConId tycon, List tvs, Cell constr )
1836 /* ctx0 :: [((QConId,VarId))] */
1837 /* tycon :: ConId */
1838 /* tvs :: [((VarId,Kind))] */
1839 /* constr :: ((ConId,Type)) or NIL if abstract */
1842 Text t = textOf(tycon);
1844 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1849 if (nonNull(findTycon(t))) {
1850 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1854 Tycon tc = newTycon(t);
1855 tycon(tc).line = line;
1856 tycon(tc).arity = length(tvs);
1857 tycon(tc).what = NEWTYPE;
1858 tycon(tc).kind = tvsToKind(tvs);
1859 /* can't really do this until I've read in all synonyms */
1861 if (isNull(constr)) {
1862 tycon(tc).defn = NIL;
1864 /* constr :: ((ConId,Type)) */
1865 Text con = textOf(zfst(constr));
1866 Type type = zsnd(constr);
1867 Name n = findName(con); /* Allocate constructor fun name */
1869 n = newName(con,NIL);
1870 } else if (name(n).defn!=PREDEFINED) {
1871 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1875 name(n).arity = 1; /* Save constructor fun details */
1876 name(n).line = line;
1877 name(n).number = cfunNo(0);
1878 name(n).defn = nameId;
1879 tycon(tc).defn = singleton(n);
1881 /* make resTy the result type of the constr, T v1 ... vn */
1883 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1884 resTy = ap(resTy,zfst(hd(tmp)));
1885 type = fn(type,resTy);
1887 type = ap(QUAL,pair(ctx0,type));
1888 type = tvsToOffsets(line,type,tvs);
1889 name(n).type = type;
1895 static Void finishGHCNewType ( ConId tyc )
1897 Tycon tc = findTycon(textOf(tyc));
1899 fprintf ( stderr, "begin finishGHCNewType %s\n",
1900 textToStr(textOf(tyc)) );
1903 if (isNull(tc)) internal("finishGHCNewType");
1905 if (isNull(tycon(tc).defn)) {
1906 /* it's an abstract type */
1908 else if (length(tycon(tc).defn) == 1) {
1909 /* As we expect, has a single constructor */
1910 Name n = hd(tycon(tc).defn);
1911 Int line = name(n).line;
1912 assert(currentModule == name(n).mod);
1913 name(n).type = conidcellsToTycons(line,name(n).type);
1915 internal("finishGHCNewType(2)");
1920 /* --------------------------------------------------------------------------
1921 * Class declarations
1922 * ------------------------------------------------------------------------*/
1924 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1926 List ctxt; /* [((QConId, VarId))] */
1927 ConId tc_name; /* ConId */
1928 List kinded_tvs; /* [((VarId, Kind))] */
1929 List mems0; { /* [((VarId, Type))] */
1931 List mems; /* [((VarId, Type))] */
1932 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1933 List tvs; /* [((VarId,Kind))] */
1934 List ns; /* [Name] */
1937 ZPair kinded_tv = hd(kinded_tvs);
1938 Text ct = textOf(tc_name);
1939 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1941 fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
1945 if (length(kinded_tvs) != 1) {
1946 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1950 if (nonNull(findClass(ct))) {
1951 ERRMSG(line) "Repeated definition of class \"%s\"",
1954 } else if (nonNull(findTycon(ct))) {
1955 ERRMSG(line) "\"%s\" used as both class and type constructor",
1959 Class nw = newClass(ct);
1960 cclass(nw).text = ct;
1961 cclass(nw).line = line;
1962 cclass(nw).arity = 1;
1963 cclass(nw).head = ap(nw,mkOffset(0));
1964 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1965 cclass(nw).instances = NIL;
1966 cclass(nw).numSupers = length(ctxt);
1968 /* Kludge to map the single tyvar in the context to Offset 0.
1969 Need to do something better for multiparam type classes.
1971 cclass(nw).supers = tvsToOffsets(line,ctxt,
1972 singleton(kinded_tv));
1975 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1976 ZPair mem = hd(mems);
1977 Type memT = zsnd(mem);
1978 Text mnt = textOf(zfst(mem));
1981 /* Stick the new context on the member type */
1982 memT = dictapsToQualtype(memT);
1983 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1984 if (whatIs(memT)==QUAL) {
1986 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1989 pair(singleton(newCtx),memT));
1992 /* Cook up a kind for the type. */
1993 tvsInT = ifTyvarsIn(memT);
1994 /* tvsInT :: [VarId] */
1996 /* ToDo: maximally bogus. We allow the class tyvar to
1997 have the kind as supplied by the parser, but we just
1998 assume that all others have kind *. It's a kludge.
2000 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
2002 if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
2003 k = zsnd(kinded_tv); else
2005 hd(tvs) = zpair(hd(tvs),k);
2007 /* tvsIntT :: [((VarId,Kind))] */
2009 memT = mkPolyType(tvsToKind(tvsInT),memT);
2010 memT = tvsToOffsets(line,memT,tvsInT);
2012 /* Park the type back on the member */
2013 mem = zpair(zfst(mem),memT);
2015 /* Bind code to the member */
2019 "Repeated definition for class method \"%s\"",
2023 mn = newName(mnt,NIL);
2028 cclass(nw).members = mems0;
2029 cclass(nw).numMembers = length(mems0);
2032 for (mno=0; mno<cclass(nw).numSupers; mno++) {
2033 ns = cons(newDSel(nw,mno),ns);
2035 cclass(nw).dsels = rev(ns);
2040 static Class finishGHCClass ( Tycon cls_tyc )
2045 Class nw = findClass ( textOf(cls_tyc) );
2047 fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
2049 if (isNull(nw)) internal("finishGHCClass");
2051 line = cclass(nw).line;
2053 assert (currentModule == cclass(nw).mod);
2055 cclass(nw).level = 0;
2056 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
2057 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
2058 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
2060 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2061 Pair mem = hd(mems); /* (VarId, Type) */
2062 Text txt = textOf(fst(mem));
2064 Name n = findName(txt);
2067 name(n).line = cclass(nw).line;
2069 name(n).number = ctr--;
2070 name(n).arity = arityInclDictParams(name(n).type);
2071 name(n).parent = nw;
2079 /* --------------------------------------------------------------------------
2081 * ------------------------------------------------------------------------*/
2083 static Inst startGHCInstance (line,ktyvars,cls,var)
2085 List ktyvars; /* [((VarId,Kind))] */
2086 Type cls; /* Type */
2087 VarId var; { /* VarId */
2088 List tmp, tvs, ks, spec;
2093 Inst in = newInst();
2095 fprintf ( stderr, "begin startGHCInstance\n" );
2100 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2102 The order of tvs is important for tvsToOffsets.
2103 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2104 out of ktyvars and attach them to tvs.
2106 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2108 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2109 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2111 if (isNull(k)) internal("startGHCInstance: finding kinds");
2112 hd(xs1) = zpair(hd(xs1),k);
2115 cls = tvsToOffsets(line,cls,tvs);
2118 spec = cons(fun(cls),spec);
2121 spec = reverse(spec);
2123 inst(in).line = line;
2124 inst(in).implements = NIL;
2125 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2126 inst(in).specifics = spec;
2127 inst(in).numSpecifics = length(spec);
2128 inst(in).head = cls;
2130 /* Figure out the name of the class being instanced, and store it
2131 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2133 Cell cl = inst(in).head;
2134 assert(whatIs(cl)==DICTAP);
2135 cl = unap(DICTAP,cl);
2137 assert ( isQCon(cl) );
2142 Name b = newName( /*inventText()*/ textOf(var),NIL);
2143 name(b).line = line;
2144 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2145 name(b).number = DFUNNAME;
2146 name(b).parent = in;
2147 inst(in).builder = b;
2148 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2155 static Void finishGHCInstance ( Inst in )
2162 fprintf ( stderr, "begin finishGHCInstance\n" );
2165 assert (nonNull(in));
2166 line = inst(in).line;
2167 assert (currentModule==inst(in).mod);
2169 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2170 since startGHCInstance couldn't possibly have resolved it to
2171 a Class at that point. We convert it to a Class now.
2175 c = findQualClassWithoutConsultingExportList(c);
2179 inst(in).head = conidcellsToTycons(line,inst(in).head);
2180 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2181 cclass(c).instances = cons(in,cclass(c).instances);
2185 /* --------------------------------------------------------------------------
2187 * ------------------------------------------------------------------------*/
2189 /* This is called from the startGHC* functions. It traverses a structure
2190 and converts varidcells, ie, type variables parsed by the interface
2191 parser, into Offsets, which is how Hugs wants to see them internally.
2192 The Offset for a type variable is determined by its place in the list
2193 passed as the second arg; the associated kinds are irrelevant.
2195 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2198 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2199 static Type tvsToOffsets(line,type,ktyvars)
2202 List ktyvars; { /* [((VarId,Kind))] */
2203 switch (whatIs(type)) {
2210 case ZTUP2: /* convert to the untyped representation */
2211 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2212 tvsToOffsets(line,zsnd(type),ktyvars) );
2214 return ap( tvsToOffsets(line,fun(type),ktyvars),
2215 tvsToOffsets(line,arg(type),ktyvars) );
2219 tvsToOffsets(line,monotypeOf(type),ktyvars)
2223 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2224 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2225 case DICTAP: /* bogus ?? */
2226 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2227 case UNBOXEDTUP: /* bogus?? */
2228 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2229 case BANG: /* bogus?? */
2230 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2231 case VARIDCELL: /* Ha! some real work to do! */
2233 Text tv = textOf(type);
2234 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2237 assert(isZPair(hd(ktyvars)));
2238 varid = zfst(hd(ktyvars));
2240 if (tv == tt) return mkOffset(i);
2242 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2247 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2249 fprintf(stderr,"\n");
2253 return NIL; /* NOTREACHED */
2257 /* This is called from the finishGHC* functions. It traverses a structure
2258 and converts conidcells, ie, type constructors parsed by the interface
2259 parser, into Tycons (or Classes), which is how Hugs wants to see them
2260 internally. Calls to this fn have to be deferred to the second phase
2261 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2262 Tycons or Classes have been loaded into the symbol tables and can be
2265 static Type conidcellsToTycons ( Int line, Type type )
2267 switch (whatIs(type)) {
2277 { Cell t; /* Tycon or Class */
2278 Text m = qmodOf(type);
2279 Module mod = findModule(m);
2282 "Undefined module in qualified name \"%s\"",
2287 t = findQualTyconWithoutConsultingExportList(type);
2288 if (nonNull(t)) return t;
2289 t = findQualClassWithoutConsultingExportList(type);
2290 if (nonNull(t)) return t;
2292 "Undefined qualified class or type \"%s\"",
2300 cl = findQualClass(type);
2301 if (nonNull(cl)) return cl;
2302 if (textOf(type)==findText("[]"))
2303 /* a hack; magically qualify [] into PrelBase.[] */
2304 return conidcellsToTycons(line,
2305 mkQualId(mkCon(findText("PrelBase")),type));
2306 tc = findQualTycon(type);
2307 if (nonNull(tc)) return tc;
2309 "Undefined class or type constructor \"%s\"",
2315 return ap( conidcellsToTycons(line,fun(type)),
2316 conidcellsToTycons(line,arg(type)) );
2317 case ZTUP2: /* convert to std pair */
2318 return ap( conidcellsToTycons(line,zfst(type)),
2319 conidcellsToTycons(line,zsnd(type)) );
2324 conidcellsToTycons(line,monotypeOf(type))
2328 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2329 conidcellsToTycons(line,snd(snd(type)))));
2330 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2331 Not sure if this is really the right place to
2332 convert it to the form Hugs wants, but will do so anyway.
2334 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2336 Class cl = fst(unap(DICTAP,type));
2337 List args = snd(unap(DICTAP,type));
2339 conidcellsToTycons(line,pair(cl,args));
2342 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2344 return ap(BANG, conidcellsToTycons(line, snd(type)));
2346 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2349 fprintf(stderr,"\n");
2353 return NIL; /* NOTREACHED */
2357 /* Find out if a type mentions a type constructor not present in
2358 the supplied list of qualified tycons.
2360 static Bool allTypesKnown ( Type type,
2361 List aktys /* [QualId] */,
2364 switch (whatIs(type)) {
2371 return allTypesKnown(fun(type),aktys,thisMod)
2372 && allTypesKnown(arg(type),aktys,thisMod);
2374 return allTypesKnown(zfst(type),aktys,thisMod)
2375 && allTypesKnown(zsnd(type),aktys,thisMod);
2377 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2380 if (textOf(type)==findText("[]"))
2381 /* a hack; magically qualify [] into PrelBase.[] */
2382 type = mkQualId(mkCon(findText("PrelBase")),type); else
2383 type = mkQualId(thisMod,type);
2386 if (isNull(qualidIsMember(type,aktys))) goto missing;
2392 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2393 print(type,10);printf("\n");
2394 internal("allTypesKnown");
2395 return TRUE; /*notreached*/
2399 fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
2400 fprintf(stderr,"\n");
2406 /* --------------------------------------------------------------------------
2409 * None of these do lookups or require that lookups have been resolved
2410 * so they can be performed while reading interfaces.
2411 * ------------------------------------------------------------------------*/
2413 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2414 static Kinds tvsToKind(tvs)
2415 List tvs; { /* [((VarId,Kind))] */
2418 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2419 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2420 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2421 r = ap(zsnd(hd(rs)),r);
2427 static Int arityInclDictParams ( Type type )
2430 if (isPolyType(type)) type = monotypeOf(type);
2432 if (whatIs(type) == QUAL)
2434 arity += length ( fst(snd(type)) );
2435 type = snd(snd(type));
2437 while (isAp(type) && getHead(type)==typeArrow) {
2444 /* arity of a constructor with this type */
2445 static Int arityFromType(type)
2448 if (isPolyType(type)) {
2449 type = monotypeOf(type);
2451 if (whatIs(type) == QUAL) {
2452 type = snd(snd(type));
2454 if (whatIs(type) == EXIST) {
2455 type = snd(snd(type));
2457 if (whatIs(type)==RANK2) {
2458 type = snd(snd(type));
2460 while (isAp(type) && getHead(type)==typeArrow) {
2468 /* ifTyvarsIn :: Type -> [VarId]
2469 The returned list has no duplicates -- is a set.
2471 static List ifTyvarsIn(type)
2473 List vs = typeVarsIn(type,NIL,NIL,NIL);
2475 for (; nonNull(vs2); vs2=tl(vs2))
2476 if (whatIs(hd(vs2)) != VARIDCELL)
2477 internal("ifTyvarsIn");
2483 /* --------------------------------------------------------------------------
2484 * General object symbol query stuff
2485 * ------------------------------------------------------------------------*/
2487 #define EXTERN_SYMS_ALLPLATFORMS \
2489 Sym(stg_gc_enter_1) \
2490 Sym(stg_gc_noregs) \
2498 Sym(stg_update_PAP) \
2499 Sym(stg_error_entry) \
2500 Sym(__ap_2_upd_info) \
2501 Sym(__ap_3_upd_info) \
2502 Sym(__ap_4_upd_info) \
2503 Sym(__ap_5_upd_info) \
2504 Sym(__ap_6_upd_info) \
2505 Sym(__ap_7_upd_info) \
2506 Sym(__ap_8_upd_info) \
2507 Sym(__sel_0_upd_info) \
2508 Sym(__sel_1_upd_info) \
2509 Sym(__sel_2_upd_info) \
2510 Sym(__sel_3_upd_info) \
2511 Sym(__sel_4_upd_info) \
2512 Sym(__sel_5_upd_info) \
2513 Sym(__sel_6_upd_info) \
2514 Sym(__sel_7_upd_info) \
2515 Sym(__sel_8_upd_info) \
2516 Sym(__sel_9_upd_info) \
2517 Sym(__sel_10_upd_info) \
2518 Sym(__sel_11_upd_info) \
2519 Sym(__sel_12_upd_info) \
2520 Sym(Upd_frame_info) \
2521 Sym(seq_frame_info) \
2522 Sym(CAF_BLACKHOLE_info) \
2523 Sym(IND_STATIC_info) \
2524 Sym(EMPTY_MVAR_info) \
2525 Sym(MUT_ARR_PTRS_FROZEN_info) \
2527 Sym(putMVarzh_fast) \
2528 Sym(newMVarzh_fast) \
2529 Sym(takeMVarzh_fast) \
2530 Sym(takeMaybeMVarzh_fast) \
2535 Sym(killThreadzh_fast) \
2536 Sym(waitReadzh_fast) \
2537 Sym(waitWritezh_fast) \
2538 Sym(CHARLIKE_closure) \
2539 Sym(INTLIKE_closure) \
2540 Sym(suspendThread) \
2542 Sym(stackOverflow) \
2543 Sym(int2Integerzh_fast) \
2544 Sym(stg_gc_unbx_r1) \
2546 Sym(mkForeignObjzh_fast) \
2547 Sym(__encodeDouble) \
2548 Sym(decodeDoublezh_fast) \
2550 Sym(isDoubleInfinite) \
2551 Sym(isDoubleDenormalized) \
2552 Sym(isDoubleNegativeZero) \
2553 Sym(__encodeFloat) \
2554 Sym(decodeFloatzh_fast) \
2556 Sym(isFloatInfinite) \
2557 Sym(isFloatDenormalized) \
2558 Sym(isFloatNegativeZero) \
2559 Sym(__int_encodeFloat) \
2560 Sym(__int_encodeDouble) \
2564 Sym(gcdIntegerzh_fast) \
2565 Sym(newArrayzh_fast) \
2566 Sym(unsafeThawArrayzh_fast) \
2567 Sym(newDoubleArrayzh_fast) \
2568 Sym(newFloatArrayzh_fast) \
2569 Sym(newAddrArrayzh_fast) \
2570 Sym(newWordArrayzh_fast) \
2571 Sym(newIntArrayzh_fast) \
2572 Sym(newCharArrayzh_fast) \
2573 Sym(newMutVarzh_fast) \
2574 Sym(quotRemIntegerzh_fast) \
2575 Sym(quotIntegerzh_fast) \
2576 Sym(remIntegerzh_fast) \
2577 Sym(divExactIntegerzh_fast) \
2578 Sym(divModIntegerzh_fast) \
2579 Sym(timesIntegerzh_fast) \
2580 Sym(minusIntegerzh_fast) \
2581 Sym(plusIntegerzh_fast) \
2582 Sym(addr2Integerzh_fast) \
2583 Sym(mkWeakzh_fast) \
2586 Sym(resetNonBlockingFd) \
2588 Sym(stable_ptr_table) \
2589 Sym(createAdjThunk) \
2590 Sym(shutdownHaskellAndExit) \
2591 Sym(stg_enterStackTop) \
2592 Sym(CAF_UNENTERED_entry) \
2593 Sym(stg_yield_to_Hugs) \
2596 Sym(blockAsyncExceptionszh_fast) \
2597 Sym(unblockAsyncExceptionszh_fast) \
2599 /* needed by libHS_cbits */ \
2632 #define EXTERN_SYMS_cygwin32 \
2633 SymX(GetCurrentProcess) \
2634 SymX(GetProcessTimes) \
2643 SymX(__imp__tzname) \
2644 SymX(__imp__timezone) \
2669 #define EXTERN_SYMS_linux \
2670 Sym(__errno_location) \
2688 #define EXTERN_SYMS_solaris2 \
2689 SymX(gettimeofday) \
2692 #if defined(linux_TARGET_OS)
2693 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
2696 #if defined(solaris2_TARGET_OS)
2697 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
2700 #if defined(cygwin32_TARGET_OS)
2701 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
2706 /* entirely bogus claims about types of these symbols */
2707 #define Sym(vvv) extern void (vvv);
2708 #define SymX(vvv) /**/
2709 EXTERN_SYMS_ALLPLATFORMS
2710 EXTERN_SYMS_THISPLATFORM
2715 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2717 #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2721 EXTERN_SYMS_ALLPLATFORMS
2722 EXTERN_SYMS_THISPLATFORM
2731 /* A kludge to assist Win32 debugging. */
2732 char* nameFromStaticOPtr ( void* ptr )
2735 for (k = 0; rtsTab[k].nm; k++)
2736 if (ptr == rtsTab[k].ad)
2737 return rtsTab[k].nm;
2742 void* lookupObjName ( char* nm )
2750 int first_real_char;
2753 strncpy(nm2,nm,200);
2755 /* first see if it's an RTS name */
2756 for (k = 0; rtsTab[k].nm; k++)
2757 if (0==strcmp(nm2,rtsTab[k].nm))
2758 return rtsTab[k].ad;
2760 /* perhaps an extra-symbol ? */
2761 a = lookupOExtraTabName ( nm );
2764 # if LEADING_UNDERSCORE
2765 first_real_char = 1;
2767 first_real_char = 0;
2770 /* Maybe it's an __init_Module thing? */
2771 if (strlen(nm2+first_real_char) > 7
2772 && strncmp(nm2+first_real_char, "__init_", 7)==0) {
2773 t = unZcodeThenFindText(nm2+first_real_char+7);
2774 if (t == findText("PrelGHC")) return (4+NULL); /* kludge */
2776 if (isNull(m)) goto dire_straits;
2777 a = lookupOTabName ( m, nm );
2782 /* if not an RTS name, look in the
2783 relevant module's object symbol table
2785 pp = strchr(nm2+first_real_char, '_');
2786 if (!pp || !isupper(nm2[first_real_char])) goto dire_straits;
2788 t = unZcodeThenFindText(nm2+first_real_char);
2790 if (isNull(m)) goto dire_straits;
2792 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2796 /* make a desperate, last-ditch attempt to find it */
2797 a = lookupOTabNameAbsolutelyEverywhere ( nm );
2801 "lookupObjName: can't resolve name `%s'\n",
2808 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2810 OSectionKind sk = lookupSection(p);
2811 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2812 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2816 int is_dynamically_loaded_rwdata_ptr ( char* p )
2818 OSectionKind sk = lookupSection(p);
2819 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2820 return (sk == HUGS_SECTIONKIND_RWDATA);
2824 int is_not_dynamically_loaded_ptr ( char* p )
2826 OSectionKind sk = lookupSection(p);
2827 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2828 return (sk == HUGS_SECTIONKIND_OTHER);
2832 /* --------------------------------------------------------------------------
2834 * ------------------------------------------------------------------------*/
2836 Void interface(what)
2839 case POSTPREL: break;
2843 ifaces_outstanding = NIL;
2846 mark(ifaces_outstanding);
2851 /*-------------------------------------------------------------------------*/