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 09:22:28 $
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;
1624 Text t = textOf(tycon);
1626 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1630 if (nonNull(findTycon(t))) {
1631 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1635 Tycon tc = newTycon(t);
1637 tycon(tc).line = line;
1638 tycon(tc).arity = length(ktyvars);
1639 tycon(tc).kind = tvsToKind(ktyvars);
1640 tycon(tc).what = DATATYPE;
1642 /* a list to accumulate selectors in :: [((VarId,Type))] */
1645 /* make resTy the result type of the constr, T v1 ... vn */
1647 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1648 resTy = ap(resTy,zfst(hd(tmp)));
1650 /* for each constructor ... */
1651 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1652 constr = hd(constrs);
1653 conid = zfst(constr);
1654 fields = zsnd(constr);
1656 /* Build type of constr and handle any selectors found.
1657 Also collect up tyvars occurring in the constr's arg
1658 types, so we can throw away irrelevant parts of the
1662 tyvarsMentioned = NIL;
1663 /* tyvarsMentioned :: [VarId] */
1665 conArgs = reverse(fields);
1666 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1667 conArg = hd(conArgs); /* (Type,Text) */
1668 conArgTy = zfst3(conArg);
1669 conArgNm = zsnd3(conArg);
1670 conArgStrictness = intOf(zthd3(conArg));
1671 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1673 /* Not sure what the deal is with strictness. Do we need
1674 to notify the symbol table, or not? The Hugs desugarer?
1675 Currently disabled. */
1676 /* if (conArgStrictness > 0) conArgTy = bang(conArgTy); */
1677 ty = fn(conArgTy,ty);
1678 if (nonNull(conArgNm)) {
1679 /* a field name is mentioned too */
1680 selTy = fn(resTy,conArgTy);
1681 if (whatIs(tycon(tc).kind) != STAR)
1682 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1683 selTy = tvsToOffsets(line,selTy, ktyvars);
1684 sels = cons( zpair(conArgNm,selTy), sels);
1688 /* Now ty is the constructor's type, not including context.
1689 Throw away any parts of the context not mentioned in
1690 tyvarsMentioned, and use it to qualify ty.
1693 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1695 /* ctxElem :: ((QConId,VarId)) */
1696 if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1697 ctx2 = cons(ctxElem, ctx2);
1700 ty = ap(QUAL,pair(ctx2,ty));
1702 /* stick the tycon's kind on, if not simply STAR */
1703 if (whatIs(tycon(tc).kind) != STAR)
1704 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1706 ty = tvsToOffsets(line,ty, ktyvars);
1708 /* Finally, stick the constructor's type onto it. */
1709 hd(constrs) = ztriple(conid,fields,ty);
1712 /* Final result is that
1713 constrs :: [((ConId,[((Type,Text))],Type))]
1714 lists the constructors and their types
1715 sels :: [((VarId,Type))]
1716 lists the selectors and their types
1718 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1723 static List startGHCConstrs ( Int line, List cons, List sels )
1725 /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1726 /* sels :: [((VarId,Type))] */
1727 /* returns [Name] */
1729 Int conNo = length(cons)>1 ? 1 : 0;
1730 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1731 Name c = startGHCConstr(line,conNo,hd(cs));
1734 /* cons :: [Name] */
1736 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1737 hd(ss) = startGHCSel(line,hd(ss));
1739 /* sels :: [Name] */
1740 return appendOnto(cons,sels);
1744 static Name startGHCSel ( Int line, ZPair sel )
1746 /* sel :: ((VarId, Type)) */
1747 Text t = textOf(zfst(sel));
1748 Type type = zsnd(sel);
1750 Name n = findName(t);
1752 ERRMSG(line) "Repeated definition for selector \"%s\"",
1758 name(n).line = line;
1759 name(n).number = SELNAME;
1762 name(n).type = type;
1767 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1769 /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1770 /* (ADR) ToDo: add rank2 annotation and existential annotation
1771 * these affect how constr can be used.
1773 Text con = textOf(zfst3(constr));
1774 Type type = zthd3(constr);
1775 Int arity = arityFromType(type);
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;
1792 static List finishGHCDataDecl ( ConId tyc )
1795 Tycon tc = findTycon(textOf(tyc));
1797 fprintf ( stderr, "begin finishGHCDataDecl %s\n",
1798 textToStr(textOf(tyc)) );
1800 if (isNull(tc)) internal("finishGHCDataDecl");
1802 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1804 Int line = name(n).line;
1805 assert(currentModule == name(n).mod);
1806 name(n).type = conidcellsToTycons(line,name(n).type);
1807 name(n).parent = tc; //---????
1810 return tycon(tc).defn;
1814 /* --------------------------------------------------------------------------
1816 * ------------------------------------------------------------------------*/
1818 static Void startGHCNewType ( Int line, List ctx0,
1819 ConId tycon, List tvs, Cell constr )
1821 /* ctx0 :: [((QConId,VarId))] */
1822 /* tycon :: ConId */
1823 /* tvs :: [((VarId,Kind))] */
1824 /* constr :: ((ConId,Type)) or NIL if abstract */
1827 Text t = textOf(tycon);
1829 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1834 if (nonNull(findTycon(t))) {
1835 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1839 Tycon tc = newTycon(t);
1840 tycon(tc).line = line;
1841 tycon(tc).arity = length(tvs);
1842 tycon(tc).what = NEWTYPE;
1843 tycon(tc).kind = tvsToKind(tvs);
1844 /* can't really do this until I've read in all synonyms */
1846 if (isNull(constr)) {
1847 tycon(tc).defn = NIL;
1849 /* constr :: ((ConId,Type)) */
1850 Text con = textOf(zfst(constr));
1851 Type type = zsnd(constr);
1852 Name n = findName(con); /* Allocate constructor fun name */
1854 n = newName(con,NIL);
1855 } else if (name(n).defn!=PREDEFINED) {
1856 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1860 name(n).arity = 1; /* Save constructor fun details */
1861 name(n).line = line;
1862 name(n).number = cfunNo(0);
1863 name(n).defn = nameId;
1864 tycon(tc).defn = singleton(n);
1866 /* make resTy the result type of the constr, T v1 ... vn */
1868 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1869 resTy = ap(resTy,zfst(hd(tmp)));
1870 type = fn(type,resTy);
1872 type = ap(QUAL,pair(ctx0,type));
1873 type = tvsToOffsets(line,type,tvs);
1874 name(n).type = type;
1880 static Void finishGHCNewType ( ConId tyc )
1882 Tycon tc = findTycon(textOf(tyc));
1884 fprintf ( stderr, "begin finishGHCNewType %s\n",
1885 textToStr(textOf(tyc)) );
1888 if (isNull(tc)) internal("finishGHCNewType");
1890 if (isNull(tycon(tc).defn)) {
1891 /* it's an abstract type */
1893 else if (length(tycon(tc).defn) == 1) {
1894 /* As we expect, has a single constructor */
1895 Name n = hd(tycon(tc).defn);
1896 Int line = name(n).line;
1897 assert(currentModule == name(n).mod);
1898 name(n).type = conidcellsToTycons(line,name(n).type);
1900 internal("finishGHCNewType(2)");
1905 /* --------------------------------------------------------------------------
1906 * Class declarations
1907 * ------------------------------------------------------------------------*/
1909 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1911 List ctxt; /* [((QConId, VarId))] */
1912 ConId tc_name; /* ConId */
1913 List kinded_tvs; /* [((VarId, Kind))] */
1914 List mems0; { /* [((VarId, Type))] */
1916 List mems; /* [((VarId, Type))] */
1917 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1918 List tvs; /* [((VarId,Kind))] */
1919 List ns; /* [Name] */
1922 ZPair kinded_tv = hd(kinded_tvs);
1923 Text ct = textOf(tc_name);
1924 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1926 fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
1930 if (length(kinded_tvs) != 1) {
1931 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1935 if (nonNull(findClass(ct))) {
1936 ERRMSG(line) "Repeated definition of class \"%s\"",
1939 } else if (nonNull(findTycon(ct))) {
1940 ERRMSG(line) "\"%s\" used as both class and type constructor",
1944 Class nw = newClass(ct);
1945 cclass(nw).text = ct;
1946 cclass(nw).line = line;
1947 cclass(nw).arity = 1;
1948 cclass(nw).head = ap(nw,mkOffset(0));
1949 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1950 cclass(nw).instances = NIL;
1951 cclass(nw).numSupers = length(ctxt);
1953 /* Kludge to map the single tyvar in the context to Offset 0.
1954 Need to do something better for multiparam type classes.
1956 cclass(nw).supers = tvsToOffsets(line,ctxt,
1957 singleton(kinded_tv));
1960 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1961 ZPair mem = hd(mems);
1962 Type memT = zsnd(mem);
1963 Text mnt = textOf(zfst(mem));
1966 /* Stick the new context on the member type */
1967 memT = dictapsToQualtype(memT);
1968 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1969 if (whatIs(memT)==QUAL) {
1971 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1974 pair(singleton(newCtx),memT));
1977 /* Cook up a kind for the type. */
1978 tvsInT = ifTyvarsIn(memT);
1979 /* tvsInT :: [VarId] */
1981 /* ToDo: maximally bogus. We allow the class tyvar to
1982 have the kind as supplied by the parser, but we just
1983 assume that all others have kind *. It's a kludge.
1985 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
1987 if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
1988 k = zsnd(kinded_tv); else
1990 hd(tvs) = zpair(hd(tvs),k);
1992 /* tvsIntT :: [((VarId,Kind))] */
1994 memT = mkPolyType(tvsToKind(tvsInT),memT);
1995 memT = tvsToOffsets(line,memT,tvsInT);
1997 /* Park the type back on the member */
1998 mem = zpair(zfst(mem),memT);
2000 /* Bind code to the member */
2004 "Repeated definition for class method \"%s\"",
2008 mn = newName(mnt,NIL);
2013 cclass(nw).members = mems0;
2014 cclass(nw).numMembers = length(mems0);
2017 for (mno=0; mno<cclass(nw).numSupers; mno++) {
2018 ns = cons(newDSel(nw,mno),ns);
2020 cclass(nw).dsels = rev(ns);
2025 static Class finishGHCClass ( Tycon cls_tyc )
2030 Class nw = findClass ( textOf(cls_tyc) );
2032 fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
2034 if (isNull(nw)) internal("finishGHCClass");
2036 line = cclass(nw).line;
2038 assert (currentModule == cclass(nw).mod);
2040 cclass(nw).level = 0;
2041 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
2042 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
2043 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
2045 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2046 Pair mem = hd(mems); /* (VarId, Type) */
2047 Text txt = textOf(fst(mem));
2049 Name n = findName(txt);
2052 name(n).line = cclass(nw).line;
2054 name(n).number = ctr--;
2055 name(n).arity = arityInclDictParams(name(n).type);
2056 name(n).parent = nw;
2064 /* --------------------------------------------------------------------------
2066 * ------------------------------------------------------------------------*/
2068 static Inst startGHCInstance (line,ktyvars,cls,var)
2070 List ktyvars; /* [((VarId,Kind))] */
2071 Type cls; /* Type */
2072 VarId var; { /* VarId */
2073 List tmp, tvs, ks, spec;
2078 Inst in = newInst();
2080 fprintf ( stderr, "begin startGHCInstance\n" );
2085 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2087 The order of tvs is important for tvsToOffsets.
2088 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2089 out of ktyvars and attach them to tvs.
2091 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2093 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2094 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2096 if (isNull(k)) internal("startGHCInstance: finding kinds");
2097 hd(xs1) = zpair(hd(xs1),k);
2100 cls = tvsToOffsets(line,cls,tvs);
2103 spec = cons(fun(cls),spec);
2106 spec = reverse(spec);
2108 inst(in).line = line;
2109 inst(in).implements = NIL;
2110 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2111 inst(in).specifics = spec;
2112 inst(in).numSpecifics = length(spec);
2113 inst(in).head = cls;
2115 /* Figure out the name of the class being instanced, and store it
2116 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2118 Cell cl = inst(in).head;
2119 assert(whatIs(cl)==DICTAP);
2120 cl = unap(DICTAP,cl);
2122 assert ( isQCon(cl) );
2127 Name b = newName( /*inventText()*/ textOf(var),NIL);
2128 name(b).line = line;
2129 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2130 name(b).number = DFUNNAME;
2131 name(b).parent = in;
2132 inst(in).builder = b;
2133 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2140 static Void finishGHCInstance ( Inst in )
2147 fprintf ( stderr, "begin finishGHCInstance\n" );
2150 assert (nonNull(in));
2151 line = inst(in).line;
2152 assert (currentModule==inst(in).mod);
2154 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2155 since startGHCInstance couldn't possibly have resolved it to
2156 a Class at that point. We convert it to a Class now.
2160 c = findQualClassWithoutConsultingExportList(c);
2164 inst(in).head = conidcellsToTycons(line,inst(in).head);
2165 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2166 cclass(c).instances = cons(in,cclass(c).instances);
2170 /* --------------------------------------------------------------------------
2172 * ------------------------------------------------------------------------*/
2174 /* This is called from the startGHC* functions. It traverses a structure
2175 and converts varidcells, ie, type variables parsed by the interface
2176 parser, into Offsets, which is how Hugs wants to see them internally.
2177 The Offset for a type variable is determined by its place in the list
2178 passed as the second arg; the associated kinds are irrelevant.
2180 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2183 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2184 static Type tvsToOffsets(line,type,ktyvars)
2187 List ktyvars; { /* [((VarId,Kind))] */
2188 switch (whatIs(type)) {
2195 case ZTUP2: /* convert to the untyped representation */
2196 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2197 tvsToOffsets(line,zsnd(type),ktyvars) );
2199 return ap( tvsToOffsets(line,fun(type),ktyvars),
2200 tvsToOffsets(line,arg(type),ktyvars) );
2204 tvsToOffsets(line,monotypeOf(type),ktyvars)
2208 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2209 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2210 case DICTAP: /* bogus ?? */
2211 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2212 case UNBOXEDTUP: /* bogus?? */
2213 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2214 case BANG: /* bogus?? */
2215 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2216 case VARIDCELL: /* Ha! some real work to do! */
2218 Text tv = textOf(type);
2219 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2222 assert(isZPair(hd(ktyvars)));
2223 varid = zfst(hd(ktyvars));
2225 if (tv == tt) return mkOffset(i);
2227 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2232 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2234 fprintf(stderr,"\n");
2238 return NIL; /* NOTREACHED */
2242 /* This is called from the finishGHC* functions. It traverses a structure
2243 and converts conidcells, ie, type constructors parsed by the interface
2244 parser, into Tycons (or Classes), which is how Hugs wants to see them
2245 internally. Calls to this fn have to be deferred to the second phase
2246 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2247 Tycons or Classes have been loaded into the symbol tables and can be
2250 static Type conidcellsToTycons ( Int line, Type type )
2252 switch (whatIs(type)) {
2262 { Cell t; /* Tycon or Class */
2263 Text m = qmodOf(type);
2264 Module mod = findModule(m);
2267 "Undefined module in qualified name \"%s\"",
2272 t = findQualTyconWithoutConsultingExportList(type);
2273 if (nonNull(t)) return t;
2274 t = findQualClassWithoutConsultingExportList(type);
2275 if (nonNull(t)) return t;
2277 "Undefined qualified class or type \"%s\"",
2285 cl = findQualClass(type);
2286 if (nonNull(cl)) return cl;
2287 if (textOf(type)==findText("[]"))
2288 /* a hack; magically qualify [] into PrelBase.[] */
2289 return conidcellsToTycons(line,
2290 mkQualId(mkCon(findText("PrelBase")),type));
2291 tc = findQualTycon(type);
2292 if (nonNull(tc)) return tc;
2294 "Undefined class or type constructor \"%s\"",
2300 return ap( conidcellsToTycons(line,fun(type)),
2301 conidcellsToTycons(line,arg(type)) );
2302 case ZTUP2: /* convert to std pair */
2303 return ap( conidcellsToTycons(line,zfst(type)),
2304 conidcellsToTycons(line,zsnd(type)) );
2309 conidcellsToTycons(line,monotypeOf(type))
2313 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2314 conidcellsToTycons(line,snd(snd(type)))));
2315 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2316 Not sure if this is really the right place to
2317 convert it to the form Hugs wants, but will do so anyway.
2319 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2321 Class cl = fst(unap(DICTAP,type));
2322 List args = snd(unap(DICTAP,type));
2324 conidcellsToTycons(line,pair(cl,args));
2327 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2329 return ap(BANG, conidcellsToTycons(line, snd(type)));
2331 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2334 fprintf(stderr,"\n");
2338 return NIL; /* NOTREACHED */
2342 /* Find out if a type mentions a type constructor not present in
2343 the supplied list of qualified tycons.
2345 static Bool allTypesKnown ( Type type,
2346 List aktys /* [QualId] */,
2349 switch (whatIs(type)) {
2356 return allTypesKnown(fun(type),aktys,thisMod)
2357 && allTypesKnown(arg(type),aktys,thisMod);
2359 return allTypesKnown(zfst(type),aktys,thisMod)
2360 && allTypesKnown(zsnd(type),aktys,thisMod);
2362 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2365 if (textOf(type)==findText("[]"))
2366 /* a hack; magically qualify [] into PrelBase.[] */
2367 type = mkQualId(mkCon(findText("PrelBase")),type); else
2368 type = mkQualId(thisMod,type);
2371 if (isNull(qualidIsMember(type,aktys))) goto missing;
2377 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2378 print(type,10);printf("\n");
2379 internal("allTypesKnown");
2380 return TRUE; /*notreached*/
2384 fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
2385 fprintf(stderr,"\n");
2391 /* --------------------------------------------------------------------------
2394 * None of these do lookups or require that lookups have been resolved
2395 * so they can be performed while reading interfaces.
2396 * ------------------------------------------------------------------------*/
2398 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2399 static Kinds tvsToKind(tvs)
2400 List tvs; { /* [((VarId,Kind))] */
2403 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2404 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2405 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2406 r = ap(zsnd(hd(rs)),r);
2412 static Int arityInclDictParams ( Type type )
2415 if (isPolyType(type)) type = monotypeOf(type);
2417 if (whatIs(type) == QUAL)
2419 arity += length ( fst(snd(type)) );
2420 type = snd(snd(type));
2422 while (isAp(type) && getHead(type)==typeArrow) {
2429 /* arity of a constructor with this type */
2430 static Int arityFromType(type)
2433 if (isPolyType(type)) {
2434 type = monotypeOf(type);
2436 if (whatIs(type) == QUAL) {
2437 type = snd(snd(type));
2439 if (whatIs(type) == EXIST) {
2440 type = snd(snd(type));
2442 if (whatIs(type)==RANK2) {
2443 type = snd(snd(type));
2445 while (isAp(type) && getHead(type)==typeArrow) {
2453 /* ifTyvarsIn :: Type -> [VarId]
2454 The returned list has no duplicates -- is a set.
2456 static List ifTyvarsIn(type)
2458 List vs = typeVarsIn(type,NIL,NIL,NIL);
2460 for (; nonNull(vs2); vs2=tl(vs2))
2461 if (whatIs(hd(vs2)) != VARIDCELL)
2462 internal("ifTyvarsIn");
2468 /* --------------------------------------------------------------------------
2469 * General object symbol query stuff
2470 * ------------------------------------------------------------------------*/
2472 #define EXTERN_SYMS_ALLPLATFORMS \
2474 Sym(stg_gc_enter_1) \
2475 Sym(stg_gc_noregs) \
2483 Sym(stg_update_PAP) \
2484 Sym(stg_error_entry) \
2485 Sym(__ap_2_upd_info) \
2486 Sym(__ap_3_upd_info) \
2487 Sym(__ap_4_upd_info) \
2488 Sym(__ap_5_upd_info) \
2489 Sym(__ap_6_upd_info) \
2490 Sym(__ap_7_upd_info) \
2491 Sym(__ap_8_upd_info) \
2492 Sym(__sel_0_upd_info) \
2493 Sym(__sel_1_upd_info) \
2494 Sym(__sel_2_upd_info) \
2495 Sym(__sel_3_upd_info) \
2496 Sym(__sel_4_upd_info) \
2497 Sym(__sel_5_upd_info) \
2498 Sym(__sel_6_upd_info) \
2499 Sym(__sel_7_upd_info) \
2500 Sym(__sel_8_upd_info) \
2501 Sym(__sel_9_upd_info) \
2502 Sym(__sel_10_upd_info) \
2503 Sym(__sel_11_upd_info) \
2504 Sym(__sel_12_upd_info) \
2505 Sym(Upd_frame_info) \
2506 Sym(seq_frame_info) \
2507 Sym(CAF_BLACKHOLE_info) \
2508 Sym(IND_STATIC_info) \
2509 Sym(EMPTY_MVAR_info) \
2510 Sym(MUT_ARR_PTRS_FROZEN_info) \
2512 Sym(putMVarzh_fast) \
2513 Sym(newMVarzh_fast) \
2514 Sym(takeMVarzh_fast) \
2519 Sym(killThreadzh_fast) \
2520 Sym(waitReadzh_fast) \
2521 Sym(waitWritezh_fast) \
2522 Sym(CHARLIKE_closure) \
2523 Sym(INTLIKE_closure) \
2524 Sym(suspendThread) \
2526 Sym(stackOverflow) \
2527 Sym(int2Integerzh_fast) \
2528 Sym(stg_gc_unbx_r1) \
2530 Sym(makeForeignObjzh_fast) \
2531 Sym(__encodeDouble) \
2532 Sym(decodeDoublezh_fast) \
2534 Sym(isDoubleInfinite) \
2535 Sym(isDoubleDenormalized) \
2536 Sym(isDoubleNegativeZero) \
2537 Sym(__encodeFloat) \
2538 Sym(decodeFloatzh_fast) \
2540 Sym(isFloatInfinite) \
2541 Sym(isFloatDenormalized) \
2542 Sym(isFloatNegativeZero) \
2543 Sym(__int_encodeFloat) \
2544 Sym(__int_encodeDouble) \
2548 Sym(gcdIntegerzh_fast) \
2549 Sym(newArrayzh_fast) \
2550 Sym(unsafeThawArrayzh_fast) \
2551 Sym(newDoubleArrayzh_fast) \
2552 Sym(newFloatArrayzh_fast) \
2553 Sym(newAddrArrayzh_fast) \
2554 Sym(newWordArrayzh_fast) \
2555 Sym(newIntArrayzh_fast) \
2556 Sym(newCharArrayzh_fast) \
2557 Sym(newMutVarzh_fast) \
2558 Sym(quotRemIntegerzh_fast) \
2559 Sym(quotIntegerzh_fast) \
2560 Sym(remIntegerzh_fast) \
2561 Sym(divExactIntegerzh_fast) \
2562 Sym(divModIntegerzh_fast) \
2563 Sym(timesIntegerzh_fast) \
2564 Sym(minusIntegerzh_fast) \
2565 Sym(plusIntegerzh_fast) \
2566 Sym(addr2Integerzh_fast) \
2567 Sym(mkWeakzh_fast) \
2570 Sym(resetNonBlockingFd) \
2572 Sym(stable_ptr_table) \
2573 Sym(createAdjThunk) \
2574 Sym(shutdownHaskellAndExit) \
2575 Sym(stg_enterStackTop) \
2576 Sym(CAF_UNENTERED_entry) \
2577 Sym(stg_yield_to_Hugs) \
2581 /* needed by libHS_cbits */ \
2615 #define EXTERN_SYMS_cygwin32 \
2616 SymX(GetCurrentProcess) \
2617 SymX(GetProcessTimes) \
2626 SymX(__imp__tzname) \
2627 SymX(__imp__timezone) \
2646 #define EXTERN_SYMS_linux \
2647 Sym(__errno_location) \
2665 #if defined(linux_TARGET_OS)
2666 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
2669 #if defined(solaris2_TARGET_OS)
2670 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
2673 #if defined(cygwin32_TARGET_OS)
2674 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
2680 /* entirely bogus claims about types of these symbols */
2681 #define Sym(vvv) extern void (vvv);
2682 #define SymX(vvv) /**/
2683 EXTERN_SYMS_ALLPLATFORMS
2684 EXTERN_SYMS_THISPLATFORM
2689 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2691 #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2695 EXTERN_SYMS_ALLPLATFORMS
2696 EXTERN_SYMS_THISPLATFORM
2706 /* A kludge to assist Win32 debugging. */
2707 char* nameFromStaticOPtr ( void* ptr )
2710 for (k = 0; rtsTab[k].nm; k++)
2711 if (ptr == rtsTab[k].ad)
2712 return rtsTab[k].nm;
2717 void* lookupObjName ( char* nm )
2725 int first_real_char;
2728 strncpy(nm2,nm,200);
2730 /* first see if it's an RTS name */
2731 for (k = 0; rtsTab[k].nm; k++)
2732 if (0==strcmp(nm2,rtsTab[k].nm))
2733 return rtsTab[k].ad;
2735 /* perhaps an extra-symbol ? */
2736 a = lookupOExtraTabName ( nm );
2739 # if LEADING_UNDERSCORE
2740 first_real_char = 1;
2742 first_real_char = 0;
2745 /* Maybe it's an __init_Module thing? */
2746 if (strlen(nm2+first_real_char) > 7
2747 && strncmp(nm2+first_real_char, "__init_", 7)==0) {
2748 t = unZcodeThenFindText(nm2+first_real_char+7);
2749 if (t == findText("PrelGHC")) return (4+NULL); /* kludge */
2751 if (isNull(m)) goto not_found;
2752 a = lookupOTabName ( m, nm );
2757 /* if not an RTS name, look in the
2758 relevant module's object symbol table
2760 pp = strchr(nm2+first_real_char, '_');
2761 if (!pp || !isupper(nm2[first_real_char])) goto not_found;
2763 t = unZcodeThenFindText(nm2+first_real_char);
2765 if (isNull(m)) goto not_found;
2767 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2772 "lookupObjName: can't resolve name `%s'\n",
2779 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2781 OSectionKind sk = lookupSection(p);
2782 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2783 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2787 int is_dynamically_loaded_rwdata_ptr ( char* p )
2789 OSectionKind sk = lookupSection(p);
2790 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2791 return (sk == HUGS_SECTIONKIND_RWDATA);
2795 int is_not_dynamically_loaded_ptr ( char* p )
2797 OSectionKind sk = lookupSection(p);
2798 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2799 return (sk == HUGS_SECTIONKIND_OTHER);
2803 /* --------------------------------------------------------------------------
2805 * ------------------------------------------------------------------------*/
2807 Void interface(what)
2810 case POSTPREL: break;
2814 ifaces_outstanding = NIL;
2817 mark(ifaces_outstanding);
2822 /*-------------------------------------------------------------------------*/