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/03/22 18:14:22 $
12 * ------------------------------------------------------------------------*/
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).fromSrc);
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 ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
1091 = ocNew ( startGHCModule_errMsg,
1092 startGHCModule_clientLookup,
1096 ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
1099 if (!ocLoadImage(oc,VERBOSE)) {
1100 ERRMSG(0) "Reading of object file \"%s\" failed", objNm
1103 if (!ocVerifyImage(oc,VERBOSE)) {
1104 ERRMSG(0) "Validation of object file \"%s\" failed", objNm
1107 if (!ocGetNames(oc,VERBOSE)) {
1108 ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
1114 static Void startGHCModule ( Text mname )
1117 Module m = findModule(mname);
1121 fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
1122 textToStr(mname), module(m).objSize );
1125 module(m).fake = FALSE;
1127 /* Get hold of the primary object for the module. */
1129 = startGHCModule_partial_load ( textToStr(module(m).objName),
1130 module(m).objSize );
1132 /* and any extras ... */
1133 for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
1137 String nm = getExtraObjectInfo (
1138 textToStr(module(m).objName),
1143 ERRMSG(0) "Can't find extra object file \"%s\"", nm
1146 oc = startGHCModule_partial_load ( nm, size );
1147 oc->next = module(m).objectExtras;
1148 module(m).objectExtras = oc;
1153 /* For the module mod, augment both the export environment (.exports)
1154 and the eval environment (.names, .tycons, .classes)
1155 with the symbols mentioned in exlist. We don't actually need
1156 to modify the names, tycons, classes or instances in the eval
1157 environment, since previous processing of the
1158 top-level decls in the iface should have done this already.
1160 mn is the module mentioned in the export list; it is the "original"
1161 module for the symbols in the export list. We should also record
1162 this info with the symbols, since references to object code need to
1163 refer to the original module in which a symbol was defined, rather
1164 than to some module it has been imported into and then re-exported.
1166 We take the policy that if something mentioned in an export list
1167 can't be found in the symbol tables, it is simply ignored. After all,
1168 previous processing of the iface syntax trees has already removed
1169 everything which Hugs can't handle, so if there is mention of these
1170 things still lurking in export lists somewhere, about the only thing
1171 to do is to ignore it.
1173 Also do an implicit 'import Prelude' thingy for the module,
1178 static Void finishGHCModule ( Cell root )
1180 /* root :: I_INTERFACE */
1181 Cell iface = unap(I_INTERFACE,root);
1182 ConId iname = zfst(iface);
1183 Module mod = findModule(textOf(iname));
1184 List exlist_list = NIL;
1189 fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1192 if (isNull(mod)) internal("finishExports(1)");
1195 exlist_list = getExportDeclsInIFace ( root );
1196 /* exlist_list :: [I_EXPORT] */
1198 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1199 ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
1200 ConId exmod = zfst(exdecl);
1201 List exlist = zsnd(exdecl);
1202 /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1204 for (; nonNull(exlist); exlist=tl(exlist)) {
1209 Cell ex = hd(exlist);
1211 switch (whatIs(ex)) {
1213 case VARIDCELL: /* variable */
1214 q = mkQualId(exmod,ex);
1215 c = findQualNameWithoutConsultingExportList ( q );
1216 if (isNull(c)) goto notfound;
1218 fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
1220 module(mod).exports = cons(c, module(mod).exports);
1224 case CONIDCELL: /* non data tycon */
1225 q = mkQualId(exmod,ex);
1226 c = findQualTyconWithoutConsultingExportList ( q );
1227 if (isNull(c)) goto notfound;
1229 fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
1231 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1235 case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
1236 subents = zsnd(ex); /* :: [ConVarId] */
1237 ex = zfst(ex); /* :: ConId */
1238 q = mkQualId(exmod,ex);
1239 c = findQualTyconWithoutConsultingExportList ( q );
1241 if (nonNull(c)) { /* data */
1243 fprintf(stderr, " data/newtype %s = { ",
1244 textToStr(textOf(ex)) );
1246 assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1247 abstract = isNull(tycon(c).defn);
1248 /* This data/newtype could be abstract even tho the export list
1249 says to export it non-abstractly. That happens if it was
1250 imported from some other module and is now being re-exported,
1251 and previous cleanup phases have abstractified it in the
1252 original (defining) module.
1255 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1258 fprintf ( stderr, "(abstract) ");
1261 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1263 for (; nonNull(subents); subents = tl(subents)) {
1264 Cell ent2 = hd(subents);
1265 assert(isCon(ent2) || isVar(ent2));
1266 /* isVar since could be a field name */
1267 q = mkQualId(exmod,ent2);
1268 c = findQualNameWithoutConsultingExportList ( q );
1270 fprintf(stderr, "%s ", textToStr(name(c).text));
1273 /* module(mod).exports = cons(c, module(mod).exports); */
1278 fprintf(stderr, "}\n" );
1280 } else { /* class */
1281 q = mkQualId(exmod,ex);
1282 c = findQualClassWithoutConsultingExportList ( q );
1283 if (isNull(c)) goto notfound;
1285 fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
1287 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1289 for (; nonNull(subents); subents = tl(subents)) {
1290 Cell ent2 = hd(subents);
1291 assert(isVar(ent2));
1292 q = mkQualId(exmod,ent2);
1293 c = findQualNameWithoutConsultingExportList ( q );
1295 fprintf(stderr, "%s ", textToStr(name(c).text));
1297 if (isNull(c)) goto notfound;
1298 /* module(mod).exports = cons(c, module(mod).exports); */
1302 fprintf(stderr, "}\n" );
1308 internal("finishExports(2)");
1311 continue; /* so notfound: can be placed after this */
1314 /* q holds what ain't found */
1315 assert(whatIs(q)==QUALIDENT);
1317 fprintf( stderr, " ------ IGNORED: %s.%s\n",
1318 textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1325 if (preludeLoaded) {
1326 /* do the implicit 'import Prelude' thing */
1327 List pxs = module(modulePrelude).exports;
1328 for (; nonNull(pxs); pxs=tl(pxs)) {
1331 switch (whatIs(px)) {
1336 module(mod).names = cons ( px, module(mod).names );
1339 module(mod).tycons = cons ( px, module(mod).tycons );
1342 module(mod).classes = cons ( px, module(mod).classes );
1345 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1346 internal("finishGHCModule -- implicit import Prelude");
1353 /* Last, but by no means least ... */
1354 if (!ocResolve(module(mod).object,VERBOSE))
1355 internal("finishGHCModule: object resolution failed");
1357 for (oc=module(mod).objectExtras; oc; oc=oc->next) {
1358 if (!ocResolve(oc, VERBOSE))
1359 internal("finishGHCModule: extra object resolution failed");
1364 /* --------------------------------------------------------------------------
1366 * ------------------------------------------------------------------------*/
1368 static Void startGHCExports ( ConId mn, List exlist )
1371 fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
1373 /* Nothing to do. */
1376 static Void finishGHCExports ( ConId mn, List exlist )
1379 fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
1381 /* Nothing to do. */
1385 /* --------------------------------------------------------------------------
1387 * ------------------------------------------------------------------------*/
1389 static Void startGHCImports ( ConId mn, List syms )
1390 /* nm the module to import from */
1391 /* syms [ConId | VarId] -- the names to import */
1394 fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
1396 /* Nothing to do. */
1400 static Void finishGHCImports ( ConId nm, List syms )
1401 /* nm the module to import from */
1402 /* syms [ConId | VarId] -- the names to import */
1405 fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
1407 /* Nothing to do. */
1411 /* --------------------------------------------------------------------------
1413 * ------------------------------------------------------------------------*/
1415 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
1417 Int p = intOf(prec);
1418 Int a = intOf(assoc);
1419 Name n = findName(textOf(name));
1420 assert (nonNull(n));
1421 name(n).syntax = mkSyntax ( a, p );
1425 /* --------------------------------------------------------------------------
1427 * ------------------------------------------------------------------------*/
1429 /* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
1430 { C1 a } -> { C2 b } -> T into
1431 ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
1433 static Type dictapsToQualtype ( Type ty )
1436 List preds, dictaps;
1438 /* break ty into pieces at the top-level arrows */
1439 while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
1440 pieces = cons ( arg(fun(ty)), pieces );
1443 pieces = cons ( ty, pieces );
1444 pieces = reverse ( pieces );
1447 while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
1448 dictaps = cons ( hd(pieces), dictaps );
1449 pieces = tl(pieces);
1452 /* dictaps holds the predicates, backwards */
1453 /* pieces holds the remainder of the type, forwards */
1454 assert(nonNull(pieces));
1455 pieces = reverse(pieces);
1457 pieces = tl(pieces);
1458 for (; nonNull(pieces); pieces=tl(pieces))
1459 ty = fn(hd(pieces),ty);
1462 for (; nonNull(dictaps); dictaps=tl(dictaps)) {
1463 Cell da = hd(dictaps);
1464 QualId cl = fst(unap(DICTAP,da));
1465 Cell arg = snd(unap(DICTAP,da));
1466 preds = cons ( pair(cl,arg), preds );
1469 if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
1475 static void startGHCValue ( Int line, VarId vid, Type ty )
1479 Text v = textOf(vid);
1482 fprintf(stderr,"begin startGHCValue %s\n", textToStr(v));
1487 if (nonNull(n) && name(n).defn != PREDEFINED) {
1488 ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
1491 if (isNull(n)) n = newName(v,NIL);
1493 ty = dictapsToQualtype(ty);
1495 tvs = ifTyvarsIn(ty);
1496 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1497 hd(tmp) = zpair(hd(tmp),STAR);
1499 ty = mkPolyType(tvsToKind(tvs),ty);
1501 ty = tvsToOffsets(line,ty,tvs);
1503 name(n).arity = arityInclDictParams(ty);
1504 name(n).line = line;
1509 static void finishGHCValue ( VarId vid )
1511 Name n = findName ( textOf(vid) );
1512 Int line = name(n).line;
1514 fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1516 assert(currentModule == name(n).mod);
1517 name(n).type = conidcellsToTycons(line,name(n).type);
1519 if (isIfaceDefaultMethodName(name(n).text)) {
1520 /* ... we need to set .parent to point to the class
1521 ... once we figure out what the class actually is :-)
1523 Type t = name(n).type;
1524 assert(isPolyType(t));
1525 if (isPolyType(t)) t = monotypeOf(t);
1526 assert(isQualType(t));
1527 t = fst(snd(t)); /* t :: [(Class,Offset)] */
1529 assert(nonNull(hd(t)));
1530 assert(isPair(hd(t)));
1531 t = fst(hd(t)); /* t :: Class */
1534 name(n).parent = t; /* phew! */
1539 /* --------------------------------------------------------------------------
1541 * ------------------------------------------------------------------------*/
1543 static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1545 /* tycon :: ConId */
1546 /* tvs :: [((VarId,Kind))] */
1548 Text t = textOf(tycon);
1550 fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1553 if (nonNull(findTycon(t))) {
1554 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1558 Tycon tc = newTycon(t);
1559 tycon(tc).line = line;
1560 tycon(tc).arity = length(tvs);
1561 tycon(tc).what = SYNONYM;
1562 tycon(tc).kind = tvsToKind(tvs);
1564 /* prepare for finishGHCSynonym */
1565 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
1570 static Void finishGHCSynonym ( ConId tyc )
1572 Tycon tc = findTycon(textOf(tyc));
1573 Int line = tycon(tc).line;
1575 fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1578 assert (currentModule == tycon(tc).mod);
1579 // setCurrModule(tycon(tc).mod);
1580 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1582 /* (ADR) ToDo: can't really do this until I've done all synonyms
1583 * and then I have to do them in order
1584 * tycon(tc).defn = fullExpand(ty);
1585 * (JRS) What?!?! i don't understand
1590 /* --------------------------------------------------------------------------
1592 * ------------------------------------------------------------------------*/
1594 static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1596 List ctx0; /* [((QConId,VarId))] */
1597 Cell tycon; /* ConId */
1598 List ktyvars; /* [((VarId,Kind))] */
1599 List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
1600 /* The Text is an optional field name
1601 The Int indicates strictness */
1602 /* ToDo: worry about being given a decl for (->) ?
1603 * and worry about qualidents for ()
1606 Type ty, resTy, selTy, conArgTy;
1607 List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
1611 Pair conArg, ctxElem;
1613 Int conArgStrictness;
1615 Text t = textOf(tycon);
1617 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1621 if (nonNull(findTycon(t))) {
1622 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1626 Tycon tc = newTycon(t);
1628 tycon(tc).line = line;
1629 tycon(tc).arity = length(ktyvars);
1630 tycon(tc).kind = tvsToKind(ktyvars);
1631 tycon(tc).what = DATATYPE;
1633 /* a list to accumulate selectors in :: [((VarId,Type))] */
1636 /* make resTy the result type of the constr, T v1 ... vn */
1638 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1639 resTy = ap(resTy,zfst(hd(tmp)));
1641 /* for each constructor ... */
1642 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1643 constr = hd(constrs);
1644 conid = zfst(constr);
1645 fields = zsnd(constr);
1647 /* Build type of constr and handle any selectors found.
1648 Also collect up tyvars occurring in the constr's arg
1649 types, so we can throw away irrelevant parts of the
1653 tyvarsMentioned = NIL;
1654 /* tyvarsMentioned :: [VarId] */
1656 conArgs = reverse(fields);
1657 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1658 conArg = hd(conArgs); /* (Type,Text) */
1659 conArgTy = zfst3(conArg);
1660 conArgNm = zsnd3(conArg);
1661 conArgStrictness = intOf(zthd3(conArg));
1662 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1664 if (conArgStrictness > 0) conArgTy = bang(conArgTy);
1665 ty = fn(conArgTy,ty);
1666 if (nonNull(conArgNm)) {
1667 /* a field name is mentioned too */
1668 selTy = fn(resTy,conArgTy);
1669 if (whatIs(tycon(tc).kind) != STAR)
1670 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1671 selTy = tvsToOffsets(line,selTy, ktyvars);
1672 sels = cons( zpair(conArgNm,selTy), sels);
1676 /* Now ty is the constructor's type, not including context.
1677 Throw away any parts of the context not mentioned in
1678 tyvarsMentioned, and use it to qualify ty.
1681 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1683 /* ctxElem :: ((QConId,VarId)) */
1684 if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1685 ctx2 = cons(ctxElem, ctx2);
1688 ty = ap(QUAL,pair(ctx2,ty));
1690 /* stick the tycon's kind on, if not simply STAR */
1691 if (whatIs(tycon(tc).kind) != STAR)
1692 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1694 ty = tvsToOffsets(line,ty, ktyvars);
1696 /* Finally, stick the constructor's type onto it. */
1697 hd(constrs) = ztriple(conid,fields,ty);
1700 /* Final result is that
1701 constrs :: [((ConId,[((Type,Text))],Type))]
1702 lists the constructors and their types
1703 sels :: [((VarId,Type))]
1704 lists the selectors and their types
1706 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1711 static List startGHCConstrs ( Int line, List cons, List sels )
1713 /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1714 /* sels :: [((VarId,Type))] */
1715 /* returns [Name] */
1717 Int conNo = length(cons)>1 ? 1 : 0;
1718 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1719 Name c = startGHCConstr(line,conNo,hd(cs));
1722 /* cons :: [Name] */
1724 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1725 hd(ss) = startGHCSel(line,hd(ss));
1727 /* sels :: [Name] */
1728 return appendOnto(cons,sels);
1732 static Name startGHCSel ( Int line, ZPair sel )
1734 /* sel :: ((VarId, Type)) */
1735 Text t = textOf(zfst(sel));
1736 Type type = zsnd(sel);
1738 Name n = findName(t);
1740 ERRMSG(line) "Repeated definition for selector \"%s\"",
1746 name(n).line = line;
1747 name(n).number = SELNAME;
1750 name(n).type = type;
1755 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1757 /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1758 /* (ADR) ToDo: add rank2 annotation and existential annotation
1759 * these affect how constr can be used.
1761 Text con = textOf(zfst3(constr));
1762 Type type = zthd3(constr);
1763 Int arity = arityFromType(type);
1764 Name n = findName(con); /* Allocate constructor fun name */
1766 n = newName(con,NIL);
1767 } else if (name(n).defn!=PREDEFINED) {
1768 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1772 name(n).arity = arity; /* Save constructor fun details */
1773 name(n).line = line;
1774 name(n).number = cfunNo(conNo);
1775 name(n).type = type;
1780 static List finishGHCDataDecl ( ConId tyc )
1783 Tycon tc = findTycon(textOf(tyc));
1785 fprintf ( stderr, "begin finishGHCDataDecl %s\n",
1786 textToStr(textOf(tyc)) );
1788 if (isNull(tc)) internal("finishGHCDataDecl");
1790 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1792 Int line = name(n).line;
1793 assert(currentModule == name(n).mod);
1794 name(n).type = conidcellsToTycons(line,name(n).type);
1795 name(n).parent = tc; //---????
1798 return tycon(tc).defn;
1802 /* --------------------------------------------------------------------------
1804 * ------------------------------------------------------------------------*/
1806 static Void startGHCNewType ( Int line, List ctx0,
1807 ConId tycon, List tvs, Cell constr )
1809 /* ctx0 :: [((QConId,VarId))] */
1810 /* tycon :: ConId */
1811 /* tvs :: [((VarId,Kind))] */
1812 /* constr :: ((ConId,Type)) or NIL if abstract */
1815 Text t = textOf(tycon);
1817 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1822 if (nonNull(findTycon(t))) {
1823 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1827 Tycon tc = newTycon(t);
1828 tycon(tc).line = line;
1829 tycon(tc).arity = length(tvs);
1830 tycon(tc).what = NEWTYPE;
1831 tycon(tc).kind = tvsToKind(tvs);
1832 /* can't really do this until I've read in all synonyms */
1834 if (isNull(constr)) {
1835 tycon(tc).defn = NIL;
1837 /* constr :: ((ConId,Type)) */
1838 Text con = textOf(zfst(constr));
1839 Type type = zsnd(constr);
1840 Name n = findName(con); /* Allocate constructor fun name */
1842 n = newName(con,NIL);
1843 } else if (name(n).defn!=PREDEFINED) {
1844 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1848 name(n).arity = 1; /* Save constructor fun details */
1849 name(n).line = line;
1850 name(n).number = cfunNo(0);
1851 name(n).defn = nameId;
1852 tycon(tc).defn = singleton(n);
1854 /* make resTy the result type of the constr, T v1 ... vn */
1856 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1857 resTy = ap(resTy,zfst(hd(tmp)));
1858 type = fn(type,resTy);
1860 type = ap(QUAL,pair(ctx0,type));
1861 type = tvsToOffsets(line,type,tvs);
1862 name(n).type = type;
1868 static Void finishGHCNewType ( ConId tyc )
1870 Tycon tc = findTycon(textOf(tyc));
1872 fprintf ( stderr, "begin finishGHCNewType %s\n",
1873 textToStr(textOf(tyc)) );
1876 if (isNull(tc)) internal("finishGHCNewType");
1878 if (isNull(tycon(tc).defn)) {
1879 /* it's an abstract type */
1881 else if (length(tycon(tc).defn) == 1) {
1882 /* As we expect, has a single constructor */
1883 Name n = hd(tycon(tc).defn);
1884 Int line = name(n).line;
1885 assert(currentModule == name(n).mod);
1886 name(n).type = conidcellsToTycons(line,name(n).type);
1888 internal("finishGHCNewType(2)");
1893 /* --------------------------------------------------------------------------
1894 * Class declarations
1895 * ------------------------------------------------------------------------*/
1897 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1899 List ctxt; /* [((QConId, VarId))] */
1900 ConId tc_name; /* ConId */
1901 List kinded_tvs; /* [((VarId, Kind))] */
1902 List mems0; { /* [((VarId, Type))] */
1904 List mems; /* [((VarId, Type))] */
1905 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1906 List tvs; /* [((VarId,Kind))] */
1907 List ns; /* [Name] */
1910 ZPair kinded_tv = hd(kinded_tvs);
1911 Text ct = textOf(tc_name);
1912 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1914 fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
1918 if (length(kinded_tvs) != 1) {
1919 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1923 if (nonNull(findClass(ct))) {
1924 ERRMSG(line) "Repeated definition of class \"%s\"",
1927 } else if (nonNull(findTycon(ct))) {
1928 ERRMSG(line) "\"%s\" used as both class and type constructor",
1932 Class nw = newClass(ct);
1933 cclass(nw).text = ct;
1934 cclass(nw).line = line;
1935 cclass(nw).arity = 1;
1936 cclass(nw).head = ap(nw,mkOffset(0));
1937 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1938 cclass(nw).instances = NIL;
1939 cclass(nw).numSupers = length(ctxt);
1941 /* Kludge to map the single tyvar in the context to Offset 0.
1942 Need to do something better for multiparam type classes.
1944 cclass(nw).supers = tvsToOffsets(line,ctxt,
1945 singleton(kinded_tv));
1948 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1949 ZPair mem = hd(mems);
1950 Type memT = zsnd(mem);
1951 Text mnt = textOf(zfst(mem));
1954 /* Stick the new context on the member type */
1955 memT = dictapsToQualtype(memT);
1956 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1957 if (whatIs(memT)==QUAL) {
1959 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1962 pair(singleton(newCtx),memT));
1965 /* Cook up a kind for the type. */
1966 tvsInT = ifTyvarsIn(memT);
1967 /* tvsInT :: [VarId] */
1969 /* ToDo: maximally bogus. We allow the class tyvar to
1970 have the kind as supplied by the parser, but we just
1971 assume that all others have kind *. It's a kludge.
1973 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
1975 if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
1976 k = zsnd(kinded_tv); else
1978 hd(tvs) = zpair(hd(tvs),k);
1980 /* tvsIntT :: [((VarId,Kind))] */
1982 memT = mkPolyType(tvsToKind(tvsInT),memT);
1983 memT = tvsToOffsets(line,memT,tvsInT);
1985 /* Park the type back on the member */
1986 mem = zpair(zfst(mem),memT);
1988 /* Bind code to the member */
1992 "Repeated definition for class method \"%s\"",
1996 mn = newName(mnt,NIL);
2001 cclass(nw).members = mems0;
2002 cclass(nw).numMembers = length(mems0);
2005 for (mno=0; mno<cclass(nw).numSupers; mno++) {
2006 ns = cons(newDSel(nw,mno),ns);
2008 cclass(nw).dsels = rev(ns);
2013 static Class finishGHCClass ( Tycon cls_tyc )
2018 Class nw = findClass ( textOf(cls_tyc) );
2020 fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
2022 if (isNull(nw)) internal("finishGHCClass");
2024 line = cclass(nw).line;
2026 assert (currentModule == cclass(nw).mod);
2028 cclass(nw).level = 0;
2029 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
2030 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
2031 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
2033 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2034 Pair mem = hd(mems); /* (VarId, Type) */
2035 Text txt = textOf(fst(mem));
2037 Name n = findName(txt);
2040 name(n).line = cclass(nw).line;
2042 name(n).number = ctr--;
2043 name(n).arity = arityInclDictParams(name(n).type);
2044 name(n).parent = nw;
2052 /* --------------------------------------------------------------------------
2054 * ------------------------------------------------------------------------*/
2056 static Inst startGHCInstance (line,ktyvars,cls,var)
2058 List ktyvars; /* [((VarId,Kind))] */
2059 Type cls; /* Type */
2060 VarId var; { /* VarId */
2061 List tmp, tvs, ks, spec;
2066 Inst in = newInst();
2068 fprintf ( stderr, "begin startGHCInstance\n" );
2073 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2075 The order of tvs is important for tvsToOffsets.
2076 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2077 out of ktyvars and attach them to tvs.
2079 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2081 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2082 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2084 if (isNull(k)) internal("startGHCInstance: finding kinds");
2085 hd(xs1) = zpair(hd(xs1),k);
2088 cls = tvsToOffsets(line,cls,tvs);
2091 spec = cons(fun(cls),spec);
2094 spec = reverse(spec);
2096 inst(in).line = line;
2097 inst(in).implements = NIL;
2098 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2099 inst(in).specifics = spec;
2100 inst(in).numSpecifics = length(spec);
2101 inst(in).head = cls;
2103 /* Figure out the name of the class being instanced, and store it
2104 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2106 Cell cl = inst(in).head;
2107 assert(whatIs(cl)==DICTAP);
2108 cl = unap(DICTAP,cl);
2110 assert ( isQCon(cl) );
2115 Name b = newName( /*inventText()*/ textOf(var),NIL);
2116 name(b).line = line;
2117 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2118 name(b).number = DFUNNAME;
2119 name(b).parent = in;
2120 inst(in).builder = b;
2121 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2128 static Void finishGHCInstance ( Inst in )
2135 fprintf ( stderr, "begin finishGHCInstance\n" );
2138 assert (nonNull(in));
2139 line = inst(in).line;
2140 assert (currentModule==inst(in).mod);
2142 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2143 since startGHCInstance couldn't possibly have resolved it to
2144 a Class at that point. We convert it to a Class now.
2148 c = findQualClassWithoutConsultingExportList(c);
2152 inst(in).head = conidcellsToTycons(line,inst(in).head);
2153 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2154 cclass(c).instances = cons(in,cclass(c).instances);
2158 /* --------------------------------------------------------------------------
2160 * ------------------------------------------------------------------------*/
2162 /* This is called from the startGHC* functions. It traverses a structure
2163 and converts varidcells, ie, type variables parsed by the interface
2164 parser, into Offsets, which is how Hugs wants to see them internally.
2165 The Offset for a type variable is determined by its place in the list
2166 passed as the second arg; the associated kinds are irrelevant.
2168 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2171 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2172 static Type tvsToOffsets(line,type,ktyvars)
2175 List ktyvars; { /* [((VarId,Kind))] */
2176 switch (whatIs(type)) {
2183 case ZTUP2: /* convert to the untyped representation */
2184 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2185 tvsToOffsets(line,zsnd(type),ktyvars) );
2187 return ap( tvsToOffsets(line,fun(type),ktyvars),
2188 tvsToOffsets(line,arg(type),ktyvars) );
2192 tvsToOffsets(line,monotypeOf(type),ktyvars)
2196 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2197 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2198 case DICTAP: /* bogus ?? */
2199 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2200 case UNBOXEDTUP: /* bogus?? */
2201 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2202 case BANG: /* bogus?? */
2203 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2204 case VARIDCELL: /* Ha! some real work to do! */
2206 Text tv = textOf(type);
2207 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2210 assert(isZPair(hd(ktyvars)));
2211 varid = zfst(hd(ktyvars));
2213 if (tv == tt) return mkOffset(i);
2215 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2220 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2222 fprintf(stderr,"\n");
2226 return NIL; /* NOTREACHED */
2230 /* This is called from the finishGHC* functions. It traverses a structure
2231 and converts conidcells, ie, type constructors parsed by the interface
2232 parser, into Tycons (or Classes), which is how Hugs wants to see them
2233 internally. Calls to this fn have to be deferred to the second phase
2234 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2235 Tycons or Classes have been loaded into the symbol tables and can be
2238 static Type conidcellsToTycons ( Int line, Type type )
2240 switch (whatIs(type)) {
2250 { Cell t; /* Tycon or Class */
2251 Text m = qmodOf(type);
2252 Module mod = findModule(m);
2255 "Undefined module in qualified name \"%s\"",
2260 t = findQualTyconWithoutConsultingExportList(type);
2261 if (nonNull(t)) return t;
2262 t = findQualClassWithoutConsultingExportList(type);
2263 if (nonNull(t)) return t;
2265 "Undefined qualified class or type \"%s\"",
2273 cl = findQualClass(type);
2274 if (nonNull(cl)) return cl;
2275 if (textOf(type)==findText("[]"))
2276 /* a hack; magically qualify [] into PrelBase.[] */
2277 return conidcellsToTycons(line,
2278 mkQualId(mkCon(findText("PrelBase")),type));
2279 tc = findQualTycon(type);
2280 if (nonNull(tc)) return tc;
2282 "Undefined class or type constructor \"%s\"",
2288 return ap( conidcellsToTycons(line,fun(type)),
2289 conidcellsToTycons(line,arg(type)) );
2290 case ZTUP2: /* convert to std pair */
2291 return ap( conidcellsToTycons(line,zfst(type)),
2292 conidcellsToTycons(line,zsnd(type)) );
2297 conidcellsToTycons(line,monotypeOf(type))
2301 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2302 conidcellsToTycons(line,snd(snd(type)))));
2303 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2304 Not sure if this is really the right place to
2305 convert it to the form Hugs wants, but will do so anyway.
2307 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2309 Class cl = fst(unap(DICTAP,type));
2310 List args = snd(unap(DICTAP,type));
2312 conidcellsToTycons(line,pair(cl,args));
2315 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2317 return ap(BANG, conidcellsToTycons(line, snd(type)));
2319 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2322 fprintf(stderr,"\n");
2326 return NIL; /* NOTREACHED */
2330 /* Find out if a type mentions a type constructor not present in
2331 the supplied list of qualified tycons.
2333 static Bool allTypesKnown ( Type type,
2334 List aktys /* [QualId] */,
2337 switch (whatIs(type)) {
2344 return allTypesKnown(fun(type),aktys,thisMod)
2345 && allTypesKnown(arg(type),aktys,thisMod);
2347 return allTypesKnown(zfst(type),aktys,thisMod)
2348 && allTypesKnown(zsnd(type),aktys,thisMod);
2350 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2353 if (textOf(type)==findText("[]"))
2354 /* a hack; magically qualify [] into PrelBase.[] */
2355 type = mkQualId(mkCon(findText("PrelBase")),type); else
2356 type = mkQualId(thisMod,type);
2359 if (isNull(qualidIsMember(type,aktys))) goto missing;
2365 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2366 print(type,10);printf("\n");
2367 internal("allTypesKnown");
2368 return TRUE; /*notreached*/
2372 fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
2373 fprintf(stderr,"\n");
2379 /* --------------------------------------------------------------------------
2382 * None of these do lookups or require that lookups have been resolved
2383 * so they can be performed while reading interfaces.
2384 * ------------------------------------------------------------------------*/
2386 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2387 static Kinds tvsToKind(tvs)
2388 List tvs; { /* [((VarId,Kind))] */
2391 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2392 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2393 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2394 r = ap(zsnd(hd(rs)),r);
2400 static Int arityInclDictParams ( Type type )
2403 if (isPolyType(type)) type = monotypeOf(type);
2405 if (whatIs(type) == QUAL)
2407 arity += length ( fst(snd(type)) );
2408 type = snd(snd(type));
2410 while (isAp(type) && getHead(type)==typeArrow) {
2417 /* arity of a constructor with this type */
2418 static Int arityFromType(type)
2421 if (isPolyType(type)) {
2422 type = monotypeOf(type);
2424 if (whatIs(type) == QUAL) {
2425 type = snd(snd(type));
2427 if (whatIs(type) == EXIST) {
2428 type = snd(snd(type));
2430 if (whatIs(type)==RANK2) {
2431 type = snd(snd(type));
2433 while (isAp(type) && getHead(type)==typeArrow) {
2441 /* ifTyvarsIn :: Type -> [VarId]
2442 The returned list has no duplicates -- is a set.
2444 static List ifTyvarsIn(type)
2446 List vs = typeVarsIn(type,NIL,NIL,NIL);
2448 for (; nonNull(vs2); vs2=tl(vs2))
2449 if (whatIs(hd(vs2)) != VARIDCELL)
2450 internal("ifTyvarsIn");
2456 /* --------------------------------------------------------------------------
2457 * General object symbol query stuff
2458 * ------------------------------------------------------------------------*/
2460 #define EXTERN_SYMS_ALLPLATFORMS \
2462 Sym(stg_gc_enter_1) \
2463 Sym(stg_gc_noregs) \
2471 Sym(stg_update_PAP) \
2472 Sym(stg_error_entry) \
2473 Sym(__ap_2_upd_info) \
2474 Sym(__ap_3_upd_info) \
2475 Sym(__ap_4_upd_info) \
2476 Sym(__ap_5_upd_info) \
2477 Sym(__ap_6_upd_info) \
2478 Sym(__ap_7_upd_info) \
2479 Sym(__ap_8_upd_info) \
2480 Sym(__sel_0_upd_info) \
2481 Sym(__sel_1_upd_info) \
2482 Sym(__sel_2_upd_info) \
2483 Sym(__sel_3_upd_info) \
2484 Sym(__sel_4_upd_info) \
2485 Sym(__sel_5_upd_info) \
2486 Sym(__sel_6_upd_info) \
2487 Sym(__sel_7_upd_info) \
2488 Sym(__sel_8_upd_info) \
2489 Sym(__sel_9_upd_info) \
2490 Sym(__sel_10_upd_info) \
2491 Sym(__sel_11_upd_info) \
2492 Sym(__sel_12_upd_info) \
2493 Sym(Upd_frame_info) \
2494 Sym(seq_frame_info) \
2495 Sym(CAF_BLACKHOLE_info) \
2496 Sym(IND_STATIC_info) \
2497 Sym(EMPTY_MVAR_info) \
2498 Sym(MUT_ARR_PTRS_FROZEN_info) \
2500 Sym(putMVarzh_fast) \
2501 Sym(newMVarzh_fast) \
2502 Sym(takeMVarzh_fast) \
2507 Sym(killThreadzh_fast) \
2508 Sym(waitReadzh_fast) \
2509 Sym(waitWritezh_fast) \
2510 Sym(CHARLIKE_closure) \
2511 Sym(INTLIKE_closure) \
2512 Sym(suspendThread) \
2514 Sym(stackOverflow) \
2515 Sym(int2Integerzh_fast) \
2516 Sym(stg_gc_unbx_r1) \
2518 Sym(makeForeignObjzh_fast) \
2519 Sym(__encodeDouble) \
2520 Sym(decodeDoublezh_fast) \
2522 Sym(isDoubleInfinite) \
2523 Sym(isDoubleDenormalized) \
2524 Sym(isDoubleNegativeZero) \
2525 Sym(__encodeFloat) \
2526 Sym(decodeFloatzh_fast) \
2528 Sym(isFloatInfinite) \
2529 Sym(isFloatDenormalized) \
2530 Sym(isFloatNegativeZero) \
2531 Sym(__int_encodeFloat) \
2532 Sym(__int_encodeDouble) \
2536 Sym(gcdIntegerzh_fast) \
2537 Sym(newArrayzh_fast) \
2538 Sym(unsafeThawArrayzh_fast) \
2539 Sym(newDoubleArrayzh_fast) \
2540 Sym(newFloatArrayzh_fast) \
2541 Sym(newAddrArrayzh_fast) \
2542 Sym(newWordArrayzh_fast) \
2543 Sym(newIntArrayzh_fast) \
2544 Sym(newCharArrayzh_fast) \
2545 Sym(newMutVarzh_fast) \
2546 Sym(quotRemIntegerzh_fast) \
2547 Sym(quotIntegerzh_fast) \
2548 Sym(remIntegerzh_fast) \
2549 Sym(divExactIntegerzh_fast) \
2550 Sym(divModIntegerzh_fast) \
2551 Sym(timesIntegerzh_fast) \
2552 Sym(minusIntegerzh_fast) \
2553 Sym(plusIntegerzh_fast) \
2554 Sym(addr2Integerzh_fast) \
2555 Sym(mkWeakzh_fast) \
2558 Sym(resetNonBlockingFd) \
2560 Sym(stable_ptr_table) \
2561 Sym(createAdjThunk) \
2562 Sym(shutdownHaskellAndExit) \
2563 Sym(stg_enterStackTop) \
2564 Sym(CAF_UNENTERED_entry) \
2565 Sym(stg_yield_to_Hugs) \
2569 /* needed by libHS_cbits */ \
2603 #define EXTERN_SYMS_cygwin32 \
2604 SymX(GetCurrentProcess) \
2605 SymX(GetProcessTimes) \
2614 Sym(__imp__tzname) \
2615 Sym(__imp__timezone) \
2634 #define EXTERN_SYMS_linux \
2635 Sym(__errno_location) \
2652 #if defined(linux_TARGET_OS)
2653 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
2656 #if defined(solaris2_TARGET_OS)
2657 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
2660 #if defined(cygwin32_TARGET_OS)
2661 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
2667 /* entirely bogus claims about types of these symbols */
2668 #define Sym(vvv) extern void (vvv);
2669 #define SymX(vvv) /**/
2670 EXTERN_SYMS_ALLPLATFORMS
2671 EXTERN_SYMS_THISPLATFORM
2676 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2678 #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2682 EXTERN_SYMS_ALLPLATFORMS
2683 EXTERN_SYMS_THISPLATFORM
2693 /* A kludge to assist Win32 debugging. */
2694 char* nameFromStaticOPtr ( void* ptr )
2697 for (k = 0; rtsTab[k].nm; k++)
2698 if (ptr == rtsTab[k].ad)
2699 return rtsTab[k].nm;
2704 void* lookupObjName ( char* nm )
2712 int first_real_char;
2715 strncpy(nm2,nm,200);
2717 /* first see if it's an RTS name */
2718 for (k = 0; rtsTab[k].nm; k++)
2719 if (0==strcmp(nm2,rtsTab[k].nm))
2720 return rtsTab[k].ad;
2722 /* perhaps an extra-symbol ? */
2723 a = lookupOExtraTabName ( nm );
2726 # if LEADING_UNDERSCORE
2727 first_real_char = 1;
2729 first_real_char = 0;
2732 /* Maybe it's an __init_Module thing? */
2733 if (strlen(nm2+first_real_char) > 7
2734 && strncmp(nm2+first_real_char, "__init_", 7)==0) {
2735 t = unZcodeThenFindText(nm2+first_real_char+7);
2736 if (t == findText("PrelGHC")) return (4+NULL); /* kludge */
2738 if (isNull(m)) goto not_found;
2739 a = lookupOTabName ( m, nm );
2744 /* if not an RTS name, look in the
2745 relevant module's object symbol table
2747 pp = strchr(nm2+first_real_char, '_');
2748 if (!pp || !isupper(nm2[first_real_char])) goto not_found;
2750 t = unZcodeThenFindText(nm2+first_real_char);
2752 if (isNull(m)) goto not_found;
2754 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2759 "lookupObjName: can't resolve name `%s'\n",
2766 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2768 OSectionKind sk = lookupSection(p);
2769 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2770 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2774 int is_dynamically_loaded_rwdata_ptr ( char* p )
2776 OSectionKind sk = lookupSection(p);
2777 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2778 return (sk == HUGS_SECTIONKIND_RWDATA);
2782 int is_not_dynamically_loaded_ptr ( char* p )
2784 OSectionKind sk = lookupSection(p);
2785 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2786 return (sk == HUGS_SECTIONKIND_OTHER);
2790 /* --------------------------------------------------------------------------
2792 * ------------------------------------------------------------------------*/
2794 Void interface(what)
2797 case POSTPREL: break;
2801 ifaces_outstanding = NIL;
2804 mark(ifaces_outstanding);
2809 /*-------------------------------------------------------------------------*/