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/04 15:41:56 $
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])) ]] */
393 if (isNull(exlist_list)) {
394 ERRMSG(0) "Can't find any export lists in interface file"
398 return filterInterface ( root, isExportedIFaceEntity,
403 /* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
404 static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
406 Cell iface = unap(I_INTERFACE,root);
407 Text mname = textOf(zfst(iface));
408 List defns = zsnd(iface);
409 for (; nonNull(defns); defns = tl(defns)) {
410 Cell defn = hd(defns);
411 Cell what = whatIs(defn);
412 if (what==I_TYPE || what==I_DATA
413 || what==I_NEWTYPE || what==I_CLASS) {
414 QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
415 if (!qualidIsMember ( q, aktys ))
416 aktys = cons ( q, aktys );
423 static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
425 ConVarId id = getIEntityName ( entity );
428 "dumping %s because of unknown type(s)\n",
429 isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
434 /* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
435 /* mod is the current module being processed -- so we can qualify unqual'd
436 names. Strange calling convention for aktys and mod is so we can call this
437 from filterInterface.
439 static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
442 List aktys = zfst ( aktys_mod );
443 ConId mod = zsnd ( aktys_mod );
444 switch (whatIs(entity)) {
451 Cell inst = unap(I_INSTANCE,entity);
452 List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
453 Type cls = zsel35 ( inst ); /* :: Type */
454 for (t = ctx; nonNull(t); t=tl(t))
455 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
456 if (!allTypesKnown(cls, aktys,mod)) return FALSE;
460 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
462 Cell data = unap(I_DATA,entity);
463 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
464 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
465 for (t = ctx; nonNull(t); t=tl(t))
466 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
467 for (t = constrs; nonNull(t); t=tl(t))
468 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
469 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
473 Cell newty = unap(I_NEWTYPE,entity);
474 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
475 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
476 for (t = ctx; nonNull(t); t=tl(t))
477 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
479 && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
483 Cell klass = unap(I_CLASS,entity);
484 List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
485 List sigs = zsel55(klass); /* :: [((VarId,Type))] */
486 for (t = ctx; nonNull(t); t=tl(t))
487 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
488 for (t = sigs; nonNull(t); t=tl(t))
489 if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
493 return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
495 internal("ifentityAllTypesKnown");
500 /* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
501 /* mod is the current module being processed -- so we can qualify unqual'd
502 names. Strange calling convention for aktys and mod is so we can call this
503 from filterInterface.
505 static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
508 List aktys = zfst ( aktys_mod );
509 ConId mod = zsnd ( aktys_mod );
510 if (whatIs(entity) != I_TYPE) {
513 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
518 static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
520 ConVarId id = getIEntityName ( entity );
521 assert (whatIs(entity)==I_TYPE);
525 "dumping type %s because of unknown tycon(s)\n",
526 textToStr(textOf(id)) );
531 /* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
533 static List abstractifyExDecl ( Cell root, ConId toabs )
535 ZPair exdecl = unap(I_EXPORT,root);
536 List exlist = zsnd(exdecl);
538 for (; nonNull(exlist); exlist = tl(exlist)) {
539 if (isZPair(hd(exlist))
540 && textOf(toabs) == textOf(zfst(hd(exlist)))) {
541 /* it's toabs, exported non-abstractly */
542 res = cons ( zfst(hd(exlist)), res );
544 res = cons ( hd(exlist), res );
547 return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
551 static Void ppModule ( Text modt )
554 fflush(stderr); fflush(stdout);
555 fprintf(stderr, "---------------- MODULE %s ----------------\n",
561 static void* ifFindItblFor ( Name n )
563 /* n is a constructor for which we want to find the GHC info table.
564 First look for a _con_info symbol. If that doesn't exist, _and_
565 this is a nullary constructor, then it's safe to look for the
566 _static_info symbol instead.
572 sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_info"),
573 textToStr( module(name(n).mod).text ),
574 textToStr( name(n).text ) );
575 t = enZcodeThenFindText(buf);
576 p = lookupOTabName ( name(n).mod, textToStr(t) );
580 if (name(n).arity == 0) {
581 sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"),
582 textToStr( module(name(n).mod).text ),
583 textToStr( name(n).text ) );
584 t = enZcodeThenFindText(buf);
585 p = lookupOTabName ( name(n).mod, textToStr(t) );
589 ERRMSG(0) "Can't find info table %s", textToStr(t)
594 void ifLinkConstrItbl ( Name n )
596 /* name(n) is either a constructor or a field name.
597 If the latter, ignore it. If it is a non-nullary constructor,
598 find its info table in the object code. If it's nullary,
599 we can skip the info table, since all accesses will go via
602 if (islower(textToStr(name(n).text)[0])) return;
603 if (name(n).arity == 0) return;
604 name(n).itbl = ifFindItblFor(n);
608 static void ifSetClassDefaultsAndDCon ( Class c )
616 List defs; /* :: [Name] */
617 List mems; /* :: [Name] */
619 assert(isNull(cclass(c).defaults));
621 /* Create the defaults list by more-or-less cloning the members list. */
623 for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
625 s = textToStr( name(hd(mems)).text );
626 assert(strlen(s) < 95);
628 n = findNameInAnyModule(findText(buf));
633 cclass(c).defaults = defs;
635 /* Create a name table entry for the dictionary datacon.
636 Interface files don't mention them, so it had better not
640 s = textToStr( cclass(c).text );
641 assert( strlen(s) < 96 );
644 n = findNameInAnyModule(t);
650 name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
651 name(n).number = cfunNo(0);
654 /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
655 Because this happens right at the end of loading, we know
656 that we should actually be able to find the symbol in this
657 module's object symbol table. Except that if the dictionary
658 has arity 1, we don't bother, since it will be represented as
659 a newtype and not as a data, so its itbl can remain NULL.
661 if (name(n).arity == 1) {
663 name(n).defn = nameId;
665 p = ifFindItblFor ( n );
671 void processInterfaces ( List /* of CONID */ iface_modnames )
682 List all_known_types;
684 List cls_list; /* :: List Class */
685 List constructor_list; /* :: List Name */
687 List ifaces = NIL; /* :: List I_INTERFACE */
689 if (isNull(iface_modnames)) return;
693 "processInterfaces: %d interfaces to process\n",
694 length(ifaces_outstanding) );
697 for (xs = iface_modnames; nonNull(xs); xs=tl(xs)) {
698 mod = findModule(textOf(hd(xs)));
699 assert(nonNull(mod));
700 assert(module(mod).mode == FM_OBJECT);
701 ifaces = cons ( module(mod).tree, ifaces );
703 ifaces = reverse(ifaces);
705 /* Clean up interfaces -- dump non-exported value, class, type decls */
706 for (xs = ifaces; nonNull(xs); xs = tl(xs))
707 hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
710 /* Iteratively delete any type declarations which refer to unknown
713 num_known_types = 999999999;
717 /* Construct a list of all known tycons. This is a list of QualIds.
718 Unfortunately it also has to contain all known class names, since
719 allTypesKnown cannot distinguish between tycons and classes -- a
720 deficiency of the iface abs syntax.
722 all_known_types = getAllKnownTyconsAndClasses();
723 for (xs = ifaces; nonNull(xs); xs=tl(xs))
725 = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
727 /* Have we reached a fixed point? */
728 i = length(all_known_types);
731 "\n============= %d known types =============\n", i );
733 if (num_known_types == i) break;
736 /* Delete all entities which refer to unknown tycons. */
737 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
738 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
739 assert(nonNull(mod));
740 hd(xs) = filterInterface ( hd(xs),
741 ifTypeDoesntRefUnknownTycon,
742 zpair(all_known_types,mod),
743 ifTypeDoesntRefUnknownTycon_dumpmsg );
747 /* Now abstractify any datas and newtypes which refer to unknown tycons
748 -- including, of course, the type decls just deleted.
750 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
751 List absify = NIL; /* :: [ConId] */
752 ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
753 ConId mod = zfst(iface);
754 List aktys = all_known_types; /* just a renaming */
758 /* Compute into absify the list of all ConIds (tycons) we need to
761 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
763 Bool allKnown = TRUE;
765 if (whatIs(ent)==I_DATA) {
766 Cell data = unap(I_DATA,ent);
767 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
768 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
769 for (t = ctx; nonNull(t); t=tl(t))
770 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
771 for (t = constrs; nonNull(t); t=tl(t))
772 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
773 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
775 else if (whatIs(ent)==I_NEWTYPE) {
776 Cell newty = unap(I_NEWTYPE,ent);
777 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
778 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
779 for (t = ctx; nonNull(t); t=tl(t))
780 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
781 if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
785 absify = cons ( getIEntityName(ent), absify );
788 "abstractifying %s because it uses an unknown type\n",
789 textToStr(textOf(getIEntityName(ent))) );
794 /* mark in exports as abstract all names in absify (modifies iface) */
795 for (; nonNull(absify); absify=tl(absify)) {
796 ConId toAbs = hd(absify);
797 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
798 if (whatIs(hd(es)) != I_EXPORT) continue;
799 hd(es) = abstractifyExDecl ( hd(es), toAbs );
803 /* For each data/newtype in the export list marked as abstract,
804 remove the constructor lists. This catches all abstractification
805 caused by the code above, and it also catches tycons which really
806 were exported abstractly.
809 exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
810 /* exlist_list :: [I_EXPORT] */
811 for (t=exlist_list; nonNull(t); t=tl(t))
812 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
813 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
815 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
817 if (whatIs(ent)==I_DATA
818 && isExportedAbstractly ( getIEntityName(ent),
820 Cell data = unap(I_DATA,ent);
821 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
822 zsel45(data), NIL /* the constr list */ );
823 hd(es) = ap(I_DATA,data);
825 fprintf(stderr, "abstractify data %s\n",
826 textToStr(textOf(getIEntityName(ent))) );
829 else if (whatIs(ent)==I_NEWTYPE
830 && isExportedAbstractly ( getIEntityName(ent),
832 Cell data = unap(I_NEWTYPE,ent);
833 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
834 zsel45(data), NIL /* the constr-type pair */ );
835 hd(es) = ap(I_NEWTYPE,data);
837 fprintf(stderr, "abstractify newtype %s\n",
838 textToStr(textOf(getIEntityName(ent))) );
843 /* We've finally finished mashing this iface. Update the iface list. */
844 hd(xs) = ap(I_INTERFACE,iface);
848 /* At this point, the interfaces are cleaned up so that no type, data or
849 newtype defn refers to a non-existant type. However, there still may
850 be value defns, classes and instances which refer to unknown types.
851 Delete iteratively until a fixed point is reached.
854 fprintf(stderr,"\n");
856 num_known_types = 999999999;
860 /* Construct a list of all known tycons. This is a list of QualIds.
861 Unfortunately it also has to contain all known class names, since
862 allTypesKnown cannot distinguish between tycons and classes -- a
863 deficiency of the iface abs syntax.
865 all_known_types = getAllKnownTyconsAndClasses();
866 for (xs = ifaces; nonNull(xs); xs=tl(xs))
867 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
869 /* Have we reached a fixed point? */
870 i = length(all_known_types);
873 "\n------------- %d known types -------------\n", i );
875 if (num_known_types == i) break;
878 /* Delete all entities which refer to unknown tycons. */
879 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
880 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
881 assert(nonNull(mod));
883 hd(xs) = filterInterface ( hd(xs),
884 ifentityAllTypesKnown,
885 zpair(all_known_types,mod),
886 ifentityAllTypesKnown_dumpmsg );
891 /* Allocate module table entries and read in object code. */
892 for (xs=ifaces; nonNull(xs); xs=tl(xs))
893 startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))) );
896 /* Now work through the decl lists of the modules, and call the
897 startGHC* functions on the entities. This creates names in
898 various tables but doesn't bind them to anything.
901 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
902 iface = unap(I_INTERFACE,hd(xs));
903 mname = textOf(zfst(iface));
904 mod = findModule(mname);
905 if (isNull(mod)) internal("processInterfaces(4)");
907 ppModule ( module(mod).text );
909 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
910 Cell decl = hd(decls);
911 switch(whatIs(decl)) {
913 Cell exdecl = unap(I_EXPORT,decl);
914 startGHCExports ( zfst(exdecl), zsnd(exdecl) );
918 Cell imdecl = unap(I_IMPORT,decl);
919 startGHCImports ( zfst(imdecl), zsnd(imdecl) );
926 /* Trying to find the instance table location allocated by
927 startGHCInstance in subsequent processing is a nightmare, so
928 cache it on the tree.
930 Cell instance = unap(I_INSTANCE,decl);
931 Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
932 zsel35(instance), zsel45(instance) );
933 hd(decls) = ap(I_INSTANCE,
934 z5ble( zsel15(instance), zsel25(instance),
935 zsel35(instance), zsel45(instance), in ));
939 Cell tydecl = unap(I_TYPE,decl);
940 startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
941 zsel34(tydecl), zsel44(tydecl) );
945 Cell ddecl = unap(I_DATA,decl);
946 startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
947 zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
951 Cell ntdecl = unap(I_NEWTYPE,decl);
952 startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
953 zsel35(ntdecl), zsel45(ntdecl),
958 Cell klass = unap(I_CLASS,decl);
959 startGHCClass ( zsel15(klass), zsel25(klass),
960 zsel35(klass), zsel45(klass),
965 Cell value = unap(I_VALUE,decl);
966 startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
970 internal("processInterfaces(1)");
976 fprintf(stderr, "\n============================"
977 "=============================\n");
978 fprintf(stderr, "=============================="
979 "===========================\n");
982 /* Traverse again the decl lists of the modules, this time
983 calling the finishGHC* functions. But don't process
984 the export lists; those must wait for later.
987 constructor_list = NIL;
988 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
989 iface = unap(I_INTERFACE,hd(xs));
990 mname = textOf(zfst(iface));
991 mod = findModule(mname);
992 if (isNull(mod)) internal("processInterfaces(3)");
994 ppModule ( module(mod).text );
996 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
997 Cell decl = hd(decls);
998 switch(whatIs(decl)) {
1006 Cell fixdecl = unap(I_FIXDECL,decl);
1007 finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
1011 Cell instance = unap(I_INSTANCE,decl);
1012 finishGHCInstance ( zsel55(instance) );
1016 Cell tydecl = unap(I_TYPE,decl);
1017 finishGHCSynonym ( zsel24(tydecl) );
1021 Cell ddecl = unap(I_DATA,decl);
1022 List constrs = finishGHCDataDecl ( zsel35(ddecl) );
1023 constructor_list = appendOnto ( constrs, constructor_list );
1027 Cell ntdecl = unap(I_NEWTYPE,decl);
1028 finishGHCNewType ( zsel35(ntdecl) );
1032 Cell klass = unap(I_CLASS,decl);
1033 Class cls = finishGHCClass ( zsel35(klass) );
1034 cls_list = cons(cls,cls_list);
1038 Cell value = unap(I_VALUE,decl);
1039 finishGHCValue ( zsnd3(value) );
1043 internal("processInterfaces(2)");
1048 fprintf(stderr, "\n+++++++++++++++++++++++++++++"
1049 "++++++++++++++++++++++++++++\n");
1050 fprintf(stderr, "+++++++++++++++++++++++++++++++"
1051 "++++++++++++++++++++++++++\n");
1054 /* Build the module(m).export lists for each module, by running
1055 through the export lists in the iface. Also, do the implicit
1056 'import Prelude' thing. And finally, do the object code
1059 for (xs = ifaces; nonNull(xs); xs = tl(xs))
1060 finishGHCModule(hd(xs));
1062 mapProc(visitClass,cls_list);
1063 mapProc(ifSetClassDefaultsAndDCon,cls_list);
1064 mapProc(ifLinkConstrItbl,constructor_list);
1067 ifaces_outstanding = NIL;
1071 /* --------------------------------------------------------------------------
1073 * ------------------------------------------------------------------------*/
1075 static void startGHCModule_errMsg ( char* msg )
1077 fprintf ( stderr, "object error: %s\n", msg );
1080 static void* startGHCModule_clientLookup ( char* sym )
1083 /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
1085 return lookupObjName ( sym );
1088 static int /*Bool*/ startGHCModule_clientWantsSymbol ( char* sym )
1090 if (strcmp(sym,"ghc_cc_ID")==0) return 0;
1094 static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
1097 = ocNew ( startGHCModule_errMsg,
1098 startGHCModule_clientLookup,
1099 startGHCModule_clientWantsSymbol,
1103 ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
1106 if (!ocLoadImage(oc,VERBOSE)) {
1107 ERRMSG(0) "Reading of object file \"%s\" failed", objNm
1110 if (!ocVerifyImage(oc,VERBOSE)) {
1111 ERRMSG(0) "Validation of object file \"%s\" failed", objNm
1114 if (!ocGetNames(oc,VERBOSE)) {
1115 ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
1121 static Void startGHCModule ( Text mname )
1124 Module m = findModule(mname);
1128 fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
1129 textToStr(mname), module(m).objSize );
1132 module(m).fake = FALSE;
1134 /* Get hold of the primary object for the module. */
1136 = startGHCModule_partial_load ( textToStr(module(m).objName),
1137 module(m).objSize );
1139 /* and any extras ... */
1140 for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
1144 String nm = getExtraObjectInfo (
1145 textToStr(module(m).objName),
1150 ERRMSG(0) "Can't find extra object file \"%s\"", nm
1153 oc = startGHCModule_partial_load ( nm, size );
1154 oc->next = module(m).objectExtras;
1155 module(m).objectExtras = oc;
1160 /* For the module mod, augment both the export environment (.exports)
1161 and the eval environment (.names, .tycons, .classes)
1162 with the symbols mentioned in exlist. We don't actually need
1163 to modify the names, tycons, classes or instances in the eval
1164 environment, since previous processing of the
1165 top-level decls in the iface should have done this already.
1167 mn is the module mentioned in the export list; it is the "original"
1168 module for the symbols in the export list. We should also record
1169 this info with the symbols, since references to object code need to
1170 refer to the original module in which a symbol was defined, rather
1171 than to some module it has been imported into and then re-exported.
1173 We take the policy that if something mentioned in an export list
1174 can't be found in the symbol tables, it is simply ignored. After all,
1175 previous processing of the iface syntax trees has already removed
1176 everything which Hugs can't handle, so if there is mention of these
1177 things still lurking in export lists somewhere, about the only thing
1178 to do is to ignore it.
1180 Also do an implicit 'import Prelude' thingy for the module,
1185 static Void finishGHCModule ( Cell root )
1187 /* root :: I_INTERFACE */
1188 Cell iface = unap(I_INTERFACE,root);
1189 ConId iname = zfst(iface);
1190 Module mod = findModule(textOf(iname));
1191 List exlist_list = NIL;
1196 fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1199 if (isNull(mod)) internal("finishExports(1)");
1202 exlist_list = getExportDeclsInIFace ( root );
1203 /* exlist_list :: [I_EXPORT] */
1205 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1206 ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
1207 ConId exmod = zfst(exdecl);
1208 List exlist = zsnd(exdecl);
1209 /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1211 for (; nonNull(exlist); exlist=tl(exlist)) {
1216 Cell ex = hd(exlist);
1218 switch (whatIs(ex)) {
1220 case VARIDCELL: /* variable */
1221 q = mkQualId(exmod,ex);
1222 c = findQualNameWithoutConsultingExportList ( q );
1223 if (isNull(c)) goto notfound;
1225 fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
1227 module(mod).exports = cons(c, module(mod).exports);
1231 case CONIDCELL: /* non data tycon */
1232 q = mkQualId(exmod,ex);
1233 c = findQualTyconWithoutConsultingExportList ( q );
1234 if (isNull(c)) goto notfound;
1236 fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
1238 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1242 case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
1243 subents = zsnd(ex); /* :: [ConVarId] */
1244 ex = zfst(ex); /* :: ConId */
1245 q = mkQualId(exmod,ex);
1246 c = findQualTyconWithoutConsultingExportList ( q );
1248 if (nonNull(c)) { /* data */
1250 fprintf(stderr, " data/newtype %s = { ",
1251 textToStr(textOf(ex)) );
1253 assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1254 abstract = isNull(tycon(c).defn);
1255 /* This data/newtype could be abstract even tho the export list
1256 says to export it non-abstractly. That happens if it was
1257 imported from some other module and is now being re-exported,
1258 and previous cleanup phases have abstractified it in the
1259 original (defining) module.
1262 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1265 fprintf ( stderr, "(abstract) ");
1268 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1270 for (; nonNull(subents); subents = tl(subents)) {
1271 Cell ent2 = hd(subents);
1272 assert(isCon(ent2) || isVar(ent2));
1273 /* isVar since could be a field name */
1274 q = mkQualId(exmod,ent2);
1275 c = findQualNameWithoutConsultingExportList ( q );
1277 fprintf(stderr, "%s ", textToStr(name(c).text));
1280 /* module(mod).exports = cons(c, module(mod).exports); */
1285 fprintf(stderr, "}\n" );
1287 } else { /* class */
1288 q = mkQualId(exmod,ex);
1289 c = findQualClassWithoutConsultingExportList ( q );
1290 if (isNull(c)) goto notfound;
1292 fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
1294 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1296 for (; nonNull(subents); subents = tl(subents)) {
1297 Cell ent2 = hd(subents);
1298 assert(isVar(ent2));
1299 q = mkQualId(exmod,ent2);
1300 c = findQualNameWithoutConsultingExportList ( q );
1302 fprintf(stderr, "%s ", textToStr(name(c).text));
1304 if (isNull(c)) goto notfound;
1305 /* module(mod).exports = cons(c, module(mod).exports); */
1309 fprintf(stderr, "}\n" );
1315 internal("finishExports(2)");
1318 continue; /* so notfound: can be placed after this */
1321 /* q holds what ain't found */
1322 assert(whatIs(q)==QUALIDENT);
1324 fprintf( stderr, " ------ IGNORED: %s.%s\n",
1325 textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1332 if (preludeLoaded) {
1333 /* do the implicit 'import Prelude' thing */
1334 List pxs = module(modulePrelude).exports;
1335 for (; nonNull(pxs); pxs=tl(pxs)) {
1338 switch (whatIs(px)) {
1343 module(mod).names = cons ( px, module(mod).names );
1346 module(mod).tycons = cons ( px, module(mod).tycons );
1349 module(mod).classes = cons ( px, module(mod).classes );
1352 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1353 internal("finishGHCModule -- implicit import Prelude");
1360 /* Last, but by no means least ... */
1361 if (!ocResolve(module(mod).object,VERBOSE))
1362 internal("finishGHCModule: object resolution failed");
1364 for (oc=module(mod).objectExtras; oc; oc=oc->next) {
1365 if (!ocResolve(oc, VERBOSE))
1366 internal("finishGHCModule: extra object resolution failed");
1371 /* --------------------------------------------------------------------------
1373 * ------------------------------------------------------------------------*/
1375 static Void startGHCExports ( ConId mn, List exlist )
1378 fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
1380 /* Nothing to do. */
1383 static Void finishGHCExports ( ConId mn, List exlist )
1386 fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
1388 /* Nothing to do. */
1392 /* --------------------------------------------------------------------------
1394 * ------------------------------------------------------------------------*/
1396 static Void startGHCImports ( ConId mn, List syms )
1397 /* nm the module to import from */
1398 /* syms [ConId | VarId] -- the names to import */
1401 fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
1403 /* Nothing to do. */
1407 static Void finishGHCImports ( ConId nm, List syms )
1408 /* nm the module to import from */
1409 /* syms [ConId | VarId] -- the names to import */
1412 fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
1414 /* Nothing to do. */
1418 /* --------------------------------------------------------------------------
1420 * ------------------------------------------------------------------------*/
1422 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
1424 Int p = intOf(prec);
1425 Int a = intOf(assoc);
1426 Name n = findName(textOf(name));
1427 assert (nonNull(n));
1428 name(n).syntax = mkSyntax ( a, p );
1432 /* --------------------------------------------------------------------------
1434 * ------------------------------------------------------------------------*/
1436 /* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
1437 { C1 a } -> { C2 b } -> T into
1438 ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
1440 static Type dictapsToQualtype ( Type ty )
1443 List preds, dictaps;
1445 /* break ty into pieces at the top-level arrows */
1446 while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
1447 pieces = cons ( arg(fun(ty)), pieces );
1450 pieces = cons ( ty, pieces );
1451 pieces = reverse ( pieces );
1454 while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
1455 dictaps = cons ( hd(pieces), dictaps );
1456 pieces = tl(pieces);
1459 /* dictaps holds the predicates, backwards */
1460 /* pieces holds the remainder of the type, forwards */
1461 assert(nonNull(pieces));
1462 pieces = reverse(pieces);
1464 pieces = tl(pieces);
1465 for (; nonNull(pieces); pieces=tl(pieces))
1466 ty = fn(hd(pieces),ty);
1469 for (; nonNull(dictaps); dictaps=tl(dictaps)) {
1470 Cell da = hd(dictaps);
1471 QualId cl = fst(unap(DICTAP,da));
1472 Cell arg = snd(unap(DICTAP,da));
1473 preds = cons ( pair(cl,arg), preds );
1476 if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
1482 static void startGHCValue ( Int line, VarId vid, Type ty )
1486 Text v = textOf(vid);
1489 fprintf(stderr,"begin startGHCValue %s\n", textToStr(v));
1494 if (nonNull(n) && name(n).defn != PREDEFINED) {
1495 ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
1498 if (isNull(n)) n = newName(v,NIL);
1500 ty = dictapsToQualtype(ty);
1502 tvs = ifTyvarsIn(ty);
1503 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1504 hd(tmp) = zpair(hd(tmp),STAR);
1506 ty = mkPolyType(tvsToKind(tvs),ty);
1508 ty = tvsToOffsets(line,ty,tvs);
1510 name(n).arity = arityInclDictParams(ty);
1511 name(n).line = line;
1516 static void finishGHCValue ( VarId vid )
1518 Name n = findName ( textOf(vid) );
1519 Int line = name(n).line;
1521 fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1523 assert(currentModule == name(n).mod);
1524 name(n).type = conidcellsToTycons(line,name(n).type);
1526 if (isIfaceDefaultMethodName(name(n).text)) {
1527 /* ... we need to set .parent to point to the class
1528 ... once we figure out what the class actually is :-)
1530 Type t = name(n).type;
1531 assert(isPolyType(t));
1532 if (isPolyType(t)) t = monotypeOf(t);
1533 assert(isQualType(t));
1534 t = fst(snd(t)); /* t :: [(Class,Offset)] */
1536 assert(nonNull(hd(t)));
1537 assert(isPair(hd(t)));
1538 t = fst(hd(t)); /* t :: Class */
1541 name(n).parent = t; /* phew! */
1546 /* --------------------------------------------------------------------------
1548 * ------------------------------------------------------------------------*/
1550 static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1552 /* tycon :: ConId */
1553 /* tvs :: [((VarId,Kind))] */
1555 Text t = textOf(tycon);
1557 fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1560 if (nonNull(findTycon(t))) {
1561 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1565 Tycon tc = newTycon(t);
1566 tycon(tc).line = line;
1567 tycon(tc).arity = length(tvs);
1568 tycon(tc).what = SYNONYM;
1569 tycon(tc).kind = tvsToKind(tvs);
1571 /* prepare for finishGHCSynonym */
1572 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
1577 static Void finishGHCSynonym ( ConId tyc )
1579 Tycon tc = findTycon(textOf(tyc));
1580 Int line = tycon(tc).line;
1582 fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1585 assert (currentModule == tycon(tc).mod);
1586 // setCurrModule(tycon(tc).mod);
1587 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1589 /* (ADR) ToDo: can't really do this until I've done all synonyms
1590 * and then I have to do them in order
1591 * tycon(tc).defn = fullExpand(ty);
1592 * (JRS) What?!?! i don't understand
1597 /* --------------------------------------------------------------------------
1599 * ------------------------------------------------------------------------*/
1601 static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1603 List ctx0; /* [((QConId,VarId))] */
1604 Cell tycon; /* ConId */
1605 List ktyvars; /* [((VarId,Kind))] */
1606 List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
1607 /* The Text is an optional field name
1608 The Int indicates strictness */
1609 /* ToDo: worry about being given a decl for (->) ?
1610 * and worry about qualidents for ()
1613 Type ty, resTy, selTy, conArgTy;
1614 List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
1618 Pair conArg, ctxElem;
1620 Int conArgStrictness;
1622 Text t = textOf(tycon);
1624 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1628 if (nonNull(findTycon(t))) {
1629 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1633 Tycon tc = newTycon(t);
1635 tycon(tc).line = line;
1636 tycon(tc).arity = length(ktyvars);
1637 tycon(tc).kind = tvsToKind(ktyvars);
1638 tycon(tc).what = DATATYPE;
1640 /* a list to accumulate selectors in :: [((VarId,Type))] */
1643 /* make resTy the result type of the constr, T v1 ... vn */
1645 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1646 resTy = ap(resTy,zfst(hd(tmp)));
1648 /* for each constructor ... */
1649 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1650 constr = hd(constrs);
1651 conid = zfst(constr);
1652 fields = zsnd(constr);
1654 /* Build type of constr and handle any selectors found.
1655 Also collect up tyvars occurring in the constr's arg
1656 types, so we can throw away irrelevant parts of the
1660 tyvarsMentioned = NIL;
1661 /* tyvarsMentioned :: [VarId] */
1663 conArgs = reverse(fields);
1664 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1665 conArg = hd(conArgs); /* (Type,Text) */
1666 conArgTy = zfst3(conArg);
1667 conArgNm = zsnd3(conArg);
1668 conArgStrictness = intOf(zthd3(conArg));
1669 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1671 if (conArgStrictness > 0) conArgTy = bang(conArgTy);
1672 ty = fn(conArgTy,ty);
1673 if (nonNull(conArgNm)) {
1674 /* a field name is mentioned too */
1675 selTy = fn(resTy,conArgTy);
1676 if (whatIs(tycon(tc).kind) != STAR)
1677 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1678 selTy = tvsToOffsets(line,selTy, ktyvars);
1679 sels = cons( zpair(conArgNm,selTy), sels);
1683 /* Now ty is the constructor's type, not including context.
1684 Throw away any parts of the context not mentioned in
1685 tyvarsMentioned, and use it to qualify ty.
1688 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1690 /* ctxElem :: ((QConId,VarId)) */
1691 if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1692 ctx2 = cons(ctxElem, ctx2);
1695 ty = ap(QUAL,pair(ctx2,ty));
1697 /* stick the tycon's kind on, if not simply STAR */
1698 if (whatIs(tycon(tc).kind) != STAR)
1699 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1701 ty = tvsToOffsets(line,ty, ktyvars);
1703 /* Finally, stick the constructor's type onto it. */
1704 hd(constrs) = ztriple(conid,fields,ty);
1707 /* Final result is that
1708 constrs :: [((ConId,[((Type,Text))],Type))]
1709 lists the constructors and their types
1710 sels :: [((VarId,Type))]
1711 lists the selectors and their types
1713 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1718 static List startGHCConstrs ( Int line, List cons, List sels )
1720 /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1721 /* sels :: [((VarId,Type))] */
1722 /* returns [Name] */
1724 Int conNo = length(cons)>1 ? 1 : 0;
1725 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1726 Name c = startGHCConstr(line,conNo,hd(cs));
1729 /* cons :: [Name] */
1731 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1732 hd(ss) = startGHCSel(line,hd(ss));
1734 /* sels :: [Name] */
1735 return appendOnto(cons,sels);
1739 static Name startGHCSel ( Int line, ZPair sel )
1741 /* sel :: ((VarId, Type)) */
1742 Text t = textOf(zfst(sel));
1743 Type type = zsnd(sel);
1745 Name n = findName(t);
1747 ERRMSG(line) "Repeated definition for selector \"%s\"",
1753 name(n).line = line;
1754 name(n).number = SELNAME;
1757 name(n).type = type;
1762 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1764 /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1765 /* (ADR) ToDo: add rank2 annotation and existential annotation
1766 * these affect how constr can be used.
1768 Text con = textOf(zfst3(constr));
1769 Type type = zthd3(constr);
1770 Int arity = arityFromType(type);
1771 Name n = findName(con); /* Allocate constructor fun name */
1773 n = newName(con,NIL);
1774 } else if (name(n).defn!=PREDEFINED) {
1775 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1779 name(n).arity = arity; /* Save constructor fun details */
1780 name(n).line = line;
1781 name(n).number = cfunNo(conNo);
1782 name(n).type = type;
1787 static List finishGHCDataDecl ( ConId tyc )
1790 Tycon tc = findTycon(textOf(tyc));
1792 fprintf ( stderr, "begin finishGHCDataDecl %s\n",
1793 textToStr(textOf(tyc)) );
1795 if (isNull(tc)) internal("finishGHCDataDecl");
1797 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1799 Int line = name(n).line;
1800 assert(currentModule == name(n).mod);
1801 name(n).type = conidcellsToTycons(line,name(n).type);
1802 name(n).parent = tc; //---????
1805 return tycon(tc).defn;
1809 /* --------------------------------------------------------------------------
1811 * ------------------------------------------------------------------------*/
1813 static Void startGHCNewType ( Int line, List ctx0,
1814 ConId tycon, List tvs, Cell constr )
1816 /* ctx0 :: [((QConId,VarId))] */
1817 /* tycon :: ConId */
1818 /* tvs :: [((VarId,Kind))] */
1819 /* constr :: ((ConId,Type)) or NIL if abstract */
1822 Text t = textOf(tycon);
1824 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1829 if (nonNull(findTycon(t))) {
1830 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1834 Tycon tc = newTycon(t);
1835 tycon(tc).line = line;
1836 tycon(tc).arity = length(tvs);
1837 tycon(tc).what = NEWTYPE;
1838 tycon(tc).kind = tvsToKind(tvs);
1839 /* can't really do this until I've read in all synonyms */
1841 if (isNull(constr)) {
1842 tycon(tc).defn = NIL;
1844 /* constr :: ((ConId,Type)) */
1845 Text con = textOf(zfst(constr));
1846 Type type = zsnd(constr);
1847 Name n = findName(con); /* Allocate constructor fun name */
1849 n = newName(con,NIL);
1850 } else if (name(n).defn!=PREDEFINED) {
1851 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1855 name(n).arity = 1; /* Save constructor fun details */
1856 name(n).line = line;
1857 name(n).number = cfunNo(0);
1858 name(n).defn = nameId;
1859 tycon(tc).defn = singleton(n);
1861 /* make resTy the result type of the constr, T v1 ... vn */
1863 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1864 resTy = ap(resTy,zfst(hd(tmp)));
1865 type = fn(type,resTy);
1867 type = ap(QUAL,pair(ctx0,type));
1868 type = tvsToOffsets(line,type,tvs);
1869 name(n).type = type;
1875 static Void finishGHCNewType ( ConId tyc )
1877 Tycon tc = findTycon(textOf(tyc));
1879 fprintf ( stderr, "begin finishGHCNewType %s\n",
1880 textToStr(textOf(tyc)) );
1883 if (isNull(tc)) internal("finishGHCNewType");
1885 if (isNull(tycon(tc).defn)) {
1886 /* it's an abstract type */
1888 else if (length(tycon(tc).defn) == 1) {
1889 /* As we expect, has a single constructor */
1890 Name n = hd(tycon(tc).defn);
1891 Int line = name(n).line;
1892 assert(currentModule == name(n).mod);
1893 name(n).type = conidcellsToTycons(line,name(n).type);
1895 internal("finishGHCNewType(2)");
1900 /* --------------------------------------------------------------------------
1901 * Class declarations
1902 * ------------------------------------------------------------------------*/
1904 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1906 List ctxt; /* [((QConId, VarId))] */
1907 ConId tc_name; /* ConId */
1908 List kinded_tvs; /* [((VarId, Kind))] */
1909 List mems0; { /* [((VarId, Type))] */
1911 List mems; /* [((VarId, Type))] */
1912 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1913 List tvs; /* [((VarId,Kind))] */
1914 List ns; /* [Name] */
1917 ZPair kinded_tv = hd(kinded_tvs);
1918 Text ct = textOf(tc_name);
1919 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1921 fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
1925 if (length(kinded_tvs) != 1) {
1926 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1930 if (nonNull(findClass(ct))) {
1931 ERRMSG(line) "Repeated definition of class \"%s\"",
1934 } else if (nonNull(findTycon(ct))) {
1935 ERRMSG(line) "\"%s\" used as both class and type constructor",
1939 Class nw = newClass(ct);
1940 cclass(nw).text = ct;
1941 cclass(nw).line = line;
1942 cclass(nw).arity = 1;
1943 cclass(nw).head = ap(nw,mkOffset(0));
1944 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1945 cclass(nw).instances = NIL;
1946 cclass(nw).numSupers = length(ctxt);
1948 /* Kludge to map the single tyvar in the context to Offset 0.
1949 Need to do something better for multiparam type classes.
1951 cclass(nw).supers = tvsToOffsets(line,ctxt,
1952 singleton(kinded_tv));
1955 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1956 ZPair mem = hd(mems);
1957 Type memT = zsnd(mem);
1958 Text mnt = textOf(zfst(mem));
1961 /* Stick the new context on the member type */
1962 memT = dictapsToQualtype(memT);
1963 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1964 if (whatIs(memT)==QUAL) {
1966 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1969 pair(singleton(newCtx),memT));
1972 /* Cook up a kind for the type. */
1973 tvsInT = ifTyvarsIn(memT);
1974 /* tvsInT :: [VarId] */
1976 /* ToDo: maximally bogus. We allow the class tyvar to
1977 have the kind as supplied by the parser, but we just
1978 assume that all others have kind *. It's a kludge.
1980 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
1982 if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
1983 k = zsnd(kinded_tv); else
1985 hd(tvs) = zpair(hd(tvs),k);
1987 /* tvsIntT :: [((VarId,Kind))] */
1989 memT = mkPolyType(tvsToKind(tvsInT),memT);
1990 memT = tvsToOffsets(line,memT,tvsInT);
1992 /* Park the type back on the member */
1993 mem = zpair(zfst(mem),memT);
1995 /* Bind code to the member */
1999 "Repeated definition for class method \"%s\"",
2003 mn = newName(mnt,NIL);
2008 cclass(nw).members = mems0;
2009 cclass(nw).numMembers = length(mems0);
2012 for (mno=0; mno<cclass(nw).numSupers; mno++) {
2013 ns = cons(newDSel(nw,mno),ns);
2015 cclass(nw).dsels = rev(ns);
2020 static Class finishGHCClass ( Tycon cls_tyc )
2025 Class nw = findClass ( textOf(cls_tyc) );
2027 fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
2029 if (isNull(nw)) internal("finishGHCClass");
2031 line = cclass(nw).line;
2033 assert (currentModule == cclass(nw).mod);
2035 cclass(nw).level = 0;
2036 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
2037 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
2038 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
2040 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2041 Pair mem = hd(mems); /* (VarId, Type) */
2042 Text txt = textOf(fst(mem));
2044 Name n = findName(txt);
2047 name(n).line = cclass(nw).line;
2049 name(n).number = ctr--;
2050 name(n).arity = arityInclDictParams(name(n).type);
2051 name(n).parent = nw;
2059 /* --------------------------------------------------------------------------
2061 * ------------------------------------------------------------------------*/
2063 static Inst startGHCInstance (line,ktyvars,cls,var)
2065 List ktyvars; /* [((VarId,Kind))] */
2066 Type cls; /* Type */
2067 VarId var; { /* VarId */
2068 List tmp, tvs, ks, spec;
2073 Inst in = newInst();
2075 fprintf ( stderr, "begin startGHCInstance\n" );
2080 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2082 The order of tvs is important for tvsToOffsets.
2083 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2084 out of ktyvars and attach them to tvs.
2086 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2088 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2089 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2091 if (isNull(k)) internal("startGHCInstance: finding kinds");
2092 hd(xs1) = zpair(hd(xs1),k);
2095 cls = tvsToOffsets(line,cls,tvs);
2098 spec = cons(fun(cls),spec);
2101 spec = reverse(spec);
2103 inst(in).line = line;
2104 inst(in).implements = NIL;
2105 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2106 inst(in).specifics = spec;
2107 inst(in).numSpecifics = length(spec);
2108 inst(in).head = cls;
2110 /* Figure out the name of the class being instanced, and store it
2111 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2113 Cell cl = inst(in).head;
2114 assert(whatIs(cl)==DICTAP);
2115 cl = unap(DICTAP,cl);
2117 assert ( isQCon(cl) );
2122 Name b = newName( /*inventText()*/ textOf(var),NIL);
2123 name(b).line = line;
2124 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2125 name(b).number = DFUNNAME;
2126 name(b).parent = in;
2127 inst(in).builder = b;
2128 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2135 static Void finishGHCInstance ( Inst in )
2142 fprintf ( stderr, "begin finishGHCInstance\n" );
2145 assert (nonNull(in));
2146 line = inst(in).line;
2147 assert (currentModule==inst(in).mod);
2149 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2150 since startGHCInstance couldn't possibly have resolved it to
2151 a Class at that point. We convert it to a Class now.
2155 c = findQualClassWithoutConsultingExportList(c);
2159 inst(in).head = conidcellsToTycons(line,inst(in).head);
2160 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2161 cclass(c).instances = cons(in,cclass(c).instances);
2165 /* --------------------------------------------------------------------------
2167 * ------------------------------------------------------------------------*/
2169 /* This is called from the startGHC* functions. It traverses a structure
2170 and converts varidcells, ie, type variables parsed by the interface
2171 parser, into Offsets, which is how Hugs wants to see them internally.
2172 The Offset for a type variable is determined by its place in the list
2173 passed as the second arg; the associated kinds are irrelevant.
2175 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2178 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2179 static Type tvsToOffsets(line,type,ktyvars)
2182 List ktyvars; { /* [((VarId,Kind))] */
2183 switch (whatIs(type)) {
2190 case ZTUP2: /* convert to the untyped representation */
2191 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2192 tvsToOffsets(line,zsnd(type),ktyvars) );
2194 return ap( tvsToOffsets(line,fun(type),ktyvars),
2195 tvsToOffsets(line,arg(type),ktyvars) );
2199 tvsToOffsets(line,monotypeOf(type),ktyvars)
2203 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2204 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2205 case DICTAP: /* bogus ?? */
2206 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2207 case UNBOXEDTUP: /* bogus?? */
2208 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2209 case BANG: /* bogus?? */
2210 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2211 case VARIDCELL: /* Ha! some real work to do! */
2213 Text tv = textOf(type);
2214 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2217 assert(isZPair(hd(ktyvars)));
2218 varid = zfst(hd(ktyvars));
2220 if (tv == tt) return mkOffset(i);
2222 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2227 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2229 fprintf(stderr,"\n");
2233 return NIL; /* NOTREACHED */
2237 /* This is called from the finishGHC* functions. It traverses a structure
2238 and converts conidcells, ie, type constructors parsed by the interface
2239 parser, into Tycons (or Classes), which is how Hugs wants to see them
2240 internally. Calls to this fn have to be deferred to the second phase
2241 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2242 Tycons or Classes have been loaded into the symbol tables and can be
2245 static Type conidcellsToTycons ( Int line, Type type )
2247 switch (whatIs(type)) {
2257 { Cell t; /* Tycon or Class */
2258 Text m = qmodOf(type);
2259 Module mod = findModule(m);
2262 "Undefined module in qualified name \"%s\"",
2267 t = findQualTyconWithoutConsultingExportList(type);
2268 if (nonNull(t)) return t;
2269 t = findQualClassWithoutConsultingExportList(type);
2270 if (nonNull(t)) return t;
2272 "Undefined qualified class or type \"%s\"",
2280 cl = findQualClass(type);
2281 if (nonNull(cl)) return cl;
2282 if (textOf(type)==findText("[]"))
2283 /* a hack; magically qualify [] into PrelBase.[] */
2284 return conidcellsToTycons(line,
2285 mkQualId(mkCon(findText("PrelBase")),type));
2286 tc = findQualTycon(type);
2287 if (nonNull(tc)) return tc;
2289 "Undefined class or type constructor \"%s\"",
2295 return ap( conidcellsToTycons(line,fun(type)),
2296 conidcellsToTycons(line,arg(type)) );
2297 case ZTUP2: /* convert to std pair */
2298 return ap( conidcellsToTycons(line,zfst(type)),
2299 conidcellsToTycons(line,zsnd(type)) );
2304 conidcellsToTycons(line,monotypeOf(type))
2308 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2309 conidcellsToTycons(line,snd(snd(type)))));
2310 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2311 Not sure if this is really the right place to
2312 convert it to the form Hugs wants, but will do so anyway.
2314 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2316 Class cl = fst(unap(DICTAP,type));
2317 List args = snd(unap(DICTAP,type));
2319 conidcellsToTycons(line,pair(cl,args));
2322 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2324 return ap(BANG, conidcellsToTycons(line, snd(type)));
2326 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2329 fprintf(stderr,"\n");
2333 return NIL; /* NOTREACHED */
2337 /* Find out if a type mentions a type constructor not present in
2338 the supplied list of qualified tycons.
2340 static Bool allTypesKnown ( Type type,
2341 List aktys /* [QualId] */,
2344 switch (whatIs(type)) {
2351 return allTypesKnown(fun(type),aktys,thisMod)
2352 && allTypesKnown(arg(type),aktys,thisMod);
2354 return allTypesKnown(zfst(type),aktys,thisMod)
2355 && allTypesKnown(zsnd(type),aktys,thisMod);
2357 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2360 if (textOf(type)==findText("[]"))
2361 /* a hack; magically qualify [] into PrelBase.[] */
2362 type = mkQualId(mkCon(findText("PrelBase")),type); else
2363 type = mkQualId(thisMod,type);
2366 if (isNull(qualidIsMember(type,aktys))) goto missing;
2372 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2373 print(type,10);printf("\n");
2374 internal("allTypesKnown");
2375 return TRUE; /*notreached*/
2379 fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
2380 fprintf(stderr,"\n");
2386 /* --------------------------------------------------------------------------
2389 * None of these do lookups or require that lookups have been resolved
2390 * so they can be performed while reading interfaces.
2391 * ------------------------------------------------------------------------*/
2393 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2394 static Kinds tvsToKind(tvs)
2395 List tvs; { /* [((VarId,Kind))] */
2398 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2399 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2400 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2401 r = ap(zsnd(hd(rs)),r);
2407 static Int arityInclDictParams ( Type type )
2410 if (isPolyType(type)) type = monotypeOf(type);
2412 if (whatIs(type) == QUAL)
2414 arity += length ( fst(snd(type)) );
2415 type = snd(snd(type));
2417 while (isAp(type) && getHead(type)==typeArrow) {
2424 /* arity of a constructor with this type */
2425 static Int arityFromType(type)
2428 if (isPolyType(type)) {
2429 type = monotypeOf(type);
2431 if (whatIs(type) == QUAL) {
2432 type = snd(snd(type));
2434 if (whatIs(type) == EXIST) {
2435 type = snd(snd(type));
2437 if (whatIs(type)==RANK2) {
2438 type = snd(snd(type));
2440 while (isAp(type) && getHead(type)==typeArrow) {
2448 /* ifTyvarsIn :: Type -> [VarId]
2449 The returned list has no duplicates -- is a set.
2451 static List ifTyvarsIn(type)
2453 List vs = typeVarsIn(type,NIL,NIL,NIL);
2455 for (; nonNull(vs2); vs2=tl(vs2))
2456 if (whatIs(hd(vs2)) != VARIDCELL)
2457 internal("ifTyvarsIn");
2463 /* --------------------------------------------------------------------------
2464 * General object symbol query stuff
2465 * ------------------------------------------------------------------------*/
2467 #define EXTERN_SYMS_ALLPLATFORMS \
2469 Sym(stg_gc_enter_1) \
2470 Sym(stg_gc_noregs) \
2478 Sym(stg_update_PAP) \
2479 Sym(stg_error_entry) \
2480 Sym(__ap_2_upd_info) \
2481 Sym(__ap_3_upd_info) \
2482 Sym(__ap_4_upd_info) \
2483 Sym(__ap_5_upd_info) \
2484 Sym(__ap_6_upd_info) \
2485 Sym(__ap_7_upd_info) \
2486 Sym(__ap_8_upd_info) \
2487 Sym(__sel_0_upd_info) \
2488 Sym(__sel_1_upd_info) \
2489 Sym(__sel_2_upd_info) \
2490 Sym(__sel_3_upd_info) \
2491 Sym(__sel_4_upd_info) \
2492 Sym(__sel_5_upd_info) \
2493 Sym(__sel_6_upd_info) \
2494 Sym(__sel_7_upd_info) \
2495 Sym(__sel_8_upd_info) \
2496 Sym(__sel_9_upd_info) \
2497 Sym(__sel_10_upd_info) \
2498 Sym(__sel_11_upd_info) \
2499 Sym(__sel_12_upd_info) \
2500 Sym(Upd_frame_info) \
2501 Sym(seq_frame_info) \
2502 Sym(CAF_BLACKHOLE_info) \
2503 Sym(IND_STATIC_info) \
2504 Sym(EMPTY_MVAR_info) \
2505 Sym(MUT_ARR_PTRS_FROZEN_info) \
2507 Sym(putMVarzh_fast) \
2508 Sym(newMVarzh_fast) \
2509 Sym(takeMVarzh_fast) \
2514 Sym(killThreadzh_fast) \
2515 Sym(waitReadzh_fast) \
2516 Sym(waitWritezh_fast) \
2517 Sym(CHARLIKE_closure) \
2518 Sym(INTLIKE_closure) \
2519 Sym(suspendThread) \
2521 Sym(stackOverflow) \
2522 Sym(int2Integerzh_fast) \
2523 Sym(stg_gc_unbx_r1) \
2525 Sym(makeForeignObjzh_fast) \
2526 Sym(__encodeDouble) \
2527 Sym(decodeDoublezh_fast) \
2529 Sym(isDoubleInfinite) \
2530 Sym(isDoubleDenormalized) \
2531 Sym(isDoubleNegativeZero) \
2532 Sym(__encodeFloat) \
2533 Sym(decodeFloatzh_fast) \
2535 Sym(isFloatInfinite) \
2536 Sym(isFloatDenormalized) \
2537 Sym(isFloatNegativeZero) \
2538 Sym(__int_encodeFloat) \
2539 Sym(__int_encodeDouble) \
2543 Sym(gcdIntegerzh_fast) \
2544 Sym(newArrayzh_fast) \
2545 Sym(unsafeThawArrayzh_fast) \
2546 Sym(newDoubleArrayzh_fast) \
2547 Sym(newFloatArrayzh_fast) \
2548 Sym(newAddrArrayzh_fast) \
2549 Sym(newWordArrayzh_fast) \
2550 Sym(newIntArrayzh_fast) \
2551 Sym(newCharArrayzh_fast) \
2552 Sym(newMutVarzh_fast) \
2553 Sym(quotRemIntegerzh_fast) \
2554 Sym(quotIntegerzh_fast) \
2555 Sym(remIntegerzh_fast) \
2556 Sym(divExactIntegerzh_fast) \
2557 Sym(divModIntegerzh_fast) \
2558 Sym(timesIntegerzh_fast) \
2559 Sym(minusIntegerzh_fast) \
2560 Sym(plusIntegerzh_fast) \
2561 Sym(addr2Integerzh_fast) \
2562 Sym(mkWeakzh_fast) \
2565 Sym(resetNonBlockingFd) \
2567 Sym(stable_ptr_table) \
2568 Sym(createAdjThunk) \
2569 Sym(shutdownHaskellAndExit) \
2570 Sym(stg_enterStackTop) \
2571 Sym(CAF_UNENTERED_entry) \
2572 Sym(stg_yield_to_Hugs) \
2576 /* needed by libHS_cbits */ \
2610 #define EXTERN_SYMS_cygwin32 \
2611 SymX(GetCurrentProcess) \
2612 SymX(GetProcessTimes) \
2621 SymX(__imp__tzname) \
2622 SymX(__imp__timezone) \
2641 #define EXTERN_SYMS_linux \
2642 Sym(__errno_location) \
2660 #if defined(linux_TARGET_OS)
2661 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
2664 #if defined(solaris2_TARGET_OS)
2665 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
2668 #if defined(cygwin32_TARGET_OS)
2669 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
2675 /* entirely bogus claims about types of these symbols */
2676 #define Sym(vvv) extern void (vvv);
2677 #define SymX(vvv) /**/
2678 EXTERN_SYMS_ALLPLATFORMS
2679 EXTERN_SYMS_THISPLATFORM
2684 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2686 #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2690 EXTERN_SYMS_ALLPLATFORMS
2691 EXTERN_SYMS_THISPLATFORM
2701 /* A kludge to assist Win32 debugging. */
2702 char* nameFromStaticOPtr ( void* ptr )
2705 for (k = 0; rtsTab[k].nm; k++)
2706 if (ptr == rtsTab[k].ad)
2707 return rtsTab[k].nm;
2712 void* lookupObjName ( char* nm )
2720 int first_real_char;
2723 strncpy(nm2,nm,200);
2725 /* first see if it's an RTS name */
2726 for (k = 0; rtsTab[k].nm; k++)
2727 if (0==strcmp(nm2,rtsTab[k].nm))
2728 return rtsTab[k].ad;
2730 /* perhaps an extra-symbol ? */
2731 a = lookupOExtraTabName ( nm );
2734 # if LEADING_UNDERSCORE
2735 first_real_char = 1;
2737 first_real_char = 0;
2740 /* Maybe it's an __init_Module thing? */
2741 if (strlen(nm2+first_real_char) > 7
2742 && strncmp(nm2+first_real_char, "__init_", 7)==0) {
2743 t = unZcodeThenFindText(nm2+first_real_char+7);
2744 if (t == findText("PrelGHC")) return (4+NULL); /* kludge */
2746 if (isNull(m)) goto not_found;
2747 a = lookupOTabName ( m, nm );
2752 /* if not an RTS name, look in the
2753 relevant module's object symbol table
2755 pp = strchr(nm2+first_real_char, '_');
2756 if (!pp || !isupper(nm2[first_real_char])) goto not_found;
2758 t = unZcodeThenFindText(nm2+first_real_char);
2760 if (isNull(m)) goto not_found;
2762 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2767 "lookupObjName: can't resolve name `%s'\n",
2774 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2776 OSectionKind sk = lookupSection(p);
2777 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2778 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2782 int is_dynamically_loaded_rwdata_ptr ( char* p )
2784 OSectionKind sk = lookupSection(p);
2785 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2786 return (sk == HUGS_SECTIONKIND_RWDATA);
2790 int is_not_dynamically_loaded_ptr ( char* p )
2792 OSectionKind sk = lookupSection(p);
2793 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2794 return (sk == HUGS_SECTIONKIND_OTHER);
2798 /* --------------------------------------------------------------------------
2800 * ------------------------------------------------------------------------*/
2802 Void interface(what)
2805 case POSTPREL: break;
2809 ifaces_outstanding = NIL;
2812 mark(ifaces_outstanding);
2817 /*-------------------------------------------------------------------------*/