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/02/08 17:50:46 $
12 * ------------------------------------------------------------------------*/
20 #include "Assembler.h" /* for wrapping GHC objects */
27 extern void print ( Cell, Int );
29 /* --------------------------------------------------------------------------
30 * (This comment is now out of date. JRS, 991216).
31 * The "addGHC*" functions act as "impedence matchers" between GHC
32 * interface files and Hugs. Their main job is to convert abstract
33 * syntax trees into Hugs' internal representations.
35 * The main trick here is how we deal with mutually recursive interface
38 * o As we read an import decl, we add it to a list of required imports
39 * (unless it's already loaded, of course).
41 * o Processing of declarations is split into two phases:
43 * 1) While reading the interface files, we construct all the Names,
44 * Tycons, etc declared in the interface file but we don't try to
45 * resolve references to any entities the declaration mentions.
47 * This is done by the "addGHC*" functions.
49 * 2) After reading all the interface files, we finish processing the
50 * declarations by resolving any references in the declarations
51 * and doing any other processing that may be required.
53 * This is done by the "finishGHC*" functions which use the
54 * "fixup*" functions to assist them.
56 * The interface between these two phases are the "ghc*Decls" which
57 * contain lists of decls that haven't been completed yet.
59 * ------------------------------------------------------------------------*/
63 New comment, 991216, explaining roughly how it all works.
64 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
66 Interfaces can contain references to unboxed types, and these need to
67 be handled carefully. The following is a summary of how the interface
68 loader now works. It is applied to groups of interfaces simultaneously,
69 viz, the entire Prelude at once:
71 0. Parse interfaces, chasing imports until a complete
72 strongly-connected-component of ifaces has been parsed.
73 All interfaces in this scc are processed together, in
76 1. Throw away any entity not mentioned in the export lists.
78 2. Delete type (not data or newtype) definitions which refer to
79 unknown types in their right hand sides. Because Hugs doesn't
80 know of any unboxed types, this has the side effect of removing
81 all type defns referring to unboxed types. Repeat step 2 until
82 a fixed point is reached.
84 3. Make abstract all data/newtype defns which refer to an unknown
85 type. eg, data Word = MkW Word# becomes data Word, because
86 Word# is unknown. Hugs is happy to know about abstract boxed
87 Words, but not about Word#s.
89 4. Step 2 could delete types referred to by values, instances and
90 classes. So filter all entities, and delete those referring to
91 unknown types _or_ classes. This could cause other entities
92 to become invalid, so iterate step 4 to a fixed point.
94 After step 4, the interfaces no longer contain anything
97 5. Steps 1-4 operate purely on the iface syntax trees. We now start
98 creating symbol table entries. First, create a module table
99 entry for each interface, and locate and read in the corresponding
100 object file. This is done by the startGHCModule function.
102 6. Traverse all interfaces. For each entity, create an entry in
103 the name, tycon, class or instance table, and fill in relevant
104 fields, but do not attempt to link tycon/class/instance/name uses
105 to their symbol table entries. This is done by the startGHC*
108 7. Revisit all symbol table entries created in step 6. We should
109 now be able to replace all references to tycons/classes/instances/
110 names with the relevant symbol table entries. This is done by
111 the finishGHC* functions.
113 8. Traverse all interfaces. For each iface, examine the export lists
114 and use it to build export lists in the module table. Do the
115 implicit 'import Prelude' thing if necessary. Finally, resolve
116 references in the object code for this module. This is done
117 by the finishGHCModule function.
120 /* --------------------------------------------------------------------------
121 * local function prototypes:
122 * ------------------------------------------------------------------------*/
124 static Void startGHCValue Args((Int,VarId,Type));
125 static Void finishGHCValue Args((VarId));
127 static Void startGHCSynonym Args((Int,Cell,List,Type));
128 static Void finishGHCSynonym Args((Tycon));
130 static Void startGHCClass Args((Int,List,Cell,List,List));
131 static Class finishGHCClass Args((Class));
133 static Inst startGHCInstance Args((Int,List,Pair,VarId));
134 static Void finishGHCInstance Args((Inst));
136 static Void startGHCImports Args((ConId,List));
137 static Void finishGHCImports Args((ConId,List));
139 static Void startGHCExports Args((ConId,List));
140 static Void finishGHCExports Args((ConId,List));
142 static Void finishGHCModule Args((Cell));
143 static Void startGHCModule Args((Text, Int, Text));
145 static Void startGHCDataDecl Args((Int,List,Cell,List,List));
146 static List finishGHCDataDecl ( ConId tyc );
148 static Void startGHCNewType Args((Int,List,Cell,List,Cell));
149 static Void finishGHCNewType ( ConId tyc );
152 /* Supporting stuff for {start|finish}GHCDataDecl */
153 static List startGHCConstrs Args((Int,List,List));
154 static Name startGHCSel Args((Int,Pair));
155 static Name startGHCConstr Args((Int,Int,Triple));
159 static Kinds tvsToKind Args((List));
160 static Int arityFromType Args((Type));
161 static Int arityInclDictParams Args((Type));
162 static Bool allTypesKnown ( Type type, List aktys /* [QualId] */, ConId thisMod );
164 static List ifTyvarsIn Args((Type));
166 static Type tvsToOffsets Args((Int,Type,List));
167 static Type conidcellsToTycons Args((Int,Type));
169 static void* lookupObjName ( char* );
175 /* --------------------------------------------------------------------------
176 * Top-level interface processing
177 * ------------------------------------------------------------------------*/
179 /* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
180 static ConVarId getIEntityName ( Cell c )
183 case I_IMPORT: return NIL;
184 case I_INSTIMPORT: return NIL;
185 case I_EXPORT: return NIL;
186 case I_FIXDECL: return zthd3(unap(I_FIXDECL,c));
187 case I_INSTANCE: return NIL;
188 case I_TYPE: return zsel24(unap(I_TYPE,c));
189 case I_DATA: return zsel35(unap(I_DATA,c));
190 case I_NEWTYPE: return zsel35(unap(I_NEWTYPE,c));
191 case I_CLASS: return zsel35(unap(I_CLASS,c));
192 case I_VALUE: return zsnd3(unap(I_VALUE,c));
193 default: internal("getIEntityName");
198 /* Filter the contents of an interface, using the supplied predicate.
199 For flexibility, the predicate is passed as a second arg the value
200 extraArgs. This is a hack to get round the lack of partial applications
201 in C. Pred should not have any side effects. The dumpaction param
202 gives us the chance to print a message or some such for dumped items.
203 When a named entity is deleted, filterInterface also deletes the name
206 static Cell filterInterface ( Cell root,
207 Bool (*pred)(Cell,Cell),
209 Void (*dumpAction)(Cell) )
212 Cell iface = unap(I_INTERFACE,root);
214 List deleted_ids = NIL; /* :: [ConVarId] */
216 for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
217 if (pred(hd(tops),extraArgs)) {
218 tops2 = cons( hd(tops), tops2 );
220 ConVarId deleted_id = getIEntityName ( hd(tops) );
221 if (nonNull(deleted_id))
222 deleted_ids = cons ( deleted_id, deleted_ids );
224 dumpAction ( hd(tops) );
227 tops2 = reverse(tops2);
229 /* Clean up the export list now. */
230 for (tops=tops2; nonNull(tops); tops=tl(tops)) {
231 if (whatIs(hd(tops))==I_EXPORT) {
232 Cell exdecl = unap(I_EXPORT,hd(tops));
233 List exlist = zsnd(exdecl);
235 for (; nonNull(exlist); exlist=tl(exlist)) {
236 Cell ex = hd(exlist);
237 ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
238 assert (isCon(exid) || isVar(exid));
239 if (!varIsMember(textOf(exid),deleted_ids))
240 exlist2 = cons(ex, exlist2);
242 hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
246 return ap(I_INTERFACE, zpair(zfst(iface),tops2));
250 ZPair readInterface(String fname, Long fileSize)
254 ZPair iface = parseInterface(fname,fileSize);
255 assert (whatIs(iface)==I_INTERFACE);
257 for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
258 if (whatIs(hd(tops)) == I_IMPORT) {
259 ZPair imp_decl = unap(I_IMPORT,hd(tops));
260 ConId m_to_imp = zfst(imp_decl);
261 if (textOf(m_to_imp) != findText("PrelGHC")) {
262 imports = cons(m_to_imp,imports);
263 /* fprintf(stderr, "add iface %s\n", textToStr(textOf(m_to_imp))); */
266 return zpair(iface,imports);
270 /* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
271 static List getExportDeclsInIFace ( Cell root )
273 Cell iface = unap(I_INTERFACE,root);
274 List decls = zsnd(iface);
277 for (ds=decls; nonNull(ds); ds=tl(ds))
278 if (whatIs(hd(ds))==I_EXPORT)
279 exports = cons(hd(ds), exports);
284 /* Does t start with "$dm" ? */
285 static Bool isIfaceDefaultMethodName ( Text t )
287 String s = textToStr(t);
288 return (s && s[0]=='$' && s[1]=='d' && s[2]=='m' && s[3]);
292 static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
294 /* ife :: I_IMPORT..I_VALUE */
295 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
301 ConVarId ife_id = getIEntityName ( ife );
303 if (isNull(ife_id)) return TRUE;
305 tnm = textOf(ife_id);
307 /* Don't junk default methods, even tho the export list doesn't
310 if (isIfaceDefaultMethodName(tnm)) goto retain;
312 /* for each export list ... */
313 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
314 exlist = hd(exlist_list);
316 /* for each entity in an export list ... */
317 for (t=exlist; nonNull(t); t=tl(t)) {
318 if (isZPair(hd(t))) {
319 /* A pair, which means an export entry
320 of the form ClassName(foo,bar). */
321 List subents = cons(zfst(hd(t)),zsnd(hd(t)));
322 for (; nonNull(subents); subents=tl(subents))
323 if (textOf(hd(subents)) == tnm) goto retain;
325 /* Single name in the list. */
326 if (textOf(hd(t)) == tnm) goto retain;
331 fprintf ( stderr, " dump %s\n", textToStr(tnm) );
335 fprintf ( stderr, " retain %s\n", textToStr(tnm) );
340 static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
342 /* ife_id :: ConId */
343 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
348 assert (isCon(ife_id));
349 tnm = textOf(ife_id);
351 /* for each export list ... */
352 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
353 exlist = hd(exlist_list);
355 /* for each entity in an export list ... */
356 for (t=exlist; nonNull(t); t=tl(t)) {
357 if (isZPair(hd(t))) {
358 /* A pair, which means an export entry
359 of the form ClassName(foo,bar). */
360 if (textOf(zfst(hd(t))) == tnm) return FALSE;
362 if (textOf(hd(t)) == tnm) return TRUE;
366 internal("isExportedAbstractly");
367 return FALSE; /*notreached*/
371 /* Remove entities not mentioned in any of the export lists. */
372 static Cell deleteUnexportedIFaceEntities ( Cell root )
374 Cell iface = unap(I_INTERFACE,root);
375 ConId iname = zfst(iface);
376 List decls = zsnd(iface);
378 List exlist_list = NIL;
381 fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
383 exlist_list = getExportDeclsInIFace ( root );
384 /* exlist_list :: [I_EXPORT] */
386 for (t=exlist_list; nonNull(t); t=tl(t))
387 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
388 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
390 if (isNull(exlist_list)) {
391 ERRMSG(0) "Can't find any export lists in interface file"
395 return filterInterface ( root, isExportedIFaceEntity,
400 /* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
401 static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
403 Cell iface = unap(I_INTERFACE,root);
404 Text mname = textOf(zfst(iface));
405 List defns = zsnd(iface);
406 for (; nonNull(defns); defns = tl(defns)) {
407 Cell defn = hd(defns);
408 Cell what = whatIs(defn);
409 if (what==I_TYPE || what==I_DATA
410 || what==I_NEWTYPE || what==I_CLASS) {
411 QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
412 if (!qualidIsMember ( q, aktys ))
413 aktys = cons ( q, aktys );
420 static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
422 ConVarId id = getIEntityName ( entity );
424 "dumping %s because of unknown type(s)\n",
425 isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
429 /* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
430 /* mod is the current module being processed -- so we can qualify unqual'd
431 names. Strange calling convention for aktys and mod is so we can call this
432 from filterInterface.
434 static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
437 List aktys = zfst ( aktys_mod );
438 ConId mod = zsnd ( aktys_mod );
439 switch (whatIs(entity)) {
446 Cell inst = unap(I_INSTANCE,entity);
447 List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
448 Type cls = zsel35 ( inst ); /* :: Type */
449 for (t = ctx; nonNull(t); t=tl(t))
450 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
451 if (!allTypesKnown(cls, aktys,mod)) return FALSE;
455 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
457 Cell data = unap(I_DATA,entity);
458 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
459 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
460 for (t = ctx; nonNull(t); t=tl(t))
461 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
462 for (t = constrs; nonNull(t); t=tl(t))
463 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
464 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
468 Cell newty = unap(I_NEWTYPE,entity);
469 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
470 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
471 for (t = ctx; nonNull(t); t=tl(t))
472 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
474 && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
478 Cell klass = unap(I_CLASS,entity);
479 List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
480 List sigs = zsel55(klass); /* :: [((VarId,Type))] */
481 for (t = ctx; nonNull(t); t=tl(t))
482 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
483 for (t = sigs; nonNull(t); t=tl(t))
484 if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
488 return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
490 internal("ifentityAllTypesKnown");
495 /* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
496 /* mod is the current module being processed -- so we can qualify unqual'd
497 names. Strange calling convention for aktys and mod is so we can call this
498 from filterInterface.
500 static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
503 List aktys = zfst ( aktys_mod );
504 ConId mod = zsnd ( aktys_mod );
505 if (whatIs(entity) != I_TYPE) {
508 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
513 static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
515 ConVarId id = getIEntityName ( entity );
516 assert (whatIs(entity)==I_TYPE);
519 "dumping type %s because of unknown tycon(s)\n",
520 textToStr(textOf(id)) );
524 /* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
526 static List abstractifyExDecl ( Cell root, ConId toabs )
528 ZPair exdecl = unap(I_EXPORT,root);
529 List exlist = zsnd(exdecl);
531 for (; nonNull(exlist); exlist = tl(exlist)) {
532 if (isZPair(hd(exlist))
533 && textOf(toabs) == textOf(zfst(hd(exlist)))) {
534 /* it's toabs, exported non-abstractly */
535 res = cons ( zfst(hd(exlist)), res );
537 res = cons ( hd(exlist), res );
540 return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
544 static Void ppModule ( Text modt )
546 fflush(stderr); fflush(stdout);
547 fprintf(stderr, "---------------- MODULE %s ----------------\n",
552 static void* ifFindItblFor ( Name n )
554 /* n is a constructor for which we want to find the GHC info table.
555 First look for a _con_info symbol. If that doesn't exist, _and_
556 this is a nullary constructor, then it's safe to look for the
557 _static_info symbol instead.
563 sprintf ( buf, "%s_%s_con_info",
564 textToStr( module(name(n).mod).text ),
565 textToStr( name(n).text ) );
566 t = enZcodeThenFindText(buf);
567 p = lookupOTabName ( name(n).mod, textToStr(t) );
571 if (name(n).arity == 0) {
572 sprintf ( buf, "%s_%s_static_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 ERRMSG(0) "Can't find info table %s", textToStr(t)
585 void ifLinkConstrItbl ( Name n )
587 /* name(n) is either a constructor or a field name.
588 If the latter, ignore it. If it is a non-nullary constructor,
589 find its info table in the object code. If it's nullary,
590 we can skip the info table, since all accesses will go via
593 if (islower(textToStr(name(n).text)[0])) return;
594 if (name(n).arity == 0) return;
595 name(n).itbl = ifFindItblFor(n);
599 static void ifSetClassDefaultsAndDCon ( Class c )
607 List defs; /* :: [Name] */
608 List mems; /* :: [Name] */
610 assert(isNull(cclass(c).defaults));
612 /* Create the defaults list by more-or-less cloning the members list. */
614 for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
616 s = textToStr( name(hd(mems)).text );
617 assert(strlen(s) < 95);
619 n = findNameInAnyModule(findText(buf));
624 cclass(c).defaults = defs;
626 /* Create a name table entry for the dictionary datacon.
627 Interface files don't mention them, so it had better not
631 s = textToStr( cclass(c).text );
632 assert( strlen(s) < 96 );
635 n = findNameInAnyModule(t);
641 name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
642 name(n).number = cfunNo(0);
645 /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
646 Because this happens right at the end of loading, we know
647 that we should actually be able to find the symbol in this
648 module's object symbol table. Except that if the dictionary
649 has arity 1, we don't bother, since it will be represented as
650 a newtype and not as a data, so its itbl can remain NULL.
652 if (name(n).arity == 1) {
654 name(n).defn = nameId;
656 p = ifFindItblFor ( n );
662 /* ifaces_outstanding holds a list of parsed interfaces
663 for which we need to load objects and create symbol
666 Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
668 Bool processInterfaces ( void )
679 List all_known_types;
682 List cls_list; /* :: List Class */
683 List constructor_list; /* :: List Name */
685 List ifaces = NIL; /* :: List I_INTERFACE */
686 List iface_sizes = NIL; /* :: List Int */
687 List iface_onames = NIL; /* :: List Text */
689 if (isNull(ifaces_outstanding)) return FALSE;
692 "processInterfaces: %d interfaces to process\n",
693 length(ifaces_outstanding) );
695 /* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
696 for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
697 ifaces = cons ( zfst3(hd(xs)), ifaces );
698 iface_onames = cons ( zsnd3(hd(xs)), iface_onames );
699 iface_sizes = cons ( zthd3(hd(xs)), iface_sizes );
702 ifaces = reverse(ifaces);
703 iface_onames = reverse(iface_onames);
704 iface_sizes = reverse(iface_sizes);
706 /* Clean up interfaces -- dump non-exported value, class, type decls */
707 for (xs = ifaces; nonNull(xs); xs = tl(xs))
708 hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
711 /* Iteratively delete any type declarations which refer to unknown
714 num_known_types = 999999999;
718 /* Construct a list of all known tycons. This is a list of QualIds.
719 Unfortunately it also has to contain all known class names, since
720 allTypesKnown cannot distinguish between tycons and classes -- a
721 deficiency of the iface abs syntax.
723 all_known_types = getAllKnownTyconsAndClasses();
724 for (xs = ifaces; nonNull(xs); xs=tl(xs))
725 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
727 /* Have we reached a fixed point? */
728 i = length(all_known_types);
729 printf ( "\n============= %d known types =============\n", i );
730 if (num_known_types == i) break;
733 /* Delete all entities which refer to unknown tycons. */
734 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
735 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
736 assert(nonNull(mod));
737 hd(xs) = filterInterface ( hd(xs),
738 ifTypeDoesntRefUnknownTycon,
739 zpair(all_known_types,mod),
740 ifTypeDoesntRefUnknownTycon_dumpmsg );
744 /* Now abstractify any datas and newtypes which refer to unknown tycons
745 -- including, of course, the type decls just deleted.
747 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
748 List absify = NIL; /* :: [ConId] */
749 ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
750 ConId mod = zfst(iface);
751 List aktys = all_known_types; /* just a renaming */
755 /* Compute into absify the list of all ConIds (tycons) we need to
758 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
760 Bool allKnown = TRUE;
762 if (whatIs(ent)==I_DATA) {
763 Cell data = unap(I_DATA,ent);
764 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
765 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
766 for (t = ctx; nonNull(t); t=tl(t))
767 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
768 for (t = constrs; nonNull(t); t=tl(t))
769 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
770 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
772 else if (whatIs(ent)==I_NEWTYPE) {
773 Cell newty = unap(I_NEWTYPE,ent);
774 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
775 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
776 for (t = ctx; nonNull(t); t=tl(t))
777 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
778 if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
782 absify = cons ( getIEntityName(ent), absify );
784 "abstractifying %s because it uses an unknown type\n",
785 textToStr(textOf(getIEntityName(ent))) );
789 /* mark in exports as abstract all names in absify (modifies iface) */
790 for (; nonNull(absify); absify=tl(absify)) {
791 ConId toAbs = hd(absify);
792 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
793 if (whatIs(hd(es)) != I_EXPORT) continue;
794 hd(es) = abstractifyExDecl ( hd(es), toAbs );
798 /* For each data/newtype in the export list marked as abstract,
799 remove the constructor lists. This catches all abstractification
800 caused by the code above, and it also catches tycons which really
801 were exported abstractly.
804 exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
805 /* exlist_list :: [I_EXPORT] */
806 for (t=exlist_list; nonNull(t); t=tl(t))
807 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
808 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
810 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
812 if (whatIs(ent)==I_DATA
813 && isExportedAbstractly ( getIEntityName(ent),
815 Cell data = unap(I_DATA,ent);
816 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
817 zsel45(data), NIL /* the constr list */ );
818 hd(es) = ap(I_DATA,data);
819 fprintf(stderr, "abstractify data %s\n", textToStr(textOf(getIEntityName(ent))) );
821 else if (whatIs(ent)==I_NEWTYPE
822 && isExportedAbstractly ( getIEntityName(ent),
824 Cell data = unap(I_NEWTYPE,ent);
825 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
826 zsel45(data), NIL /* the constr-type pair */ );
827 hd(es) = ap(I_NEWTYPE,data);
828 fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent))) );
832 /* We've finally finished mashing this iface. Update the iface list. */
833 hd(xs) = ap(I_INTERFACE,iface);
837 /* At this point, the interfaces are cleaned up so that no type, data or
838 newtype defn refers to a non-existant type. However, there still may
839 be value defns, classes and instances which refer to unknown types.
840 Delete iteratively until a fixed point is reached.
844 num_known_types = 999999999;
848 /* Construct a list of all known tycons. This is a list of QualIds.
849 Unfortunately it also has to contain all known class names, since
850 allTypesKnown cannot distinguish between tycons and classes -- a
851 deficiency of the iface abs syntax.
853 all_known_types = getAllKnownTyconsAndClasses();
854 for (xs = ifaces; nonNull(xs); xs=tl(xs))
855 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
857 /* Have we reached a fixed point? */
858 i = length(all_known_types);
859 printf ( "\n------------- %d known types -------------\n", i );
860 if (num_known_types == i) break;
863 /* Delete all entities which refer to unknown tycons. */
864 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
865 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
866 assert(nonNull(mod));
868 hd(xs) = filterInterface ( hd(xs),
869 ifentityAllTypesKnown,
870 zpair(all_known_types,mod),
871 ifentityAllTypesKnown_dumpmsg );
876 /* Allocate module table entries and read in object code. */
879 xs=tl(xs), iface_sizes=tl(iface_sizes), iface_onames=tl(iface_onames)) {
880 startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))),
881 intOf(hd(iface_sizes)),
884 assert (isNull(iface_sizes));
885 assert (isNull(iface_onames));
888 /* Now work through the decl lists of the modules, and call the
889 startGHC* functions on the entities. This creates names in
890 various tables but doesn't bind them to anything.
893 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
894 iface = unap(I_INTERFACE,hd(xs));
895 mname = textOf(zfst(iface));
896 mod = findModule(mname);
897 if (isNull(mod)) internal("processInterfaces(4)");
899 ppModule ( module(mod).text );
901 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
902 Cell decl = hd(decls);
903 switch(whatIs(decl)) {
905 Cell exdecl = unap(I_EXPORT,decl);
906 startGHCExports ( zfst(exdecl), zsnd(exdecl) );
910 Cell imdecl = unap(I_IMPORT,decl);
911 startGHCImports ( zfst(imdecl), zsnd(imdecl) );
918 /* Trying to find the instance table location allocated by
919 startGHCInstance in subsequent processing is a nightmare, so
920 cache it on the tree.
922 Cell instance = unap(I_INSTANCE,decl);
923 Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
924 zsel35(instance), zsel45(instance) );
925 hd(decls) = ap(I_INSTANCE,
926 z5ble( zsel15(instance), zsel25(instance),
927 zsel35(instance), zsel45(instance), in ));
931 Cell tydecl = unap(I_TYPE,decl);
932 startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
933 zsel34(tydecl), zsel44(tydecl) );
937 Cell ddecl = unap(I_DATA,decl);
938 startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
939 zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
943 Cell ntdecl = unap(I_NEWTYPE,decl);
944 startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
945 zsel35(ntdecl), zsel45(ntdecl),
950 Cell klass = unap(I_CLASS,decl);
951 startGHCClass ( zsel15(klass), zsel25(klass),
952 zsel35(klass), zsel45(klass),
957 Cell value = unap(I_VALUE,decl);
958 startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
962 internal("processInterfaces(1)");
967 fprintf(stderr, "\n=========================================================\n");
968 fprintf(stderr, "=========================================================\n");
970 /* Traverse again the decl lists of the modules, this time
971 calling the finishGHC* functions. But don't process
972 the export lists; those must wait for later.
976 constructor_list = NIL;
977 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
978 iface = unap(I_INTERFACE,hd(xs));
979 mname = textOf(zfst(iface));
980 mod = findModule(mname);
981 if (isNull(mod)) internal("processInterfaces(3)");
983 ppModule ( module(mod).text );
985 if (mname == textPrelude) didPrelude = TRUE;
987 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
988 Cell decl = hd(decls);
989 switch(whatIs(decl)) {
1000 Cell instance = unap(I_INSTANCE,decl);
1001 finishGHCInstance ( zsel55(instance) );
1005 Cell tydecl = unap(I_TYPE,decl);
1006 finishGHCSynonym ( zsel24(tydecl) );
1010 Cell ddecl = unap(I_DATA,decl);
1011 List constrs = finishGHCDataDecl ( zsel35(ddecl) );
1012 constructor_list = appendOnto ( constrs, constructor_list );
1016 Cell ntdecl = unap(I_NEWTYPE,decl);
1017 finishGHCNewType ( zsel35(ntdecl) );
1021 Cell klass = unap(I_CLASS,decl);
1022 Class cls = finishGHCClass ( zsel35(klass) );
1023 cls_list = cons(cls,cls_list);
1027 Cell value = unap(I_VALUE,decl);
1028 finishGHCValue ( zsnd3(value) );
1032 internal("processInterfaces(2)");
1036 fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
1037 fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
1039 /* Build the module(m).export lists for each module, by running
1040 through the export lists in the iface. Also, do the implicit
1041 'import Prelude' thing. And finally, do the object code
1044 for (xs = ifaces; nonNull(xs); xs = tl(xs))
1045 finishGHCModule(hd(xs));
1047 mapProc(visitClass,cls_list);
1048 mapProc(ifSetClassDefaultsAndDCon,cls_list);
1049 mapProc(ifLinkConstrItbl,constructor_list);
1052 ifaces_outstanding = NIL;
1058 /* --------------------------------------------------------------------------
1060 * ------------------------------------------------------------------------*/
1062 static void startGHCModule_errMsg ( char* msg )
1064 fprintf ( stderr, "object error: %s\n", msg );
1067 static void* startGHCModule_clientLookup ( char* sym )
1069 /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
1070 return lookupObjName ( sym );
1073 static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
1076 = ocNew ( startGHCModule_errMsg,
1077 startGHCModule_clientLookup,
1081 ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
1084 if (!ocLoadImage(oc,VERBOSE)) {
1085 ERRMSG(0) "Reading of object file \"%s\" failed", objNm
1088 if (!ocVerifyImage(oc,VERBOSE)) {
1089 ERRMSG(0) "Validation of object file \"%s\" failed", objNm
1092 if (!ocGetNames(oc,0||VERBOSE)) {
1093 ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
1099 static Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
1102 Module m = findModule(mname);
1105 m = newModule(mname);
1106 fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
1107 textToStr(mname), sizeObj );
1109 if (module(m).fake) {
1110 module(m).fake = FALSE;
1112 ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
1117 /* Get hold of the primary object for the module. */
1119 = startGHCModule_partial_load ( textToStr(nameObj), sizeObj );
1121 /* and any extras ... */
1122 for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
1126 String nm = getExtraObjectInfo ( textToStr(nameObj),
1130 ERRMSG(0) "Can't find extra object file \"%s\"", nm
1133 oc = startGHCModule_partial_load ( nm, size );
1134 oc->next = module(m).objectExtras;
1135 module(m).objectExtras = oc;
1140 /* For the module mod, augment both the export environment (.exports)
1141 and the eval environment (.names, .tycons, .classes)
1142 with the symbols mentioned in exlist. We don't actually need
1143 to modify the names, tycons, classes or instances in the eval
1144 environment, since previous processing of the
1145 top-level decls in the iface should have done this already.
1147 mn is the module mentioned in the export list; it is the "original"
1148 module for the symbols in the export list. We should also record
1149 this info with the symbols, since references to object code need to
1150 refer to the original module in which a symbol was defined, rather
1151 than to some module it has been imported into and then re-exported.
1153 We take the policy that if something mentioned in an export list
1154 can't be found in the symbol tables, it is simply ignored. After all,
1155 previous processing of the iface syntax trees has already removed
1156 everything which Hugs can't handle, so if there is mention of these
1157 things still lurking in export lists somewhere, about the only thing
1158 to do is to ignore it.
1160 Also do an implicit 'import Prelude' thingy for the module,
1165 static Void finishGHCModule ( Cell root )
1167 /* root :: I_INTERFACE */
1168 Cell iface = unap(I_INTERFACE,root);
1169 ConId iname = zfst(iface);
1170 Module mod = findModule(textOf(iname));
1171 List exlist_list = NIL;
1175 fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1177 if (isNull(mod)) internal("finishExports(1)");
1180 exlist_list = getExportDeclsInIFace ( root );
1181 /* exlist_list :: [I_EXPORT] */
1183 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1184 ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
1185 ConId exmod = zfst(exdecl);
1186 List exlist = zsnd(exdecl);
1187 /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1189 for (; nonNull(exlist); exlist=tl(exlist)) {
1194 Cell ex = hd(exlist);
1196 switch (whatIs(ex)) {
1198 case VARIDCELL: /* variable */
1199 q = mkQualId(exmod,ex);
1200 c = findQualNameWithoutConsultingExportList ( q );
1201 if (isNull(c)) goto notfound;
1202 fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
1203 module(mod).exports = cons(c, module(mod).exports);
1207 case CONIDCELL: /* non data tycon */
1208 q = mkQualId(exmod,ex);
1209 c = findQualTyconWithoutConsultingExportList ( q );
1210 if (isNull(c)) goto notfound;
1211 fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
1212 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1216 case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
1217 subents = zsnd(ex); /* :: [ConVarId] */
1218 ex = zfst(ex); /* :: ConId */
1219 q = mkQualId(exmod,ex);
1220 c = findQualTyconWithoutConsultingExportList ( q );
1222 if (nonNull(c)) { /* data */
1223 fprintf(stderr, " data/newtype %s = { ", textToStr(textOf(ex)) );
1224 assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1225 abstract = isNull(tycon(c).defn);
1226 /* This data/newtype could be abstract even tho the export list
1227 says to export it non-abstractly. That happens if it was
1228 imported from some other module and is now being re-exported,
1229 and previous cleanup phases have abstractified it in the
1230 original (defining) module.
1233 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1235 fprintf ( stderr, "(abstract) ");
1237 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1239 for (; nonNull(subents); subents = tl(subents)) {
1240 Cell ent2 = hd(subents);
1241 assert(isCon(ent2) || isVar(ent2));
1242 /* isVar since could be a field name */
1243 q = mkQualId(exmod,ent2);
1244 c = findQualNameWithoutConsultingExportList ( q );
1245 fprintf(stderr, "%s ", textToStr(name(c).text));
1247 /* module(mod).exports = cons(c, module(mod).exports); */
1251 fprintf(stderr, "}\n" );
1252 } else { /* class */
1253 q = mkQualId(exmod,ex);
1254 c = findQualClassWithoutConsultingExportList ( q );
1255 if (isNull(c)) goto notfound;
1256 fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
1257 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1259 for (; nonNull(subents); subents = tl(subents)) {
1260 Cell ent2 = hd(subents);
1261 assert(isVar(ent2));
1262 q = mkQualId(exmod,ent2);
1263 c = findQualNameWithoutConsultingExportList ( q );
1264 fprintf(stderr, "%s ", textToStr(name(c).text));
1265 if (isNull(c)) goto notfound;
1266 /* module(mod).exports = cons(c, module(mod).exports); */
1269 fprintf(stderr, "}\n" );
1274 internal("finishExports(2)");
1277 continue; /* so notfound: can be placed after this */
1280 /* q holds what ain't found */
1281 assert(whatIs(q)==QUALIDENT);
1282 fprintf( stderr, " ------ IGNORED: %s.%s\n",
1283 textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1289 if (preludeLoaded) {
1290 /* do the implicit 'import Prelude' thing */
1291 List pxs = module(modulePrelude).exports;
1292 for (; nonNull(pxs); pxs=tl(pxs)) {
1295 switch (whatIs(px)) {
1300 module(mod).names = cons ( px, module(mod).names );
1303 module(mod).tycons = cons ( px, module(mod).tycons );
1306 module(mod).classes = cons ( px, module(mod).classes );
1309 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1310 internal("finishGHCModule -- implicit import Prelude");
1317 /* Last, but by no means least ... */
1318 if (!ocResolve(module(mod).object,0||VERBOSE))
1319 internal("finishGHCModule: object resolution failed");
1321 for (oc=module(mod).objectExtras; oc; oc=oc->next) {
1322 if (!ocResolve(oc, 0||VERBOSE))
1323 internal("finishGHCModule: extra object resolution failed");
1328 /* --------------------------------------------------------------------------
1330 * ------------------------------------------------------------------------*/
1332 static Void startGHCExports ( ConId mn, List exlist )
1335 printf("startGHCExports %s\n", textToStr(textOf(mn)) );
1337 /* Nothing to do. */
1340 static Void finishGHCExports ( ConId mn, List exlist )
1343 printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
1345 /* Nothing to do. */
1349 /* --------------------------------------------------------------------------
1351 * ------------------------------------------------------------------------*/
1353 static Void startGHCImports ( ConId mn, List syms )
1354 /* nm the module to import from */
1355 /* syms [ConId | VarId] -- the names to import */
1358 printf("startGHCImports %s\n", textToStr(textOf(mn)) );
1360 /* Nothing to do. */
1364 static Void finishGHCImports ( ConId nm, List syms )
1365 /* nm the module to import from */
1366 /* syms [ConId | VarId] -- the names to import */
1369 printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
1371 /* Nothing to do. */
1375 /* --------------------------------------------------------------------------
1377 * ------------------------------------------------------------------------*/
1379 /* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
1380 { C1 a } -> { C2 b } -> T into
1381 ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
1383 static Type dictapsToQualtype ( Type ty )
1386 List preds, dictaps;
1388 /* break ty into pieces at the top-level arrows */
1389 while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
1390 pieces = cons ( arg(fun(ty)), pieces );
1393 pieces = cons ( ty, pieces );
1394 pieces = reverse ( pieces );
1397 while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
1398 dictaps = cons ( hd(pieces), dictaps );
1399 pieces = tl(pieces);
1402 /* dictaps holds the predicates, backwards */
1403 /* pieces holds the remainder of the type, forwards */
1404 assert(nonNull(pieces));
1405 pieces = reverse(pieces);
1407 pieces = tl(pieces);
1408 for (; nonNull(pieces); pieces=tl(pieces))
1409 ty = fn(hd(pieces),ty);
1412 for (; nonNull(dictaps); dictaps=tl(dictaps)) {
1413 Cell da = hd(dictaps);
1414 QualId cl = fst(unap(DICTAP,da));
1415 Cell arg = snd(unap(DICTAP,da));
1416 preds = cons ( pair(cl,arg), preds );
1419 if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
1425 static void startGHCValue ( Int line, VarId vid, Type ty )
1429 Text v = textOf(vid);
1432 printf("begin startGHCValue %s\n", textToStr(v));
1437 if (nonNull(n) && name(n).defn != PREDEFINED) {
1438 ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
1441 if (isNull(n)) n = newName(v,NIL);
1443 ty = dictapsToQualtype(ty);
1445 tvs = ifTyvarsIn(ty);
1446 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1447 hd(tmp) = zpair(hd(tmp),STAR);
1449 ty = mkPolyType(tvsToKind(tvs),ty);
1451 ty = tvsToOffsets(line,ty,tvs);
1453 name(n).arity = arityInclDictParams(ty);
1454 name(n).line = line;
1459 static void finishGHCValue ( VarId vid )
1461 Name n = findName ( textOf(vid) );
1462 Int line = name(n).line;
1464 fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1466 assert(currentModule == name(n).mod);
1467 name(n).type = conidcellsToTycons(line,name(n).type);
1469 if (isIfaceDefaultMethodName(name(n).text)) {
1470 /* ... we need to set .parent to point to the class
1471 ... once we figure out what the class actually is :-)
1473 Type t = name(n).type;
1474 assert(isPolyType(t));
1475 if (isPolyType(t)) t = monotypeOf(t);
1476 assert(isQualType(t));
1477 t = fst(snd(t)); /* t :: [(Class,Offset)] */
1479 assert(nonNull(hd(t)));
1480 assert(isPair(hd(t)));
1481 t = fst(hd(t)); /* t :: Class */
1484 name(n).parent = t; /* phew! */
1489 /* --------------------------------------------------------------------------
1491 * ------------------------------------------------------------------------*/
1493 static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1495 /* tycon :: ConId */
1496 /* tvs :: [((VarId,Kind))] */
1498 Text t = textOf(tycon);
1500 fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1503 if (nonNull(findTycon(t))) {
1504 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1508 Tycon tc = newTycon(t);
1509 tycon(tc).line = line;
1510 tycon(tc).arity = length(tvs);
1511 tycon(tc).what = SYNONYM;
1512 tycon(tc).kind = tvsToKind(tvs);
1514 /* prepare for finishGHCSynonym */
1515 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
1520 static Void finishGHCSynonym ( ConId tyc )
1522 Tycon tc = findTycon(textOf(tyc));
1523 Int line = tycon(tc).line;
1525 fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1528 assert (currentModule == tycon(tc).mod);
1529 // setCurrModule(tycon(tc).mod);
1530 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1532 /* (ADR) ToDo: can't really do this until I've done all synonyms
1533 * and then I have to do them in order
1534 * tycon(tc).defn = fullExpand(ty);
1535 * (JRS) What?!?! i don't understand
1540 /* --------------------------------------------------------------------------
1542 * ------------------------------------------------------------------------*/
1544 static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1546 List ctx0; /* [((QConId,VarId))] */
1547 Cell tycon; /* ConId */
1548 List ktyvars; /* [((VarId,Kind))] */
1549 List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
1550 /* The Text is an optional field name
1551 The Int indicates strictness */
1552 /* ToDo: worry about being given a decl for (->) ?
1553 * and worry about qualidents for ()
1556 Type ty, resTy, selTy, conArgTy;
1557 List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
1561 Pair conArg, ctxElem;
1563 Int conArgStrictness;
1565 Text t = textOf(tycon);
1567 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1571 if (nonNull(findTycon(t))) {
1572 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1576 Tycon tc = newTycon(t);
1578 tycon(tc).line = line;
1579 tycon(tc).arity = length(ktyvars);
1580 tycon(tc).kind = tvsToKind(ktyvars);
1581 tycon(tc).what = DATATYPE;
1583 /* a list to accumulate selectors in :: [((VarId,Type))] */
1586 /* make resTy the result type of the constr, T v1 ... vn */
1588 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1589 resTy = ap(resTy,zfst(hd(tmp)));
1591 /* for each constructor ... */
1592 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1593 constr = hd(constrs);
1594 conid = zfst(constr);
1595 fields = zsnd(constr);
1597 /* Build type of constr and handle any selectors found.
1598 Also collect up tyvars occurring in the constr's arg
1599 types, so we can throw away irrelevant parts of the
1603 tyvarsMentioned = NIL;
1604 /* tyvarsMentioned :: [VarId] */
1606 conArgs = reverse(fields);
1607 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1608 conArg = hd(conArgs); /* (Type,Text) */
1609 conArgTy = zfst3(conArg);
1610 conArgNm = zsnd3(conArg);
1611 conArgStrictness = intOf(zthd3(conArg));
1612 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1614 if (conArgStrictness > 0) conArgTy = bang(conArgTy);
1615 ty = fn(conArgTy,ty);
1616 if (nonNull(conArgNm)) {
1617 /* a field name is mentioned too */
1618 selTy = fn(resTy,conArgTy);
1619 if (whatIs(tycon(tc).kind) != STAR)
1620 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1621 selTy = tvsToOffsets(line,selTy, ktyvars);
1622 sels = cons( zpair(conArgNm,selTy), sels);
1626 /* Now ty is the constructor's type, not including context.
1627 Throw away any parts of the context not mentioned in
1628 tyvarsMentioned, and use it to qualify ty.
1631 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1633 /* ctxElem :: ((QConId,VarId)) */
1634 if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1635 ctx2 = cons(ctxElem, ctx2);
1638 ty = ap(QUAL,pair(ctx2,ty));
1640 /* stick the tycon's kind on, if not simply STAR */
1641 if (whatIs(tycon(tc).kind) != STAR)
1642 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1644 ty = tvsToOffsets(line,ty, ktyvars);
1646 /* Finally, stick the constructor's type onto it. */
1647 hd(constrs) = ztriple(conid,fields,ty);
1650 /* Final result is that
1651 constrs :: [((ConId,[((Type,Text))],Type))]
1652 lists the constructors and their types
1653 sels :: [((VarId,Type))]
1654 lists the selectors and their types
1656 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1661 static List startGHCConstrs ( Int line, List cons, List sels )
1663 /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1664 /* sels :: [((VarId,Type))] */
1665 /* returns [Name] */
1667 Int conNo = length(cons)>1 ? 1 : 0;
1668 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1669 Name c = startGHCConstr(line,conNo,hd(cs));
1672 /* cons :: [Name] */
1674 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1675 hd(ss) = startGHCSel(line,hd(ss));
1677 /* sels :: [Name] */
1678 return appendOnto(cons,sels);
1682 static Name startGHCSel ( Int line, ZPair sel )
1684 /* sel :: ((VarId, Type)) */
1685 Text t = textOf(zfst(sel));
1686 Type type = zsnd(sel);
1688 Name n = findName(t);
1690 ERRMSG(line) "Repeated definition for selector \"%s\"",
1696 name(n).line = line;
1697 name(n).number = SELNAME;
1700 name(n).type = type;
1705 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1707 /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1708 /* (ADR) ToDo: add rank2 annotation and existential annotation
1709 * these affect how constr can be used.
1711 Text con = textOf(zfst3(constr));
1712 Type type = zthd3(constr);
1713 Int arity = arityFromType(type);
1714 Name n = findName(con); /* Allocate constructor fun name */
1716 n = newName(con,NIL);
1717 } else if (name(n).defn!=PREDEFINED) {
1718 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1722 name(n).arity = arity; /* Save constructor fun details */
1723 name(n).line = line;
1724 name(n).number = cfunNo(conNo);
1725 name(n).type = type;
1730 static List finishGHCDataDecl ( ConId tyc )
1733 Tycon tc = findTycon(textOf(tyc));
1735 printf ( "begin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
1737 if (isNull(tc)) internal("finishGHCDataDecl");
1739 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1741 Int line = name(n).line;
1742 assert(currentModule == name(n).mod);
1743 name(n).type = conidcellsToTycons(line,name(n).type);
1744 name(n).parent = tc; //---????
1747 return tycon(tc).defn;
1751 /* --------------------------------------------------------------------------
1753 * ------------------------------------------------------------------------*/
1755 static Void startGHCNewType ( Int line, List ctx0,
1756 ConId tycon, List tvs, Cell constr )
1758 /* ctx0 :: [((QConId,VarId))] */
1759 /* tycon :: ConId */
1760 /* tvs :: [((VarId,Kind))] */
1761 /* constr :: ((ConId,Type)) or NIL if abstract */
1764 Text t = textOf(tycon);
1766 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1771 if (nonNull(findTycon(t))) {
1772 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1776 Tycon tc = newTycon(t);
1777 tycon(tc).line = line;
1778 tycon(tc).arity = length(tvs);
1779 tycon(tc).what = NEWTYPE;
1780 tycon(tc).kind = tvsToKind(tvs);
1781 /* can't really do this until I've read in all synonyms */
1783 if (isNull(constr)) {
1784 tycon(tc).defn = NIL;
1786 /* constr :: ((ConId,Type)) */
1787 Text con = textOf(zfst(constr));
1788 Type type = zsnd(constr);
1789 Name n = findName(con); /* Allocate constructor fun name */
1791 n = newName(con,NIL);
1792 } else if (name(n).defn!=PREDEFINED) {
1793 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1797 name(n).arity = 1; /* Save constructor fun details */
1798 name(n).line = line;
1799 name(n).number = cfunNo(0);
1800 name(n).defn = nameId;
1801 tycon(tc).defn = singleton(n);
1803 /* make resTy the result type of the constr, T v1 ... vn */
1805 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1806 resTy = ap(resTy,zfst(hd(tmp)));
1807 type = fn(type,resTy);
1809 type = ap(QUAL,pair(ctx0,type));
1810 type = tvsToOffsets(line,type,tvs);
1811 name(n).type = type;
1817 static Void finishGHCNewType ( ConId tyc )
1819 Tycon tc = findTycon(textOf(tyc));
1821 printf ( "begin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
1824 if (isNull(tc)) internal("finishGHCNewType");
1826 if (isNull(tycon(tc).defn)) {
1827 /* it's an abstract type */
1829 else if (length(tycon(tc).defn) == 1) {
1830 /* As we expect, has a single constructor */
1831 Name n = hd(tycon(tc).defn);
1832 Int line = name(n).line;
1833 assert(currentModule == name(n).mod);
1834 name(n).type = conidcellsToTycons(line,name(n).type);
1836 internal("finishGHCNewType(2)");
1841 /* --------------------------------------------------------------------------
1842 * Class declarations
1843 * ------------------------------------------------------------------------*/
1845 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1847 List ctxt; /* [((QConId, VarId))] */
1848 ConId tc_name; /* ConId */
1849 List kinded_tvs; /* [((VarId, Kind))] */
1850 List mems0; { /* [((VarId, Type))] */
1852 List mems; /* [((VarId, Type))] */
1853 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1854 List tvs; /* [((VarId,Kind))] */
1855 List ns; /* [Name] */
1858 ZPair kinded_tv = hd(kinded_tvs);
1859 Text ct = textOf(tc_name);
1860 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1862 printf ( "begin startGHCClass %s\n", textToStr(ct) );
1866 if (length(kinded_tvs) != 1) {
1867 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1871 if (nonNull(findClass(ct))) {
1872 ERRMSG(line) "Repeated definition of class \"%s\"",
1875 } else if (nonNull(findTycon(ct))) {
1876 ERRMSG(line) "\"%s\" used as both class and type constructor",
1880 Class nw = newClass(ct);
1881 cclass(nw).text = ct;
1882 cclass(nw).line = line;
1883 cclass(nw).arity = 1;
1884 cclass(nw).head = ap(nw,mkOffset(0));
1885 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1886 cclass(nw).instances = NIL;
1887 cclass(nw).numSupers = length(ctxt);
1891 /* Kludge to map the single tyvar in the context to Offset 0.
1892 Need to do something better for multiparam type classes.
1894 cclass(nw).supers = tvsToOffsets(line,ctxt,
1895 singleton(pair(tv,STAR)));
1897 cclass(nw).supers = tvsToOffsets(line,ctxt,
1898 singleton(kinded_tv));
1901 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1902 ZPair mem = hd(mems);
1903 Type memT = zsnd(mem);
1904 Text mnt = textOf(zfst(mem));
1907 /* Stick the new context on the member type */
1908 memT = dictapsToQualtype(memT);
1909 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1910 if (whatIs(memT)==QUAL) {
1912 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1915 pair(singleton(newCtx),memT));
1918 /* Cook up a kind for the type. */
1919 tvsInT = ifTyvarsIn(memT);
1920 /* tvsInT :: [VarId] */
1922 /* ToDo: maximally bogus */
1923 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
1924 hd(tvs) = zpair(hd(tvs),STAR);
1925 /* tvsIntT :: [((VarId,STAR))] */
1927 memT = mkPolyType(tvsToKind(tvsInT),memT);
1928 memT = tvsToOffsets(line,memT,tvsInT);
1930 /* Park the type back on the member */
1931 mem = zpair(zfst(mem),memT);
1933 /* Bind code to the member */
1937 "Repeated definition for class method \"%s\"",
1941 mn = newName(mnt,NIL);
1946 cclass(nw).members = mems0;
1947 cclass(nw).numMembers = length(mems0);
1950 * cclass(nw).dsels = ?;
1951 * cclass(nm).defaults = ?;
1955 for (mno=0; mno<cclass(nw).numSupers; mno++) {
1956 ns = cons(newDSel(nw,mno),ns);
1958 cclass(nw).dsels = rev(ns);
1963 static Class finishGHCClass ( Tycon cls_tyc )
1968 Class nw = findClass ( textOf(cls_tyc) );
1970 printf ( "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
1972 if (isNull(nw)) internal("finishGHCClass");
1974 line = cclass(nw).line;
1976 assert (currentModule == cclass(nw).mod);
1978 cclass(nw).level = 0;
1979 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
1980 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
1981 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
1983 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
1984 Pair mem = hd(mems); /* (VarId, Type) */
1985 Text txt = textOf(fst(mem));
1987 Name n = findName(txt);
1990 name(n).line = cclass(nw).line;
1992 name(n).number = ctr--;
1993 name(n).arity = arityInclDictParams(name(n).type);
1994 name(n).parent = nw;
2002 /* --------------------------------------------------------------------------
2004 * ------------------------------------------------------------------------*/
2006 static Inst startGHCInstance (line,ktyvars,cls,var)
2008 List ktyvars; /* [((VarId,Kind))] */
2009 Type cls; /* Type */
2010 VarId var; { /* VarId */
2011 List tmp, tvs, ks, spec;
2016 Inst in = newInst();
2018 printf ( "begin startGHCInstance\n" );
2023 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2025 The order of tvs is important for tvsToOffsets.
2026 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2027 out of ktyvars and attach them to tvs.
2029 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2031 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2032 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2034 if (isNull(k)) internal("startGHCInstance: finding kinds");
2035 hd(xs1) = zpair(hd(xs1),k);
2038 cls = tvsToOffsets(line,cls,tvs);
2041 spec = cons(fun(cls),spec);
2044 spec = reverse(spec);
2046 inst(in).line = line;
2047 inst(in).implements = NIL;
2048 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2049 inst(in).specifics = spec;
2050 inst(in).numSpecifics = length(spec);
2051 inst(in).head = cls;
2053 /* Figure out the name of the class being instanced, and store it
2054 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2056 Cell cl = inst(in).head;
2057 assert(whatIs(cl)==DICTAP);
2058 cl = unap(DICTAP,cl);
2060 assert ( isQCon(cl) );
2065 Name b = newName( /*inventText()*/ textOf(var),NIL);
2066 name(b).line = line;
2067 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2068 name(b).number = DFUNNAME;
2069 name(b).parent = in;
2070 inst(in).builder = b;
2071 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2078 static Void finishGHCInstance ( Inst in )
2085 printf ( "begin finishGHCInstance\n" );
2088 assert (nonNull(in));
2089 line = inst(in).line;
2090 assert (currentModule==inst(in).mod);
2092 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2093 since startGHCInstance couldn't possibly have resolved it to
2094 a Class at that point. We convert it to a Class now.
2098 c = findQualClassWithoutConsultingExportList(c);
2102 inst(in).head = conidcellsToTycons(line,inst(in).head);
2103 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2104 cclass(c).instances = cons(in,cclass(c).instances);
2108 /* --------------------------------------------------------------------------
2110 * ------------------------------------------------------------------------*/
2112 /* This is called from the startGHC* functions. It traverses a structure
2113 and converts varidcells, ie, type variables parsed by the interface
2114 parser, into Offsets, which is how Hugs wants to see them internally.
2115 The Offset for a type variable is determined by its place in the list
2116 passed as the second arg; the associated kinds are irrelevant.
2118 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2121 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2122 static Type tvsToOffsets(line,type,ktyvars)
2125 List ktyvars; { /* [((VarId,Kind))] */
2126 switch (whatIs(type)) {
2133 case ZTUP2: /* convert to the untyped representation */
2134 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2135 tvsToOffsets(line,zsnd(type),ktyvars) );
2137 return ap( tvsToOffsets(line,fun(type),ktyvars),
2138 tvsToOffsets(line,arg(type),ktyvars) );
2142 tvsToOffsets(line,monotypeOf(type),ktyvars)
2146 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2147 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2148 case DICTAP: /* bogus ?? */
2149 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2150 case UNBOXEDTUP: /* bogus?? */
2151 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2152 case BANG: /* bogus?? */
2153 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2154 case VARIDCELL: /* Ha! some real work to do! */
2156 Text tv = textOf(type);
2157 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2160 assert(isZPair(hd(ktyvars)));
2161 varid = zfst(hd(ktyvars));
2163 if (tv == tt) return mkOffset(i);
2165 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2170 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2172 fprintf(stderr,"\n");
2176 return NIL; /* NOTREACHED */
2180 /* This is called from the finishGHC* functions. It traverses a structure
2181 and converts conidcells, ie, type constructors parsed by the interface
2182 parser, into Tycons (or Classes), which is how Hugs wants to see them
2183 internally. Calls to this fn have to be deferred to the second phase
2184 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2185 Tycons or Classes have been loaded into the symbol tables and can be
2188 static Type conidcellsToTycons ( Int line, Type type )
2190 switch (whatIs(type)) {
2200 { Cell t; /* Tycon or Class */
2201 Text m = qmodOf(type);
2202 Module mod = findModule(m);
2205 "Undefined module in qualified name \"%s\"",
2210 t = findQualTyconWithoutConsultingExportList(type);
2211 if (nonNull(t)) return t;
2212 t = findQualClassWithoutConsultingExportList(type);
2213 if (nonNull(t)) return t;
2215 "Undefined qualified class or type \"%s\"",
2223 cl = findQualClass(type);
2224 if (nonNull(cl)) return cl;
2225 if (textOf(type)==findText("[]"))
2226 /* a hack; magically qualify [] into PrelBase.[] */
2227 return conidcellsToTycons(line,
2228 mkQualId(mkCon(findText("PrelBase")),type));
2229 tc = findQualTycon(type);
2230 if (nonNull(tc)) return tc;
2232 "Undefined class or type constructor \"%s\"",
2238 return ap( conidcellsToTycons(line,fun(type)),
2239 conidcellsToTycons(line,arg(type)) );
2240 case ZTUP2: /* convert to std pair */
2241 return ap( conidcellsToTycons(line,zfst(type)),
2242 conidcellsToTycons(line,zsnd(type)) );
2247 conidcellsToTycons(line,monotypeOf(type))
2251 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2252 conidcellsToTycons(line,snd(snd(type)))));
2253 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2254 Not sure if this is really the right place to
2255 convert it to the form Hugs wants, but will do so anyway.
2257 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2259 Class cl = fst(unap(DICTAP,type));
2260 List args = snd(unap(DICTAP,type));
2262 conidcellsToTycons(line,pair(cl,args));
2265 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2267 return ap(BANG, conidcellsToTycons(line, snd(type)));
2269 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2272 fprintf(stderr,"\n");
2276 return NIL; /* NOTREACHED */
2280 /* Find out if a type mentions a type constructor not present in
2281 the supplied list of qualified tycons.
2283 static Bool allTypesKnown ( Type type,
2284 List aktys /* [QualId] */,
2287 switch (whatIs(type)) {
2294 return allTypesKnown(fun(type),aktys,thisMod)
2295 && allTypesKnown(arg(type),aktys,thisMod);
2297 return allTypesKnown(zfst(type),aktys,thisMod)
2298 && allTypesKnown(zsnd(type),aktys,thisMod);
2300 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2303 if (textOf(type)==findText("[]"))
2304 /* a hack; magically qualify [] into PrelBase.[] */
2305 type = mkQualId(mkCon(findText("PrelBase")),type); else
2306 type = mkQualId(thisMod,type);
2309 if (isNull(qualidIsMember(type,aktys))) goto missing;
2315 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2316 print(type,10);printf("\n");
2317 internal("allTypesKnown");
2318 return TRUE; /*notreached*/
2321 printf ( "allTypesKnown: unknown " ); print(type,10); printf("\n");
2326 /* --------------------------------------------------------------------------
2329 * None of these do lookups or require that lookups have been resolved
2330 * so they can be performed while reading interfaces.
2331 * ------------------------------------------------------------------------*/
2333 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2334 static Kinds tvsToKind(tvs)
2335 List tvs; { /* [((VarId,Kind))] */
2338 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2339 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2340 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2341 r = ap(zsnd(hd(rs)),r);
2347 static Int arityInclDictParams ( Type type )
2350 if (isPolyType(type)) type = monotypeOf(type);
2352 if (whatIs(type) == QUAL)
2354 arity += length ( fst(snd(type)) );
2355 type = snd(snd(type));
2357 while (isAp(type) && getHead(type)==typeArrow) {
2364 /* arity of a constructor with this type */
2365 static Int arityFromType(type)
2368 if (isPolyType(type)) {
2369 type = monotypeOf(type);
2371 if (whatIs(type) == QUAL) {
2372 type = snd(snd(type));
2374 if (whatIs(type) == EXIST) {
2375 type = snd(snd(type));
2377 if (whatIs(type)==RANK2) {
2378 type = snd(snd(type));
2380 while (isAp(type) && getHead(type)==typeArrow) {
2388 /* ifTyvarsIn :: Type -> [VarId]
2389 The returned list has no duplicates -- is a set.
2391 static List ifTyvarsIn(type)
2393 List vs = typeVarsIn(type,NIL,NIL,NIL);
2395 for (; nonNull(vs2); vs2=tl(vs2))
2396 if (whatIs(hd(vs2)) != VARIDCELL)
2397 internal("ifTyvarsIn");
2403 /* --------------------------------------------------------------------------
2404 * General object symbol query stuff
2405 * ------------------------------------------------------------------------*/
2407 #define EXTERN_SYMS \
2408 Sym(stg_gc_enter_1) \
2409 Sym(stg_gc_noregs) \
2417 Sym(stg_update_PAP) \
2418 Sym(stg_error_entry) \
2419 Sym(__ap_2_upd_info) \
2420 Sym(__ap_3_upd_info) \
2421 Sym(__ap_4_upd_info) \
2422 Sym(__ap_5_upd_info) \
2423 Sym(__ap_6_upd_info) \
2424 Sym(__sel_0_upd_info) \
2425 Sym(__sel_1_upd_info) \
2426 Sym(__sel_2_upd_info) \
2427 Sym(__sel_3_upd_info) \
2428 Sym(__sel_4_upd_info) \
2429 Sym(__sel_5_upd_info) \
2430 Sym(__sel_6_upd_info) \
2431 Sym(__sel_7_upd_info) \
2432 Sym(__sel_8_upd_info) \
2433 Sym(__sel_9_upd_info) \
2434 Sym(__sel_10_upd_info) \
2435 Sym(__sel_11_upd_info) \
2436 Sym(__sel_12_upd_info) \
2438 Sym(Upd_frame_info) \
2439 Sym(seq_frame_info) \
2440 Sym(CAF_BLACKHOLE_info) \
2441 Sym(IND_STATIC_info) \
2442 Sym(EMPTY_MVAR_info) \
2443 Sym(MUT_ARR_PTRS_FROZEN_info) \
2445 Sym(putMVarzh_fast) \
2446 Sym(newMVarzh_fast) \
2447 Sym(takeMVarzh_fast) \
2452 Sym(killThreadzh_fast) \
2453 Sym(waitReadzh_fast) \
2454 Sym(waitWritezh_fast) \
2455 Sym(CHARLIKE_closure) \
2456 Sym(INTLIKE_closure) \
2457 Sym(suspendThread) \
2459 Sym(stackOverflow) \
2460 Sym(int2Integerzh_fast) \
2461 Sym(stg_gc_unbx_r1) \
2463 Sym(makeForeignObjzh_fast) \
2464 Sym(__encodeDouble) \
2465 Sym(decodeDoublezh_fast) \
2467 Sym(isDoubleInfinite) \
2468 Sym(isDoubleDenormalized) \
2469 Sym(isDoubleNegativeZero) \
2470 Sym(__encodeFloat) \
2471 Sym(decodeFloatzh_fast) \
2473 Sym(isFloatInfinite) \
2474 Sym(isFloatDenormalized) \
2475 Sym(isFloatNegativeZero) \
2476 Sym(__int_encodeFloat) \
2477 Sym(__int_encodeDouble) \
2481 Sym(gcdIntegerzh_fast) \
2482 Sym(newArrayzh_fast) \
2483 Sym(unsafeThawArrayzh_fast) \
2484 Sym(newDoubleArrayzh_fast) \
2485 Sym(newFloatArrayzh_fast) \
2486 Sym(newAddrArrayzh_fast) \
2487 Sym(newWordArrayzh_fast) \
2488 Sym(newIntArrayzh_fast) \
2489 Sym(newCharArrayzh_fast) \
2490 Sym(newMutVarzh_fast) \
2491 Sym(quotRemIntegerzh_fast) \
2492 Sym(quotIntegerzh_fast) \
2493 Sym(remIntegerzh_fast) \
2494 Sym(divExactIntegerzh_fast) \
2495 Sym(divModIntegerzh_fast) \
2496 Sym(timesIntegerzh_fast) \
2497 Sym(minusIntegerzh_fast) \
2498 Sym(plusIntegerzh_fast) \
2499 Sym(addr2Integerzh_fast) \
2500 Sym(mkWeakzh_fast) \
2503 Sym(resetNonBlockingFd) \
2505 /* needed by libHS_cbits */ \
2507 Sym(__errno_location) \
2559 /* entirely bogus claims about types of these symbols */
2560 #define Sym(vvv) extern int vvv;
2561 #define SymX(vvv) /* nothing */
2566 #define Sym(vvv) { #vvv, &vvv },
2567 #define SymX(vvv) { #vvv, &vvv },
2576 static void* lookupObjName ( char* nm )
2586 strncpy(nm2,nm,200);
2588 /* first see if it's an RTS name */
2589 for (k = 0; rtsTab[k].nm; k++)
2590 if (0==strcmp(nm2,rtsTab[k].nm))
2591 return rtsTab[k].ad;
2593 /* perhaps an extra-symbol ? */
2594 a = lookupOExtraTabName ( nm );
2597 /* if not an RTS name, look in the
2598 relevant module's object symbol table
2600 pp = strchr(nm2, '_');
2601 if (!pp || !isupper(nm2[0])) goto not_found;
2603 t = unZcodeThenFindText(nm2);
2605 if (isNull(m)) goto not_found;
2607 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2612 "lookupObjName: can't resolve name `%s'\n",
2619 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2621 OSectionKind sk = lookupSection(p);
2622 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2623 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2627 int is_dynamically_loaded_rwdata_ptr ( char* p )
2629 OSectionKind sk = lookupSection(p);
2630 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2631 return (sk == HUGS_SECTIONKIND_RWDATA);
2635 int is_not_dynamically_loaded_ptr ( char* p )
2637 OSectionKind sk = lookupSection(p);
2638 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2639 return (sk == HUGS_SECTIONKIND_OTHER);
2643 /* --------------------------------------------------------------------------
2645 * ------------------------------------------------------------------------*/
2647 Void interface(what)
2650 case POSTPREL: break;
2654 ifaces_outstanding = NIL;
2657 mark(ifaces_outstanding);
2662 /*-------------------------------------------------------------------------*/