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/05 10:25:08 $
12 * ------------------------------------------------------------------------*/
14 #include "hugsbasictypes.h"
20 #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 Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1605 List ctx0; /* [((QConId,VarId))] */
1606 Cell tycon; /* ConId */
1607 List ktyvars; /* [((VarId,Kind))] */
1608 List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
1609 /* The Text is an optional field name
1610 The Int indicates strictness */
1611 /* ToDo: worry about being given a decl for (->) ?
1612 * and worry about qualidents for ()
1615 Type ty, resTy, selTy, conArgTy;
1616 List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
1620 Pair conArg, ctxElem;
1622 Int conArgStrictness;
1623 Int conStrictCompCount;
1625 Text t = textOf(tycon);
1627 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1631 if (nonNull(findTycon(t))) {
1632 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1636 Tycon tc = newTycon(t);
1638 tycon(tc).line = line;
1639 tycon(tc).arity = length(ktyvars);
1640 tycon(tc).kind = tvsToKind(ktyvars);
1641 tycon(tc).what = DATATYPE;
1643 /* a list to accumulate selectors in :: [((VarId,Type))] */
1646 /* make resTy the result type of the constr, T v1 ... vn */
1648 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1649 resTy = ap(resTy,zfst(hd(tmp)));
1651 /* for each constructor ... */
1652 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1653 constr = hd(constrs);
1654 conid = zfst(constr);
1655 fields = zsnd(constr);
1657 /* Build type of constr and handle any selectors found.
1658 Also collect up tyvars occurring in the constr's arg
1659 types, so we can throw away irrelevant parts of the
1663 tyvarsMentioned = NIL;
1664 /* tyvarsMentioned :: [VarId] */
1666 conStrictCompCount = 0;
1667 conArgs = reverse(fields);
1668 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1669 conArg = hd(conArgs); /* (Type,Text) */
1670 conArgTy = zfst3(conArg);
1671 conArgNm = zsnd3(conArg);
1672 conArgStrictness = intOf(zthd3(conArg));
1673 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1675 if (conArgStrictness > 0) conStrictCompCount++;
1676 ty = fn(conArgTy,ty);
1677 if (nonNull(conArgNm)) {
1678 /* a field name is mentioned too */
1679 selTy = fn(resTy,conArgTy);
1680 if (whatIs(tycon(tc).kind) != STAR)
1681 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1682 selTy = tvsToOffsets(line,selTy, ktyvars);
1683 sels = cons( zpair(conArgNm,selTy), sels);
1687 /* Now ty is the constructor's type, not including context.
1688 Throw away any parts of the context not mentioned in
1689 tyvarsMentioned, and use it to qualify ty.
1692 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1694 /* ctxElem :: ((QConId,VarId)) */
1695 if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1696 ctx2 = cons(ctxElem, ctx2);
1699 ty = ap(QUAL,pair(ctx2,ty));
1701 /* stick the tycon's kind on, if not simply STAR */
1702 if (whatIs(tycon(tc).kind) != STAR)
1703 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1705 ty = tvsToOffsets(line,ty, ktyvars);
1707 /* Finally, stick the constructor's type onto it. */
1708 hd(constrs) = z4ble(conid,fields,ty,mkInt(conStrictCompCount));
1711 /* Final result is that
1712 constrs :: [((ConId,[((Type,Text))],Type,Int))]
1713 lists the constructors, their types and # strict comps
1714 sels :: [((VarId,Type))]
1715 lists the selectors and their types
1717 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1722 static List startGHCConstrs ( Int line, List cons, List sels )
1724 /* cons :: [((ConId,[((Type,Text,Int))],Type,Int))] */
1725 /* sels :: [((VarId,Type))] */
1726 /* returns [Name] */
1728 Int conNo = length(cons)>1 ? 1 : 0;
1729 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1730 Name c = startGHCConstr(line,conNo,hd(cs));
1733 /* cons :: [Name] */
1735 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1736 hd(ss) = startGHCSel(line,hd(ss));
1738 /* sels :: [Name] */
1739 return appendOnto(cons,sels);
1743 static Name startGHCSel ( Int line, ZPair sel )
1745 /* sel :: ((VarId, Type)) */
1746 Text t = textOf(zfst(sel));
1747 Type type = zsnd(sel);
1749 Name n = findName(t);
1751 ERRMSG(line) "Repeated definition for selector \"%s\"",
1757 name(n).line = line;
1758 name(n).number = SELNAME;
1761 name(n).type = type;
1766 static Name startGHCConstr ( Int line, Int conNo, Z4Ble constr )
1768 /* constr :: ((ConId,[((Type,Text,Int))],Type,Int)) */
1769 /* (ADR) ToDo: add rank2 annotation and existential annotation
1770 * these affect how constr can be used.
1772 Text con = textOf(zsel14(constr));
1773 Type type = zsel34(constr);
1774 Int arity = arityFromType(type);
1775 Int nStrict = intOf(zsel44(constr));
1776 Name n = findName(con); /* Allocate constructor fun name */
1778 n = newName(con,NIL);
1779 } else if (name(n).defn!=PREDEFINED) {
1780 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1784 name(n).arity = arity; /* Save constructor fun details */
1785 name(n).line = line;
1786 name(n).number = cfunNo(conNo);
1787 name(n).type = type;
1788 name(n).hasStrict = nStrict > 0;
1793 static List finishGHCDataDecl ( ConId tyc )
1796 Tycon tc = findTycon(textOf(tyc));
1798 fprintf ( stderr, "begin finishGHCDataDecl %s\n",
1799 textToStr(textOf(tyc)) );
1801 if (isNull(tc)) internal("finishGHCDataDecl");
1803 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1805 Int line = name(n).line;
1806 assert(currentModule == name(n).mod);
1807 name(n).type = conidcellsToTycons(line,name(n).type);
1808 name(n).parent = tc; //---????
1811 return tycon(tc).defn;
1815 /* --------------------------------------------------------------------------
1817 * ------------------------------------------------------------------------*/
1819 static Void startGHCNewType ( Int line, List ctx0,
1820 ConId tycon, List tvs, Cell constr )
1822 /* ctx0 :: [((QConId,VarId))] */
1823 /* tycon :: ConId */
1824 /* tvs :: [((VarId,Kind))] */
1825 /* constr :: ((ConId,Type)) or NIL if abstract */
1828 Text t = textOf(tycon);
1830 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1835 if (nonNull(findTycon(t))) {
1836 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1840 Tycon tc = newTycon(t);
1841 tycon(tc).line = line;
1842 tycon(tc).arity = length(tvs);
1843 tycon(tc).what = NEWTYPE;
1844 tycon(tc).kind = tvsToKind(tvs);
1845 /* can't really do this until I've read in all synonyms */
1847 if (isNull(constr)) {
1848 tycon(tc).defn = NIL;
1850 /* constr :: ((ConId,Type)) */
1851 Text con = textOf(zfst(constr));
1852 Type type = zsnd(constr);
1853 Name n = findName(con); /* Allocate constructor fun name */
1855 n = newName(con,NIL);
1856 } else if (name(n).defn!=PREDEFINED) {
1857 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1861 name(n).arity = 1; /* Save constructor fun details */
1862 name(n).line = line;
1863 name(n).number = cfunNo(0);
1864 name(n).defn = nameId;
1865 tycon(tc).defn = singleton(n);
1867 /* make resTy the result type of the constr, T v1 ... vn */
1869 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1870 resTy = ap(resTy,zfst(hd(tmp)));
1871 type = fn(type,resTy);
1873 type = ap(QUAL,pair(ctx0,type));
1874 type = tvsToOffsets(line,type,tvs);
1875 name(n).type = type;
1881 static Void finishGHCNewType ( ConId tyc )
1883 Tycon tc = findTycon(textOf(tyc));
1885 fprintf ( stderr, "begin finishGHCNewType %s\n",
1886 textToStr(textOf(tyc)) );
1889 if (isNull(tc)) internal("finishGHCNewType");
1891 if (isNull(tycon(tc).defn)) {
1892 /* it's an abstract type */
1894 else if (length(tycon(tc).defn) == 1) {
1895 /* As we expect, has a single constructor */
1896 Name n = hd(tycon(tc).defn);
1897 Int line = name(n).line;
1898 assert(currentModule == name(n).mod);
1899 name(n).type = conidcellsToTycons(line,name(n).type);
1901 internal("finishGHCNewType(2)");
1906 /* --------------------------------------------------------------------------
1907 * Class declarations
1908 * ------------------------------------------------------------------------*/
1910 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1912 List ctxt; /* [((QConId, VarId))] */
1913 ConId tc_name; /* ConId */
1914 List kinded_tvs; /* [((VarId, Kind))] */
1915 List mems0; { /* [((VarId, Type))] */
1917 List mems; /* [((VarId, Type))] */
1918 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1919 List tvs; /* [((VarId,Kind))] */
1920 List ns; /* [Name] */
1923 ZPair kinded_tv = hd(kinded_tvs);
1924 Text ct = textOf(tc_name);
1925 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1927 fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
1931 if (length(kinded_tvs) != 1) {
1932 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1936 if (nonNull(findClass(ct))) {
1937 ERRMSG(line) "Repeated definition of class \"%s\"",
1940 } else if (nonNull(findTycon(ct))) {
1941 ERRMSG(line) "\"%s\" used as both class and type constructor",
1945 Class nw = newClass(ct);
1946 cclass(nw).text = ct;
1947 cclass(nw).line = line;
1948 cclass(nw).arity = 1;
1949 cclass(nw).head = ap(nw,mkOffset(0));
1950 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1951 cclass(nw).instances = NIL;
1952 cclass(nw).numSupers = length(ctxt);
1954 /* Kludge to map the single tyvar in the context to Offset 0.
1955 Need to do something better for multiparam type classes.
1957 cclass(nw).supers = tvsToOffsets(line,ctxt,
1958 singleton(kinded_tv));
1961 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1962 ZPair mem = hd(mems);
1963 Type memT = zsnd(mem);
1964 Text mnt = textOf(zfst(mem));
1967 /* Stick the new context on the member type */
1968 memT = dictapsToQualtype(memT);
1969 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1970 if (whatIs(memT)==QUAL) {
1972 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1975 pair(singleton(newCtx),memT));
1978 /* Cook up a kind for the type. */
1979 tvsInT = ifTyvarsIn(memT);
1980 /* tvsInT :: [VarId] */
1982 /* ToDo: maximally bogus. We allow the class tyvar to
1983 have the kind as supplied by the parser, but we just
1984 assume that all others have kind *. It's a kludge.
1986 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
1988 if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
1989 k = zsnd(kinded_tv); else
1991 hd(tvs) = zpair(hd(tvs),k);
1993 /* tvsIntT :: [((VarId,Kind))] */
1995 memT = mkPolyType(tvsToKind(tvsInT),memT);
1996 memT = tvsToOffsets(line,memT,tvsInT);
1998 /* Park the type back on the member */
1999 mem = zpair(zfst(mem),memT);
2001 /* Bind code to the member */
2005 "Repeated definition for class method \"%s\"",
2009 mn = newName(mnt,NIL);
2014 cclass(nw).members = mems0;
2015 cclass(nw).numMembers = length(mems0);
2018 for (mno=0; mno<cclass(nw).numSupers; mno++) {
2019 ns = cons(newDSel(nw,mno),ns);
2021 cclass(nw).dsels = rev(ns);
2026 static Class finishGHCClass ( Tycon cls_tyc )
2031 Class nw = findClass ( textOf(cls_tyc) );
2033 fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
2035 if (isNull(nw)) internal("finishGHCClass");
2037 line = cclass(nw).line;
2039 assert (currentModule == cclass(nw).mod);
2041 cclass(nw).level = 0;
2042 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
2043 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
2044 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
2046 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2047 Pair mem = hd(mems); /* (VarId, Type) */
2048 Text txt = textOf(fst(mem));
2050 Name n = findName(txt);
2053 name(n).line = cclass(nw).line;
2055 name(n).number = ctr--;
2056 name(n).arity = arityInclDictParams(name(n).type);
2057 name(n).parent = nw;
2065 /* --------------------------------------------------------------------------
2067 * ------------------------------------------------------------------------*/
2069 static Inst startGHCInstance (line,ktyvars,cls,var)
2071 List ktyvars; /* [((VarId,Kind))] */
2072 Type cls; /* Type */
2073 VarId var; { /* VarId */
2074 List tmp, tvs, ks, spec;
2079 Inst in = newInst();
2081 fprintf ( stderr, "begin startGHCInstance\n" );
2086 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2088 The order of tvs is important for tvsToOffsets.
2089 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2090 out of ktyvars and attach them to tvs.
2092 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2094 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2095 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2097 if (isNull(k)) internal("startGHCInstance: finding kinds");
2098 hd(xs1) = zpair(hd(xs1),k);
2101 cls = tvsToOffsets(line,cls,tvs);
2104 spec = cons(fun(cls),spec);
2107 spec = reverse(spec);
2109 inst(in).line = line;
2110 inst(in).implements = NIL;
2111 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2112 inst(in).specifics = spec;
2113 inst(in).numSpecifics = length(spec);
2114 inst(in).head = cls;
2116 /* Figure out the name of the class being instanced, and store it
2117 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2119 Cell cl = inst(in).head;
2120 assert(whatIs(cl)==DICTAP);
2121 cl = unap(DICTAP,cl);
2123 assert ( isQCon(cl) );
2128 Name b = newName( /*inventText()*/ textOf(var),NIL);
2129 name(b).line = line;
2130 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2131 name(b).number = DFUNNAME;
2132 name(b).parent = in;
2133 inst(in).builder = b;
2134 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2141 static Void finishGHCInstance ( Inst in )
2148 fprintf ( stderr, "begin finishGHCInstance\n" );
2151 assert (nonNull(in));
2152 line = inst(in).line;
2153 assert (currentModule==inst(in).mod);
2155 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2156 since startGHCInstance couldn't possibly have resolved it to
2157 a Class at that point. We convert it to a Class now.
2161 c = findQualClassWithoutConsultingExportList(c);
2165 inst(in).head = conidcellsToTycons(line,inst(in).head);
2166 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2167 cclass(c).instances = cons(in,cclass(c).instances);
2171 /* --------------------------------------------------------------------------
2173 * ------------------------------------------------------------------------*/
2175 /* This is called from the startGHC* functions. It traverses a structure
2176 and converts varidcells, ie, type variables parsed by the interface
2177 parser, into Offsets, which is how Hugs wants to see them internally.
2178 The Offset for a type variable is determined by its place in the list
2179 passed as the second arg; the associated kinds are irrelevant.
2181 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2184 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2185 static Type tvsToOffsets(line,type,ktyvars)
2188 List ktyvars; { /* [((VarId,Kind))] */
2189 switch (whatIs(type)) {
2196 case ZTUP2: /* convert to the untyped representation */
2197 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2198 tvsToOffsets(line,zsnd(type),ktyvars) );
2200 return ap( tvsToOffsets(line,fun(type),ktyvars),
2201 tvsToOffsets(line,arg(type),ktyvars) );
2205 tvsToOffsets(line,monotypeOf(type),ktyvars)
2209 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2210 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2211 case DICTAP: /* bogus ?? */
2212 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2213 case UNBOXEDTUP: /* bogus?? */
2214 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2215 case BANG: /* bogus?? */
2216 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2217 case VARIDCELL: /* Ha! some real work to do! */
2219 Text tv = textOf(type);
2220 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2223 assert(isZPair(hd(ktyvars)));
2224 varid = zfst(hd(ktyvars));
2226 if (tv == tt) return mkOffset(i);
2228 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2233 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2235 fprintf(stderr,"\n");
2239 return NIL; /* NOTREACHED */
2243 /* This is called from the finishGHC* functions. It traverses a structure
2244 and converts conidcells, ie, type constructors parsed by the interface
2245 parser, into Tycons (or Classes), which is how Hugs wants to see them
2246 internally. Calls to this fn have to be deferred to the second phase
2247 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2248 Tycons or Classes have been loaded into the symbol tables and can be
2251 static Type conidcellsToTycons ( Int line, Type type )
2253 switch (whatIs(type)) {
2263 { Cell t; /* Tycon or Class */
2264 Text m = qmodOf(type);
2265 Module mod = findModule(m);
2268 "Undefined module in qualified name \"%s\"",
2273 t = findQualTyconWithoutConsultingExportList(type);
2274 if (nonNull(t)) return t;
2275 t = findQualClassWithoutConsultingExportList(type);
2276 if (nonNull(t)) return t;
2278 "Undefined qualified class or type \"%s\"",
2286 cl = findQualClass(type);
2287 if (nonNull(cl)) return cl;
2288 if (textOf(type)==findText("[]"))
2289 /* a hack; magically qualify [] into PrelBase.[] */
2290 return conidcellsToTycons(line,
2291 mkQualId(mkCon(findText("PrelBase")),type));
2292 tc = findQualTycon(type);
2293 if (nonNull(tc)) return tc;
2295 "Undefined class or type constructor \"%s\"",
2301 return ap( conidcellsToTycons(line,fun(type)),
2302 conidcellsToTycons(line,arg(type)) );
2303 case ZTUP2: /* convert to std pair */
2304 return ap( conidcellsToTycons(line,zfst(type)),
2305 conidcellsToTycons(line,zsnd(type)) );
2310 conidcellsToTycons(line,monotypeOf(type))
2314 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2315 conidcellsToTycons(line,snd(snd(type)))));
2316 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2317 Not sure if this is really the right place to
2318 convert it to the form Hugs wants, but will do so anyway.
2320 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2322 Class cl = fst(unap(DICTAP,type));
2323 List args = snd(unap(DICTAP,type));
2325 conidcellsToTycons(line,pair(cl,args));
2328 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2330 return ap(BANG, conidcellsToTycons(line, snd(type)));
2332 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2335 fprintf(stderr,"\n");
2339 return NIL; /* NOTREACHED */
2343 /* Find out if a type mentions a type constructor not present in
2344 the supplied list of qualified tycons.
2346 static Bool allTypesKnown ( Type type,
2347 List aktys /* [QualId] */,
2350 switch (whatIs(type)) {
2357 return allTypesKnown(fun(type),aktys,thisMod)
2358 && allTypesKnown(arg(type),aktys,thisMod);
2360 return allTypesKnown(zfst(type),aktys,thisMod)
2361 && allTypesKnown(zsnd(type),aktys,thisMod);
2363 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2366 if (textOf(type)==findText("[]"))
2367 /* a hack; magically qualify [] into PrelBase.[] */
2368 type = mkQualId(mkCon(findText("PrelBase")),type); else
2369 type = mkQualId(thisMod,type);
2372 if (isNull(qualidIsMember(type,aktys))) goto missing;
2378 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2379 print(type,10);printf("\n");
2380 internal("allTypesKnown");
2381 return TRUE; /*notreached*/
2385 fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
2386 fprintf(stderr,"\n");
2392 /* --------------------------------------------------------------------------
2395 * None of these do lookups or require that lookups have been resolved
2396 * so they can be performed while reading interfaces.
2397 * ------------------------------------------------------------------------*/
2399 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2400 static Kinds tvsToKind(tvs)
2401 List tvs; { /* [((VarId,Kind))] */
2404 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2405 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2406 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2407 r = ap(zsnd(hd(rs)),r);
2413 static Int arityInclDictParams ( Type type )
2416 if (isPolyType(type)) type = monotypeOf(type);
2418 if (whatIs(type) == QUAL)
2420 arity += length ( fst(snd(type)) );
2421 type = snd(snd(type));
2423 while (isAp(type) && getHead(type)==typeArrow) {
2430 /* arity of a constructor with this type */
2431 static Int arityFromType(type)
2434 if (isPolyType(type)) {
2435 type = monotypeOf(type);
2437 if (whatIs(type) == QUAL) {
2438 type = snd(snd(type));
2440 if (whatIs(type) == EXIST) {
2441 type = snd(snd(type));
2443 if (whatIs(type)==RANK2) {
2444 type = snd(snd(type));
2446 while (isAp(type) && getHead(type)==typeArrow) {
2454 /* ifTyvarsIn :: Type -> [VarId]
2455 The returned list has no duplicates -- is a set.
2457 static List ifTyvarsIn(type)
2459 List vs = typeVarsIn(type,NIL,NIL,NIL);
2461 for (; nonNull(vs2); vs2=tl(vs2))
2462 if (whatIs(hd(vs2)) != VARIDCELL)
2463 internal("ifTyvarsIn");
2469 /* --------------------------------------------------------------------------
2470 * General object symbol query stuff
2471 * ------------------------------------------------------------------------*/
2473 #define EXTERN_SYMS_ALLPLATFORMS \
2475 Sym(stg_gc_enter_1) \
2476 Sym(stg_gc_noregs) \
2484 Sym(stg_update_PAP) \
2485 Sym(stg_error_entry) \
2486 Sym(__ap_2_upd_info) \
2487 Sym(__ap_3_upd_info) \
2488 Sym(__ap_4_upd_info) \
2489 Sym(__ap_5_upd_info) \
2490 Sym(__ap_6_upd_info) \
2491 Sym(__ap_7_upd_info) \
2492 Sym(__ap_8_upd_info) \
2493 Sym(__sel_0_upd_info) \
2494 Sym(__sel_1_upd_info) \
2495 Sym(__sel_2_upd_info) \
2496 Sym(__sel_3_upd_info) \
2497 Sym(__sel_4_upd_info) \
2498 Sym(__sel_5_upd_info) \
2499 Sym(__sel_6_upd_info) \
2500 Sym(__sel_7_upd_info) \
2501 Sym(__sel_8_upd_info) \
2502 Sym(__sel_9_upd_info) \
2503 Sym(__sel_10_upd_info) \
2504 Sym(__sel_11_upd_info) \
2505 Sym(__sel_12_upd_info) \
2506 Sym(Upd_frame_info) \
2507 Sym(seq_frame_info) \
2508 Sym(CAF_BLACKHOLE_info) \
2509 Sym(IND_STATIC_info) \
2510 Sym(EMPTY_MVAR_info) \
2511 Sym(MUT_ARR_PTRS_FROZEN_info) \
2513 Sym(putMVarzh_fast) \
2514 Sym(newMVarzh_fast) \
2515 Sym(takeMVarzh_fast) \
2520 Sym(killThreadzh_fast) \
2521 Sym(waitReadzh_fast) \
2522 Sym(waitWritezh_fast) \
2523 Sym(CHARLIKE_closure) \
2524 Sym(INTLIKE_closure) \
2525 Sym(suspendThread) \
2527 Sym(stackOverflow) \
2528 Sym(int2Integerzh_fast) \
2529 Sym(stg_gc_unbx_r1) \
2531 Sym(makeForeignObjzh_fast) \
2532 Sym(__encodeDouble) \
2533 Sym(decodeDoublezh_fast) \
2535 Sym(isDoubleInfinite) \
2536 Sym(isDoubleDenormalized) \
2537 Sym(isDoubleNegativeZero) \
2538 Sym(__encodeFloat) \
2539 Sym(decodeFloatzh_fast) \
2541 Sym(isFloatInfinite) \
2542 Sym(isFloatDenormalized) \
2543 Sym(isFloatNegativeZero) \
2544 Sym(__int_encodeFloat) \
2545 Sym(__int_encodeDouble) \
2549 Sym(gcdIntegerzh_fast) \
2550 Sym(newArrayzh_fast) \
2551 Sym(unsafeThawArrayzh_fast) \
2552 Sym(newDoubleArrayzh_fast) \
2553 Sym(newFloatArrayzh_fast) \
2554 Sym(newAddrArrayzh_fast) \
2555 Sym(newWordArrayzh_fast) \
2556 Sym(newIntArrayzh_fast) \
2557 Sym(newCharArrayzh_fast) \
2558 Sym(newMutVarzh_fast) \
2559 Sym(quotRemIntegerzh_fast) \
2560 Sym(quotIntegerzh_fast) \
2561 Sym(remIntegerzh_fast) \
2562 Sym(divExactIntegerzh_fast) \
2563 Sym(divModIntegerzh_fast) \
2564 Sym(timesIntegerzh_fast) \
2565 Sym(minusIntegerzh_fast) \
2566 Sym(plusIntegerzh_fast) \
2567 Sym(addr2Integerzh_fast) \
2568 Sym(mkWeakzh_fast) \
2571 Sym(resetNonBlockingFd) \
2573 Sym(stable_ptr_table) \
2574 Sym(createAdjThunk) \
2575 Sym(shutdownHaskellAndExit) \
2576 Sym(stg_enterStackTop) \
2577 Sym(CAF_UNENTERED_entry) \
2578 Sym(stg_yield_to_Hugs) \
2582 /* needed by libHS_cbits */ \
2616 #define EXTERN_SYMS_cygwin32 \
2617 SymX(GetCurrentProcess) \
2618 SymX(GetProcessTimes) \
2627 SymX(__imp__tzname) \
2628 SymX(__imp__timezone) \
2647 #define EXTERN_SYMS_linux \
2648 Sym(__errno_location) \
2666 #if defined(linux_TARGET_OS)
2667 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
2670 #if defined(solaris2_TARGET_OS)
2671 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
2674 #if defined(cygwin32_TARGET_OS)
2675 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
2681 /* entirely bogus claims about types of these symbols */
2682 #define Sym(vvv) extern void (vvv);
2683 #define SymX(vvv) /**/
2684 EXTERN_SYMS_ALLPLATFORMS
2685 EXTERN_SYMS_THISPLATFORM
2690 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2692 #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2696 EXTERN_SYMS_ALLPLATFORMS
2697 EXTERN_SYMS_THISPLATFORM
2707 /* A kludge to assist Win32 debugging. */
2708 char* nameFromStaticOPtr ( void* ptr )
2711 for (k = 0; rtsTab[k].nm; k++)
2712 if (ptr == rtsTab[k].ad)
2713 return rtsTab[k].nm;
2718 void* lookupObjName ( char* nm )
2726 int first_real_char;
2729 strncpy(nm2,nm,200);
2731 /* first see if it's an RTS name */
2732 for (k = 0; rtsTab[k].nm; k++)
2733 if (0==strcmp(nm2,rtsTab[k].nm))
2734 return rtsTab[k].ad;
2736 /* perhaps an extra-symbol ? */
2737 a = lookupOExtraTabName ( nm );
2740 # if LEADING_UNDERSCORE
2741 first_real_char = 1;
2743 first_real_char = 0;
2746 /* Maybe it's an __init_Module thing? */
2747 if (strlen(nm2+first_real_char) > 7
2748 && strncmp(nm2+first_real_char, "__init_", 7)==0) {
2749 t = unZcodeThenFindText(nm2+first_real_char+7);
2750 if (t == findText("PrelGHC")) return (4+NULL); /* kludge */
2752 if (isNull(m)) goto not_found;
2753 a = lookupOTabName ( m, nm );
2758 /* if not an RTS name, look in the
2759 relevant module's object symbol table
2761 pp = strchr(nm2+first_real_char, '_');
2762 if (!pp || !isupper(nm2[first_real_char])) goto not_found;
2764 t = unZcodeThenFindText(nm2+first_real_char);
2766 if (isNull(m)) goto not_found;
2768 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2773 "lookupObjName: can't resolve name `%s'\n",
2780 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2782 OSectionKind sk = lookupSection(p);
2783 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2784 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2788 int is_dynamically_loaded_rwdata_ptr ( char* p )
2790 OSectionKind sk = lookupSection(p);
2791 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2792 return (sk == HUGS_SECTIONKIND_RWDATA);
2796 int is_not_dynamically_loaded_ptr ( char* p )
2798 OSectionKind sk = lookupSection(p);
2799 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2800 return (sk == HUGS_SECTIONKIND_OTHER);
2804 /* --------------------------------------------------------------------------
2806 * ------------------------------------------------------------------------*/
2808 Void interface(what)
2811 case POSTPREL: break;
2815 ifaces_outstanding = NIL;
2818 mark(ifaces_outstanding);
2823 /*-------------------------------------------------------------------------*/