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/08 11:20:53 $
12 * ------------------------------------------------------------------------*/
20 #include "Assembler.h" /* for wrapping GHC objects */
24 /*#define DEBUG_IFACE*/
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 finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
144 static Void finishGHCModule Args((Cell));
145 static Void startGHCModule Args((Text, Int, Text));
147 static Void startGHCDataDecl Args((Int,List,Cell,List,List));
148 static List finishGHCDataDecl ( ConId tyc );
150 static Void startGHCNewType Args((Int,List,Cell,List,Cell));
151 static Void finishGHCNewType ( ConId tyc );
154 /* Supporting stuff for {start|finish}GHCDataDecl */
155 static List startGHCConstrs Args((Int,List,List));
156 static Name startGHCSel Args((Int,Pair));
157 static Name startGHCConstr Args((Int,Int,Triple));
161 static Kinds tvsToKind Args((List));
162 static Int arityFromType Args((Type));
163 static Int arityInclDictParams Args((Type));
164 static Bool allTypesKnown ( Type type, List aktys /* [QualId] */, ConId thisMod );
166 static List ifTyvarsIn Args((Type));
168 static Type tvsToOffsets Args((Int,Type,List));
169 static Type conidcellsToTycons Args((Int,Type));
171 static void* lookupObjName ( char* );
177 /* --------------------------------------------------------------------------
178 * Top-level interface processing
179 * ------------------------------------------------------------------------*/
181 /* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
182 static ConVarId getIEntityName ( Cell c )
185 case I_IMPORT: return NIL;
186 case I_INSTIMPORT: return NIL;
187 case I_EXPORT: return NIL;
188 case I_FIXDECL: return zthd3(unap(I_FIXDECL,c));
189 case I_INSTANCE: return NIL;
190 case I_TYPE: return zsel24(unap(I_TYPE,c));
191 case I_DATA: return zsel35(unap(I_DATA,c));
192 case I_NEWTYPE: return zsel35(unap(I_NEWTYPE,c));
193 case I_CLASS: return zsel35(unap(I_CLASS,c));
194 case I_VALUE: return zsnd3(unap(I_VALUE,c));
195 default: internal("getIEntityName");
200 /* Filter the contents of an interface, using the supplied predicate.
201 For flexibility, the predicate is passed as a second arg the value
202 extraArgs. This is a hack to get round the lack of partial applications
203 in C. Pred should not have any side effects. The dumpaction param
204 gives us the chance to print a message or some such for dumped items.
205 When a named entity is deleted, filterInterface also deletes the name
208 static Cell filterInterface ( Cell root,
209 Bool (*pred)(Cell,Cell),
211 Void (*dumpAction)(Cell) )
214 Cell iface = unap(I_INTERFACE,root);
216 List deleted_ids = NIL; /* :: [ConVarId] */
218 for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
219 if (pred(hd(tops),extraArgs)) {
220 tops2 = cons( hd(tops), tops2 );
222 ConVarId deleted_id = getIEntityName ( hd(tops) );
223 if (nonNull(deleted_id))
224 deleted_ids = cons ( deleted_id, deleted_ids );
226 dumpAction ( hd(tops) );
229 tops2 = reverse(tops2);
231 /* Clean up the export list now. */
232 for (tops=tops2; nonNull(tops); tops=tl(tops)) {
233 if (whatIs(hd(tops))==I_EXPORT) {
234 Cell exdecl = unap(I_EXPORT,hd(tops));
235 List exlist = zsnd(exdecl);
237 for (; nonNull(exlist); exlist=tl(exlist)) {
238 Cell ex = hd(exlist);
239 ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
240 assert (isCon(exid) || isVar(exid));
241 if (!varIsMember(textOf(exid),deleted_ids))
242 exlist2 = cons(ex, exlist2);
244 hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
248 return ap(I_INTERFACE, zpair(zfst(iface),tops2));
252 ZPair readInterface(String fname, Long fileSize)
256 ZPair iface = parseInterface(fname,fileSize);
257 assert (whatIs(iface)==I_INTERFACE);
259 for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
260 if (whatIs(hd(tops)) == I_IMPORT) {
261 ZPair imp_decl = unap(I_IMPORT,hd(tops));
262 ConId m_to_imp = zfst(imp_decl);
263 if (textOf(m_to_imp) != findText("PrelGHC")) {
264 imports = cons(m_to_imp,imports);
266 fprintf(stderr, "add iface %s\n",
267 textToStr(textOf(m_to_imp)));
271 return zpair(iface,imports);
275 /* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
276 static List getExportDeclsInIFace ( Cell root )
278 Cell iface = unap(I_INTERFACE,root);
279 List decls = zsnd(iface);
282 for (ds=decls; nonNull(ds); ds=tl(ds))
283 if (whatIs(hd(ds))==I_EXPORT)
284 exports = cons(hd(ds), exports);
289 /* Does t start with "$dm" ? */
290 static Bool isIfaceDefaultMethodName ( Text t )
292 String s = textToStr(t);
293 return (s && s[0]=='$' && s[1]=='d' && s[2]=='m' && s[3]);
297 static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
299 /* ife :: I_IMPORT..I_VALUE */
300 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
306 ConVarId ife_id = getIEntityName ( ife );
308 if (isNull(ife_id)) return TRUE;
310 tnm = textOf(ife_id);
312 /* Don't junk default methods, even tho the export list doesn't
315 if (isIfaceDefaultMethodName(tnm)) goto retain;
317 /* for each export list ... */
318 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
319 exlist = hd(exlist_list);
321 /* for each entity in an export list ... */
322 for (t=exlist; nonNull(t); t=tl(t)) {
323 if (isZPair(hd(t))) {
324 /* A pair, which means an export entry
325 of the form ClassName(foo,bar). */
326 List subents = cons(zfst(hd(t)),zsnd(hd(t)));
327 for (; nonNull(subents); subents=tl(subents))
328 if (textOf(hd(subents)) == tnm) goto retain;
330 /* Single name in the list. */
331 if (textOf(hd(t)) == tnm) goto retain;
337 fprintf ( stderr, " dump %s\n", textToStr(tnm) );
343 fprintf ( stderr, " retain %s\n", textToStr(tnm) );
349 static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
351 /* ife_id :: ConId */
352 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
357 assert (isCon(ife_id));
358 tnm = textOf(ife_id);
360 /* for each export list ... */
361 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
362 exlist = hd(exlist_list);
364 /* for each entity in an export list ... */
365 for (t=exlist; nonNull(t); t=tl(t)) {
366 if (isZPair(hd(t))) {
367 /* A pair, which means an export entry
368 of the form ClassName(foo,bar). */
369 if (textOf(zfst(hd(t))) == tnm) return FALSE;
371 if (textOf(hd(t)) == tnm) return TRUE;
375 internal("isExportedAbstractly");
376 return FALSE; /*notreached*/
380 /* Remove entities not mentioned in any of the export lists. */
381 static Cell deleteUnexportedIFaceEntities ( Cell root )
383 Cell iface = unap(I_INTERFACE,root);
384 ConId iname = zfst(iface);
385 List decls = zsnd(iface);
387 List exlist_list = NIL;
391 fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
394 exlist_list = getExportDeclsInIFace ( root );
395 /* exlist_list :: [I_EXPORT] */
397 for (t=exlist_list; nonNull(t); t=tl(t))
398 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
399 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
401 if (isNull(exlist_list)) {
402 ERRMSG(0) "Can't find any export lists in interface file"
406 return filterInterface ( root, isExportedIFaceEntity,
411 /* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
412 static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
414 Cell iface = unap(I_INTERFACE,root);
415 Text mname = textOf(zfst(iface));
416 List defns = zsnd(iface);
417 for (; nonNull(defns); defns = tl(defns)) {
418 Cell defn = hd(defns);
419 Cell what = whatIs(defn);
420 if (what==I_TYPE || what==I_DATA
421 || what==I_NEWTYPE || what==I_CLASS) {
422 QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
423 if (!qualidIsMember ( q, aktys ))
424 aktys = cons ( q, aktys );
431 static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
433 ConVarId id = getIEntityName ( entity );
436 "dumping %s because of unknown type(s)\n",
437 isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
442 /* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
443 /* mod is the current module being processed -- so we can qualify unqual'd
444 names. Strange calling convention for aktys and mod is so we can call this
445 from filterInterface.
447 static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
450 List aktys = zfst ( aktys_mod );
451 ConId mod = zsnd ( aktys_mod );
452 switch (whatIs(entity)) {
459 Cell inst = unap(I_INSTANCE,entity);
460 List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
461 Type cls = zsel35 ( inst ); /* :: Type */
462 for (t = ctx; nonNull(t); t=tl(t))
463 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
464 if (!allTypesKnown(cls, aktys,mod)) return FALSE;
468 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
470 Cell data = unap(I_DATA,entity);
471 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
472 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
473 for (t = ctx; nonNull(t); t=tl(t))
474 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
475 for (t = constrs; nonNull(t); t=tl(t))
476 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
477 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
481 Cell newty = unap(I_NEWTYPE,entity);
482 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
483 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
484 for (t = ctx; nonNull(t); t=tl(t))
485 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
487 && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
491 Cell klass = unap(I_CLASS,entity);
492 List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
493 List sigs = zsel55(klass); /* :: [((VarId,Type))] */
494 for (t = ctx; nonNull(t); t=tl(t))
495 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
496 for (t = sigs; nonNull(t); t=tl(t))
497 if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
501 return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
503 internal("ifentityAllTypesKnown");
508 /* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
509 /* mod is the current module being processed -- so we can qualify unqual'd
510 names. Strange calling convention for aktys and mod is so we can call this
511 from filterInterface.
513 static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
516 List aktys = zfst ( aktys_mod );
517 ConId mod = zsnd ( aktys_mod );
518 if (whatIs(entity) != I_TYPE) {
521 return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
526 static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
528 ConVarId id = getIEntityName ( entity );
529 assert (whatIs(entity)==I_TYPE);
533 "dumping type %s because of unknown tycon(s)\n",
534 textToStr(textOf(id)) );
539 /* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
541 static List abstractifyExDecl ( Cell root, ConId toabs )
543 ZPair exdecl = unap(I_EXPORT,root);
544 List exlist = zsnd(exdecl);
546 for (; nonNull(exlist); exlist = tl(exlist)) {
547 if (isZPair(hd(exlist))
548 && textOf(toabs) == textOf(zfst(hd(exlist)))) {
549 /* it's toabs, exported non-abstractly */
550 res = cons ( zfst(hd(exlist)), res );
552 res = cons ( hd(exlist), res );
555 return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
559 static Void ppModule ( Text modt )
562 fflush(stderr); fflush(stdout);
563 fprintf(stderr, "---------------- MODULE %s ----------------\n",
569 static void* ifFindItblFor ( Name n )
571 /* n is a constructor for which we want to find the GHC info table.
572 First look for a _con_info symbol. If that doesn't exist, _and_
573 this is a nullary constructor, then it's safe to look for the
574 _static_info symbol instead.
580 sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_info"),
581 textToStr( module(name(n).mod).text ),
582 textToStr( name(n).text ) );
583 t = enZcodeThenFindText(buf);
584 p = lookupOTabName ( name(n).mod, textToStr(t) );
588 if (name(n).arity == 0) {
589 sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"),
590 textToStr( module(name(n).mod).text ),
591 textToStr( name(n).text ) );
592 t = enZcodeThenFindText(buf);
593 p = lookupOTabName ( name(n).mod, textToStr(t) );
597 ERRMSG(0) "Can't find info table %s", textToStr(t)
602 void ifLinkConstrItbl ( Name n )
604 /* name(n) is either a constructor or a field name.
605 If the latter, ignore it. If it is a non-nullary constructor,
606 find its info table in the object code. If it's nullary,
607 we can skip the info table, since all accesses will go via
610 if (islower(textToStr(name(n).text)[0])) return;
611 if (name(n).arity == 0) return;
612 name(n).itbl = ifFindItblFor(n);
616 static void ifSetClassDefaultsAndDCon ( Class c )
624 List defs; /* :: [Name] */
625 List mems; /* :: [Name] */
627 assert(isNull(cclass(c).defaults));
629 /* Create the defaults list by more-or-less cloning the members list. */
631 for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
633 s = textToStr( name(hd(mems)).text );
634 assert(strlen(s) < 95);
636 n = findNameInAnyModule(findText(buf));
641 cclass(c).defaults = defs;
643 /* Create a name table entry for the dictionary datacon.
644 Interface files don't mention them, so it had better not
648 s = textToStr( cclass(c).text );
649 assert( strlen(s) < 96 );
652 n = findNameInAnyModule(t);
658 name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
659 name(n).number = cfunNo(0);
662 /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
663 Because this happens right at the end of loading, we know
664 that we should actually be able to find the symbol in this
665 module's object symbol table. Except that if the dictionary
666 has arity 1, we don't bother, since it will be represented as
667 a newtype and not as a data, so its itbl can remain NULL.
669 if (name(n).arity == 1) {
671 name(n).defn = nameId;
673 p = ifFindItblFor ( n );
679 /* ifaces_outstanding holds a list of parsed interfaces
680 for which we need to load objects and create symbol
683 Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
685 Bool processInterfaces ( void )
696 List all_known_types;
699 List cls_list; /* :: List Class */
700 List constructor_list; /* :: List Name */
702 List ifaces = NIL; /* :: List I_INTERFACE */
703 List iface_sizes = NIL; /* :: List Int */
704 List iface_onames = NIL; /* :: List Text */
706 if (isNull(ifaces_outstanding)) return FALSE;
710 "processInterfaces: %d interfaces to process\n",
711 length(ifaces_outstanding) );
714 /* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
715 for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
716 ifaces = cons ( zfst3(hd(xs)), ifaces );
717 iface_onames = cons ( zsnd3(hd(xs)), iface_onames );
718 iface_sizes = cons ( zthd3(hd(xs)), iface_sizes );
721 ifaces = reverse(ifaces);
722 iface_onames = reverse(iface_onames);
723 iface_sizes = reverse(iface_sizes);
725 /* Clean up interfaces -- dump non-exported value, class, type decls */
726 for (xs = ifaces; nonNull(xs); xs = tl(xs))
727 hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
730 /* Iteratively delete any type declarations which refer to unknown
733 num_known_types = 999999999;
737 /* Construct a list of all known tycons. This is a list of QualIds.
738 Unfortunately it also has to contain all known class names, since
739 allTypesKnown cannot distinguish between tycons and classes -- a
740 deficiency of the iface abs syntax.
742 all_known_types = getAllKnownTyconsAndClasses();
743 for (xs = ifaces; nonNull(xs); xs=tl(xs))
744 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
746 /* Have we reached a fixed point? */
747 i = length(all_known_types);
750 "\n============= %d known types =============\n", i );
752 if (num_known_types == i) break;
755 /* Delete all entities which refer to unknown tycons. */
756 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
757 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
758 assert(nonNull(mod));
759 hd(xs) = filterInterface ( hd(xs),
760 ifTypeDoesntRefUnknownTycon,
761 zpair(all_known_types,mod),
762 ifTypeDoesntRefUnknownTycon_dumpmsg );
766 /* Now abstractify any datas and newtypes which refer to unknown tycons
767 -- including, of course, the type decls just deleted.
769 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
770 List absify = NIL; /* :: [ConId] */
771 ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
772 ConId mod = zfst(iface);
773 List aktys = all_known_types; /* just a renaming */
777 /* Compute into absify the list of all ConIds (tycons) we need to
780 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
782 Bool allKnown = TRUE;
784 if (whatIs(ent)==I_DATA) {
785 Cell data = unap(I_DATA,ent);
786 List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
787 List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
788 for (t = ctx; nonNull(t); t=tl(t))
789 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
790 for (t = constrs; nonNull(t); t=tl(t))
791 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
792 if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
794 else if (whatIs(ent)==I_NEWTYPE) {
795 Cell newty = unap(I_NEWTYPE,ent);
796 List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
797 ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
798 for (t = ctx; nonNull(t); t=tl(t))
799 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
800 if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
804 absify = cons ( getIEntityName(ent), absify );
807 "abstractifying %s because it uses an unknown type\n",
808 textToStr(textOf(getIEntityName(ent))) );
813 /* mark in exports as abstract all names in absify (modifies iface) */
814 for (; nonNull(absify); absify=tl(absify)) {
815 ConId toAbs = hd(absify);
816 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
817 if (whatIs(hd(es)) != I_EXPORT) continue;
818 hd(es) = abstractifyExDecl ( hd(es), toAbs );
822 /* For each data/newtype in the export list marked as abstract,
823 remove the constructor lists. This catches all abstractification
824 caused by the code above, and it also catches tycons which really
825 were exported abstractly.
828 exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
829 /* exlist_list :: [I_EXPORT] */
830 for (t=exlist_list; nonNull(t); t=tl(t))
831 hd(t) = zsnd(unap(I_EXPORT,hd(t)));
832 /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
834 for (es = zsnd(iface); nonNull(es); es=tl(es)) {
836 if (whatIs(ent)==I_DATA
837 && isExportedAbstractly ( getIEntityName(ent),
839 Cell data = unap(I_DATA,ent);
840 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
841 zsel45(data), NIL /* the constr list */ );
842 hd(es) = ap(I_DATA,data);
844 fprintf(stderr, "abstractify data %s\n",
845 textToStr(textOf(getIEntityName(ent))) );
848 else if (whatIs(ent)==I_NEWTYPE
849 && isExportedAbstractly ( getIEntityName(ent),
851 Cell data = unap(I_NEWTYPE,ent);
852 data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
853 zsel45(data), NIL /* the constr-type pair */ );
854 hd(es) = ap(I_NEWTYPE,data);
856 fprintf(stderr, "abstractify newtype %s\n",
857 textToStr(textOf(getIEntityName(ent))) );
862 /* We've finally finished mashing this iface. Update the iface list. */
863 hd(xs) = ap(I_INTERFACE,iface);
867 /* At this point, the interfaces are cleaned up so that no type, data or
868 newtype defn refers to a non-existant type. However, there still may
869 be value defns, classes and instances which refer to unknown types.
870 Delete iteratively until a fixed point is reached.
873 fprintf(stderr,"\n");
875 num_known_types = 999999999;
879 /* Construct a list of all known tycons. This is a list of QualIds.
880 Unfortunately it also has to contain all known class names, since
881 allTypesKnown cannot distinguish between tycons and classes -- a
882 deficiency of the iface abs syntax.
884 all_known_types = getAllKnownTyconsAndClasses();
885 for (xs = ifaces; nonNull(xs); xs=tl(xs))
886 all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
888 /* Have we reached a fixed point? */
889 i = length(all_known_types);
892 "\n------------- %d known types -------------\n", i );
894 if (num_known_types == i) break;
897 /* Delete all entities which refer to unknown tycons. */
898 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
899 ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
900 assert(nonNull(mod));
902 hd(xs) = filterInterface ( hd(xs),
903 ifentityAllTypesKnown,
904 zpair(all_known_types,mod),
905 ifentityAllTypesKnown_dumpmsg );
910 /* Allocate module table entries and read in object code. */
913 xs=tl(xs), iface_sizes=tl(iface_sizes), iface_onames=tl(iface_onames)) {
914 startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))),
915 intOf(hd(iface_sizes)),
918 assert (isNull(iface_sizes));
919 assert (isNull(iface_onames));
922 /* Now work through the decl lists of the modules, and call the
923 startGHC* functions on the entities. This creates names in
924 various tables but doesn't bind them to anything.
927 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
928 iface = unap(I_INTERFACE,hd(xs));
929 mname = textOf(zfst(iface));
930 mod = findModule(mname);
931 if (isNull(mod)) internal("processInterfaces(4)");
933 ppModule ( module(mod).text );
935 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
936 Cell decl = hd(decls);
937 switch(whatIs(decl)) {
939 Cell exdecl = unap(I_EXPORT,decl);
940 startGHCExports ( zfst(exdecl), zsnd(exdecl) );
944 Cell imdecl = unap(I_IMPORT,decl);
945 startGHCImports ( zfst(imdecl), zsnd(imdecl) );
952 /* Trying to find the instance table location allocated by
953 startGHCInstance in subsequent processing is a nightmare, so
954 cache it on the tree.
956 Cell instance = unap(I_INSTANCE,decl);
957 Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
958 zsel35(instance), zsel45(instance) );
959 hd(decls) = ap(I_INSTANCE,
960 z5ble( zsel15(instance), zsel25(instance),
961 zsel35(instance), zsel45(instance), in ));
965 Cell tydecl = unap(I_TYPE,decl);
966 startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
967 zsel34(tydecl), zsel44(tydecl) );
971 Cell ddecl = unap(I_DATA,decl);
972 startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
973 zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
977 Cell ntdecl = unap(I_NEWTYPE,decl);
978 startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
979 zsel35(ntdecl), zsel45(ntdecl),
984 Cell klass = unap(I_CLASS,decl);
985 startGHCClass ( zsel15(klass), zsel25(klass),
986 zsel35(klass), zsel45(klass),
991 Cell value = unap(I_VALUE,decl);
992 startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
996 internal("processInterfaces(1)");
1002 fprintf(stderr, "\n============================"
1003 "=============================\n");
1004 fprintf(stderr, "=============================="
1005 "===========================\n");
1008 /* Traverse again the decl lists of the modules, this time
1009 calling the finishGHC* functions. But don't process
1010 the export lists; those must wait for later.
1014 constructor_list = NIL;
1015 for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
1016 iface = unap(I_INTERFACE,hd(xs));
1017 mname = textOf(zfst(iface));
1018 mod = findModule(mname);
1019 if (isNull(mod)) internal("processInterfaces(3)");
1021 ppModule ( module(mod).text );
1023 if (mname == textPrelude) didPrelude = TRUE;
1025 for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
1026 Cell decl = hd(decls);
1027 switch(whatIs(decl)) {
1035 Cell fixdecl = unap(I_FIXDECL,decl);
1036 finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
1040 Cell instance = unap(I_INSTANCE,decl);
1041 finishGHCInstance ( zsel55(instance) );
1045 Cell tydecl = unap(I_TYPE,decl);
1046 finishGHCSynonym ( zsel24(tydecl) );
1050 Cell ddecl = unap(I_DATA,decl);
1051 List constrs = finishGHCDataDecl ( zsel35(ddecl) );
1052 constructor_list = appendOnto ( constrs, constructor_list );
1056 Cell ntdecl = unap(I_NEWTYPE,decl);
1057 finishGHCNewType ( zsel35(ntdecl) );
1061 Cell klass = unap(I_CLASS,decl);
1062 Class cls = finishGHCClass ( zsel35(klass) );
1063 cls_list = cons(cls,cls_list);
1067 Cell value = unap(I_VALUE,decl);
1068 finishGHCValue ( zsnd3(value) );
1072 internal("processInterfaces(2)");
1077 fprintf(stderr, "\n+++++++++++++++++++++++++++++"
1078 "++++++++++++++++++++++++++++\n");
1079 fprintf(stderr, "+++++++++++++++++++++++++++++++"
1080 "++++++++++++++++++++++++++\n");
1083 /* Build the module(m).export lists for each module, by running
1084 through the export lists in the iface. Also, do the implicit
1085 'import Prelude' thing. And finally, do the object code
1088 for (xs = ifaces; nonNull(xs); xs = tl(xs))
1089 finishGHCModule(hd(xs));
1091 mapProc(visitClass,cls_list);
1092 mapProc(ifSetClassDefaultsAndDCon,cls_list);
1093 mapProc(ifLinkConstrItbl,constructor_list);
1096 ifaces_outstanding = NIL;
1102 /* --------------------------------------------------------------------------
1104 * ------------------------------------------------------------------------*/
1106 static void startGHCModule_errMsg ( char* msg )
1108 fprintf ( stderr, "object error: %s\n", msg );
1111 static void* startGHCModule_clientLookup ( char* sym )
1114 /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
1116 return lookupObjName ( sym );
1119 static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
1122 = ocNew ( startGHCModule_errMsg,
1123 startGHCModule_clientLookup,
1127 ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
1130 if (!ocLoadImage(oc,VERBOSE)) {
1131 ERRMSG(0) "Reading of object file \"%s\" failed", objNm
1134 if (!ocVerifyImage(oc,VERBOSE)) {
1135 ERRMSG(0) "Validation of object file \"%s\" failed", objNm
1138 if (!ocGetNames(oc,VERBOSE)) {
1139 ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
1145 static Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
1148 Module m = findModule(mname);
1151 m = newModule(mname);
1153 fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
1154 textToStr(mname), sizeObj );
1157 if (module(m).fake) {
1158 module(m).fake = FALSE;
1160 ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
1165 /* Get hold of the primary object for the module. */
1167 = startGHCModule_partial_load ( textToStr(nameObj), sizeObj );
1169 /* and any extras ... */
1170 for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
1174 String nm = getExtraObjectInfo ( textToStr(nameObj),
1178 ERRMSG(0) "Can't find extra object file \"%s\"", nm
1181 oc = startGHCModule_partial_load ( nm, size );
1182 oc->next = module(m).objectExtras;
1183 module(m).objectExtras = oc;
1188 /* For the module mod, augment both the export environment (.exports)
1189 and the eval environment (.names, .tycons, .classes)
1190 with the symbols mentioned in exlist. We don't actually need
1191 to modify the names, tycons, classes or instances in the eval
1192 environment, since previous processing of the
1193 top-level decls in the iface should have done this already.
1195 mn is the module mentioned in the export list; it is the "original"
1196 module for the symbols in the export list. We should also record
1197 this info with the symbols, since references to object code need to
1198 refer to the original module in which a symbol was defined, rather
1199 than to some module it has been imported into and then re-exported.
1201 We take the policy that if something mentioned in an export list
1202 can't be found in the symbol tables, it is simply ignored. After all,
1203 previous processing of the iface syntax trees has already removed
1204 everything which Hugs can't handle, so if there is mention of these
1205 things still lurking in export lists somewhere, about the only thing
1206 to do is to ignore it.
1208 Also do an implicit 'import Prelude' thingy for the module,
1213 static Void finishGHCModule ( Cell root )
1215 /* root :: I_INTERFACE */
1216 Cell iface = unap(I_INTERFACE,root);
1217 ConId iname = zfst(iface);
1218 Module mod = findModule(textOf(iname));
1219 List exlist_list = NIL;
1224 fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1227 if (isNull(mod)) internal("finishExports(1)");
1230 exlist_list = getExportDeclsInIFace ( root );
1231 /* exlist_list :: [I_EXPORT] */
1233 for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1234 ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
1235 ConId exmod = zfst(exdecl);
1236 List exlist = zsnd(exdecl);
1237 /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1239 for (; nonNull(exlist); exlist=tl(exlist)) {
1244 Cell ex = hd(exlist);
1246 switch (whatIs(ex)) {
1248 case VARIDCELL: /* variable */
1249 q = mkQualId(exmod,ex);
1250 c = findQualNameWithoutConsultingExportList ( q );
1251 if (isNull(c)) goto notfound;
1253 fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
1255 module(mod).exports = cons(c, module(mod).exports);
1259 case CONIDCELL: /* non data tycon */
1260 q = mkQualId(exmod,ex);
1261 c = findQualTyconWithoutConsultingExportList ( q );
1262 if (isNull(c)) goto notfound;
1264 fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
1266 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1270 case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
1271 subents = zsnd(ex); /* :: [ConVarId] */
1272 ex = zfst(ex); /* :: ConId */
1273 q = mkQualId(exmod,ex);
1274 c = findQualTyconWithoutConsultingExportList ( q );
1276 if (nonNull(c)) { /* data */
1278 fprintf(stderr, " data/newtype %s = { ",
1279 textToStr(textOf(ex)) );
1281 assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1282 abstract = isNull(tycon(c).defn);
1283 /* This data/newtype could be abstract even tho the export list
1284 says to export it non-abstractly. That happens if it was
1285 imported from some other module and is now being re-exported,
1286 and previous cleanup phases have abstractified it in the
1287 original (defining) module.
1290 module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1293 fprintf ( stderr, "(abstract) ");
1296 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1298 for (; nonNull(subents); subents = tl(subents)) {
1299 Cell ent2 = hd(subents);
1300 assert(isCon(ent2) || isVar(ent2));
1301 /* isVar since could be a field name */
1302 q = mkQualId(exmod,ent2);
1303 c = findQualNameWithoutConsultingExportList ( q );
1305 fprintf(stderr, "%s ", textToStr(name(c).text));
1308 /* module(mod).exports = cons(c, module(mod).exports); */
1313 fprintf(stderr, "}\n" );
1315 } else { /* class */
1316 q = mkQualId(exmod,ex);
1317 c = findQualClassWithoutConsultingExportList ( q );
1318 if (isNull(c)) goto notfound;
1320 fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
1322 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1324 for (; nonNull(subents); subents = tl(subents)) {
1325 Cell ent2 = hd(subents);
1326 assert(isVar(ent2));
1327 q = mkQualId(exmod,ent2);
1328 c = findQualNameWithoutConsultingExportList ( q );
1330 fprintf(stderr, "%s ", textToStr(name(c).text));
1332 if (isNull(c)) goto notfound;
1333 /* module(mod).exports = cons(c, module(mod).exports); */
1337 fprintf(stderr, "}\n" );
1343 internal("finishExports(2)");
1346 continue; /* so notfound: can be placed after this */
1349 /* q holds what ain't found */
1350 assert(whatIs(q)==QUALIDENT);
1352 fprintf( stderr, " ------ IGNORED: %s.%s\n",
1353 textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1360 if (preludeLoaded) {
1361 /* do the implicit 'import Prelude' thing */
1362 List pxs = module(modulePrelude).exports;
1363 for (; nonNull(pxs); pxs=tl(pxs)) {
1366 switch (whatIs(px)) {
1371 module(mod).names = cons ( px, module(mod).names );
1374 module(mod).tycons = cons ( px, module(mod).tycons );
1377 module(mod).classes = cons ( px, module(mod).classes );
1380 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1381 internal("finishGHCModule -- implicit import Prelude");
1388 /* Last, but by no means least ... */
1389 if (!ocResolve(module(mod).object,VERBOSE))
1390 internal("finishGHCModule: object resolution failed");
1392 for (oc=module(mod).objectExtras; oc; oc=oc->next) {
1393 if (!ocResolve(oc, VERBOSE))
1394 internal("finishGHCModule: extra object resolution failed");
1399 /* --------------------------------------------------------------------------
1401 * ------------------------------------------------------------------------*/
1403 static Void startGHCExports ( ConId mn, List exlist )
1406 fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
1408 /* Nothing to do. */
1411 static Void finishGHCExports ( ConId mn, List exlist )
1414 fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
1416 /* Nothing to do. */
1420 /* --------------------------------------------------------------------------
1422 * ------------------------------------------------------------------------*/
1424 static Void startGHCImports ( ConId mn, List syms )
1425 /* nm the module to import from */
1426 /* syms [ConId | VarId] -- the names to import */
1429 fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
1431 /* Nothing to do. */
1435 static Void finishGHCImports ( ConId nm, List syms )
1436 /* nm the module to import from */
1437 /* syms [ConId | VarId] -- the names to import */
1440 fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
1442 /* Nothing to do. */
1446 /* --------------------------------------------------------------------------
1448 * ------------------------------------------------------------------------*/
1450 static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
1452 Int p = intOf(prec);
1453 Int a = intOf(assoc);
1454 Name n = findName(textOf(name));
1455 assert (nonNull(n));
1456 name(n).syntax = mkSyntax ( a, p );
1460 /* --------------------------------------------------------------------------
1462 * ------------------------------------------------------------------------*/
1464 /* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
1465 { C1 a } -> { C2 b } -> T into
1466 ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
1468 static Type dictapsToQualtype ( Type ty )
1471 List preds, dictaps;
1473 /* break ty into pieces at the top-level arrows */
1474 while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
1475 pieces = cons ( arg(fun(ty)), pieces );
1478 pieces = cons ( ty, pieces );
1479 pieces = reverse ( pieces );
1482 while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
1483 dictaps = cons ( hd(pieces), dictaps );
1484 pieces = tl(pieces);
1487 /* dictaps holds the predicates, backwards */
1488 /* pieces holds the remainder of the type, forwards */
1489 assert(nonNull(pieces));
1490 pieces = reverse(pieces);
1492 pieces = tl(pieces);
1493 for (; nonNull(pieces); pieces=tl(pieces))
1494 ty = fn(hd(pieces),ty);
1497 for (; nonNull(dictaps); dictaps=tl(dictaps)) {
1498 Cell da = hd(dictaps);
1499 QualId cl = fst(unap(DICTAP,da));
1500 Cell arg = snd(unap(DICTAP,da));
1501 preds = cons ( pair(cl,arg), preds );
1504 if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
1510 static void startGHCValue ( Int line, VarId vid, Type ty )
1514 Text v = textOf(vid);
1517 fprintf(stderr,"begin startGHCValue %s\n", textToStr(v));
1522 if (nonNull(n) && name(n).defn != PREDEFINED) {
1523 ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
1526 if (isNull(n)) n = newName(v,NIL);
1528 ty = dictapsToQualtype(ty);
1530 tvs = ifTyvarsIn(ty);
1531 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1532 hd(tmp) = zpair(hd(tmp),STAR);
1534 ty = mkPolyType(tvsToKind(tvs),ty);
1536 ty = tvsToOffsets(line,ty,tvs);
1538 name(n).arity = arityInclDictParams(ty);
1539 name(n).line = line;
1544 static void finishGHCValue ( VarId vid )
1546 Name n = findName ( textOf(vid) );
1547 Int line = name(n).line;
1549 fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1551 assert(currentModule == name(n).mod);
1552 name(n).type = conidcellsToTycons(line,name(n).type);
1554 if (isIfaceDefaultMethodName(name(n).text)) {
1555 /* ... we need to set .parent to point to the class
1556 ... once we figure out what the class actually is :-)
1558 Type t = name(n).type;
1559 assert(isPolyType(t));
1560 if (isPolyType(t)) t = monotypeOf(t);
1561 assert(isQualType(t));
1562 t = fst(snd(t)); /* t :: [(Class,Offset)] */
1564 assert(nonNull(hd(t)));
1565 assert(isPair(hd(t)));
1566 t = fst(hd(t)); /* t :: Class */
1569 name(n).parent = t; /* phew! */
1574 /* --------------------------------------------------------------------------
1576 * ------------------------------------------------------------------------*/
1578 static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1580 /* tycon :: ConId */
1581 /* tvs :: [((VarId,Kind))] */
1583 Text t = textOf(tycon);
1585 fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1588 if (nonNull(findTycon(t))) {
1589 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1593 Tycon tc = newTycon(t);
1594 tycon(tc).line = line;
1595 tycon(tc).arity = length(tvs);
1596 tycon(tc).what = SYNONYM;
1597 tycon(tc).kind = tvsToKind(tvs);
1599 /* prepare for finishGHCSynonym */
1600 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
1605 static Void finishGHCSynonym ( ConId tyc )
1607 Tycon tc = findTycon(textOf(tyc));
1608 Int line = tycon(tc).line;
1610 fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1613 assert (currentModule == tycon(tc).mod);
1614 // setCurrModule(tycon(tc).mod);
1615 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1617 /* (ADR) ToDo: can't really do this until I've done all synonyms
1618 * and then I have to do them in order
1619 * tycon(tc).defn = fullExpand(ty);
1620 * (JRS) What?!?! i don't understand
1625 /* --------------------------------------------------------------------------
1627 * ------------------------------------------------------------------------*/
1629 static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1631 List ctx0; /* [((QConId,VarId))] */
1632 Cell tycon; /* ConId */
1633 List ktyvars; /* [((VarId,Kind))] */
1634 List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
1635 /* The Text is an optional field name
1636 The Int indicates strictness */
1637 /* ToDo: worry about being given a decl for (->) ?
1638 * and worry about qualidents for ()
1641 Type ty, resTy, selTy, conArgTy;
1642 List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
1646 Pair conArg, ctxElem;
1648 Int conArgStrictness;
1650 Text t = textOf(tycon);
1652 fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1656 if (nonNull(findTycon(t))) {
1657 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1661 Tycon tc = newTycon(t);
1663 tycon(tc).line = line;
1664 tycon(tc).arity = length(ktyvars);
1665 tycon(tc).kind = tvsToKind(ktyvars);
1666 tycon(tc).what = DATATYPE;
1668 /* a list to accumulate selectors in :: [((VarId,Type))] */
1671 /* make resTy the result type of the constr, T v1 ... vn */
1673 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1674 resTy = ap(resTy,zfst(hd(tmp)));
1676 /* for each constructor ... */
1677 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1678 constr = hd(constrs);
1679 conid = zfst(constr);
1680 fields = zsnd(constr);
1682 /* Build type of constr and handle any selectors found.
1683 Also collect up tyvars occurring in the constr's arg
1684 types, so we can throw away irrelevant parts of the
1688 tyvarsMentioned = NIL;
1689 /* tyvarsMentioned :: [VarId] */
1691 conArgs = reverse(fields);
1692 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1693 conArg = hd(conArgs); /* (Type,Text) */
1694 conArgTy = zfst3(conArg);
1695 conArgNm = zsnd3(conArg);
1696 conArgStrictness = intOf(zthd3(conArg));
1697 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1699 if (conArgStrictness > 0) conArgTy = bang(conArgTy);
1700 ty = fn(conArgTy,ty);
1701 if (nonNull(conArgNm)) {
1702 /* a field name is mentioned too */
1703 selTy = fn(resTy,conArgTy);
1704 if (whatIs(tycon(tc).kind) != STAR)
1705 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1706 selTy = tvsToOffsets(line,selTy, ktyvars);
1707 sels = cons( zpair(conArgNm,selTy), sels);
1711 /* Now ty is the constructor's type, not including context.
1712 Throw away any parts of the context not mentioned in
1713 tyvarsMentioned, and use it to qualify ty.
1716 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1718 /* ctxElem :: ((QConId,VarId)) */
1719 if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1720 ctx2 = cons(ctxElem, ctx2);
1723 ty = ap(QUAL,pair(ctx2,ty));
1725 /* stick the tycon's kind on, if not simply STAR */
1726 if (whatIs(tycon(tc).kind) != STAR)
1727 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1729 ty = tvsToOffsets(line,ty, ktyvars);
1731 /* Finally, stick the constructor's type onto it. */
1732 hd(constrs) = ztriple(conid,fields,ty);
1735 /* Final result is that
1736 constrs :: [((ConId,[((Type,Text))],Type))]
1737 lists the constructors and their types
1738 sels :: [((VarId,Type))]
1739 lists the selectors and their types
1741 tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1746 static List startGHCConstrs ( Int line, List cons, List sels )
1748 /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1749 /* sels :: [((VarId,Type))] */
1750 /* returns [Name] */
1752 Int conNo = length(cons)>1 ? 1 : 0;
1753 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1754 Name c = startGHCConstr(line,conNo,hd(cs));
1757 /* cons :: [Name] */
1759 for(ss=sels; nonNull(ss); ss=tl(ss)) {
1760 hd(ss) = startGHCSel(line,hd(ss));
1762 /* sels :: [Name] */
1763 return appendOnto(cons,sels);
1767 static Name startGHCSel ( Int line, ZPair sel )
1769 /* sel :: ((VarId, Type)) */
1770 Text t = textOf(zfst(sel));
1771 Type type = zsnd(sel);
1773 Name n = findName(t);
1775 ERRMSG(line) "Repeated definition for selector \"%s\"",
1781 name(n).line = line;
1782 name(n).number = SELNAME;
1785 name(n).type = type;
1790 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1792 /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1793 /* (ADR) ToDo: add rank2 annotation and existential annotation
1794 * these affect how constr can be used.
1796 Text con = textOf(zfst3(constr));
1797 Type type = zthd3(constr);
1798 Int arity = arityFromType(type);
1799 Name n = findName(con); /* Allocate constructor fun name */
1801 n = newName(con,NIL);
1802 } else if (name(n).defn!=PREDEFINED) {
1803 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1807 name(n).arity = arity; /* Save constructor fun details */
1808 name(n).line = line;
1809 name(n).number = cfunNo(conNo);
1810 name(n).type = type;
1815 static List finishGHCDataDecl ( ConId tyc )
1818 Tycon tc = findTycon(textOf(tyc));
1820 fprintf ( stderr, "begin finishGHCDataDecl %s\n",
1821 textToStr(textOf(tyc)) );
1823 if (isNull(tc)) internal("finishGHCDataDecl");
1825 for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1827 Int line = name(n).line;
1828 assert(currentModule == name(n).mod);
1829 name(n).type = conidcellsToTycons(line,name(n).type);
1830 name(n).parent = tc; //---????
1833 return tycon(tc).defn;
1837 /* --------------------------------------------------------------------------
1839 * ------------------------------------------------------------------------*/
1841 static Void startGHCNewType ( Int line, List ctx0,
1842 ConId tycon, List tvs, Cell constr )
1844 /* ctx0 :: [((QConId,VarId))] */
1845 /* tycon :: ConId */
1846 /* tvs :: [((VarId,Kind))] */
1847 /* constr :: ((ConId,Type)) or NIL if abstract */
1850 Text t = textOf(tycon);
1852 fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1857 if (nonNull(findTycon(t))) {
1858 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1862 Tycon tc = newTycon(t);
1863 tycon(tc).line = line;
1864 tycon(tc).arity = length(tvs);
1865 tycon(tc).what = NEWTYPE;
1866 tycon(tc).kind = tvsToKind(tvs);
1867 /* can't really do this until I've read in all synonyms */
1869 if (isNull(constr)) {
1870 tycon(tc).defn = NIL;
1872 /* constr :: ((ConId,Type)) */
1873 Text con = textOf(zfst(constr));
1874 Type type = zsnd(constr);
1875 Name n = findName(con); /* Allocate constructor fun name */
1877 n = newName(con,NIL);
1878 } else if (name(n).defn!=PREDEFINED) {
1879 ERRMSG(line) "Repeated definition for constructor \"%s\"",
1883 name(n).arity = 1; /* Save constructor fun details */
1884 name(n).line = line;
1885 name(n).number = cfunNo(0);
1886 name(n).defn = nameId;
1887 tycon(tc).defn = singleton(n);
1889 /* make resTy the result type of the constr, T v1 ... vn */
1891 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1892 resTy = ap(resTy,zfst(hd(tmp)));
1893 type = fn(type,resTy);
1895 type = ap(QUAL,pair(ctx0,type));
1896 type = tvsToOffsets(line,type,tvs);
1897 name(n).type = type;
1903 static Void finishGHCNewType ( ConId tyc )
1905 Tycon tc = findTycon(textOf(tyc));
1907 fprintf ( stderr, "begin finishGHCNewType %s\n",
1908 textToStr(textOf(tyc)) );
1911 if (isNull(tc)) internal("finishGHCNewType");
1913 if (isNull(tycon(tc).defn)) {
1914 /* it's an abstract type */
1916 else if (length(tycon(tc).defn) == 1) {
1917 /* As we expect, has a single constructor */
1918 Name n = hd(tycon(tc).defn);
1919 Int line = name(n).line;
1920 assert(currentModule == name(n).mod);
1921 name(n).type = conidcellsToTycons(line,name(n).type);
1923 internal("finishGHCNewType(2)");
1928 /* --------------------------------------------------------------------------
1929 * Class declarations
1930 * ------------------------------------------------------------------------*/
1932 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1934 List ctxt; /* [((QConId, VarId))] */
1935 ConId tc_name; /* ConId */
1936 List kinded_tvs; /* [((VarId, Kind))] */
1937 List mems0; { /* [((VarId, Type))] */
1939 List mems; /* [((VarId, Type))] */
1940 List tvsInT; /* [VarId] and then [((VarId,Kind))] */
1941 List tvs; /* [((VarId,Kind))] */
1942 List ns; /* [Name] */
1945 ZPair kinded_tv = hd(kinded_tvs);
1946 Text ct = textOf(tc_name);
1947 Pair newCtx = pair(tc_name, zfst(kinded_tv));
1949 fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
1953 if (length(kinded_tvs) != 1) {
1954 ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1958 if (nonNull(findClass(ct))) {
1959 ERRMSG(line) "Repeated definition of class \"%s\"",
1962 } else if (nonNull(findTycon(ct))) {
1963 ERRMSG(line) "\"%s\" used as both class and type constructor",
1967 Class nw = newClass(ct);
1968 cclass(nw).text = ct;
1969 cclass(nw).line = line;
1970 cclass(nw).arity = 1;
1971 cclass(nw).head = ap(nw,mkOffset(0));
1972 cclass(nw).kinds = singleton( zsnd(kinded_tv) );
1973 cclass(nw).instances = NIL;
1974 cclass(nw).numSupers = length(ctxt);
1976 /* Kludge to map the single tyvar in the context to Offset 0.
1977 Need to do something better for multiparam type classes.
1979 cclass(nw).supers = tvsToOffsets(line,ctxt,
1980 singleton(kinded_tv));
1983 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1984 ZPair mem = hd(mems);
1985 Type memT = zsnd(mem);
1986 Text mnt = textOf(zfst(mem));
1989 /* Stick the new context on the member type */
1990 memT = dictapsToQualtype(memT);
1991 if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1992 if (whatIs(memT)==QUAL) {
1994 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1997 pair(singleton(newCtx),memT));
2000 /* Cook up a kind for the type. */
2001 tvsInT = ifTyvarsIn(memT);
2002 /* tvsInT :: [VarId] */
2004 /* ToDo: maximally bogus. We allow the class tyvar to
2005 have the kind as supplied by the parser, but we just
2006 assume that all others have kind *. It's a kludge.
2008 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
2010 if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
2011 k = zsnd(kinded_tv); else
2013 hd(tvs) = zpair(hd(tvs),k);
2015 /* tvsIntT :: [((VarId,Kind))] */
2017 memT = mkPolyType(tvsToKind(tvsInT),memT);
2018 memT = tvsToOffsets(line,memT,tvsInT);
2020 /* Park the type back on the member */
2021 mem = zpair(zfst(mem),memT);
2023 /* Bind code to the member */
2027 "Repeated definition for class method \"%s\"",
2031 mn = newName(mnt,NIL);
2036 cclass(nw).members = mems0;
2037 cclass(nw).numMembers = length(mems0);
2040 for (mno=0; mno<cclass(nw).numSupers; mno++) {
2041 ns = cons(newDSel(nw,mno),ns);
2043 cclass(nw).dsels = rev(ns);
2048 static Class finishGHCClass ( Tycon cls_tyc )
2053 Class nw = findClass ( textOf(cls_tyc) );
2055 fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
2057 if (isNull(nw)) internal("finishGHCClass");
2059 line = cclass(nw).line;
2061 assert (currentModule == cclass(nw).mod);
2063 cclass(nw).level = 0;
2064 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
2065 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
2066 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
2068 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2069 Pair mem = hd(mems); /* (VarId, Type) */
2070 Text txt = textOf(fst(mem));
2072 Name n = findName(txt);
2075 name(n).line = cclass(nw).line;
2077 name(n).number = ctr--;
2078 name(n).arity = arityInclDictParams(name(n).type);
2079 name(n).parent = nw;
2087 /* --------------------------------------------------------------------------
2089 * ------------------------------------------------------------------------*/
2091 static Inst startGHCInstance (line,ktyvars,cls,var)
2093 List ktyvars; /* [((VarId,Kind))] */
2094 Type cls; /* Type */
2095 VarId var; { /* VarId */
2096 List tmp, tvs, ks, spec;
2101 Inst in = newInst();
2103 fprintf ( stderr, "begin startGHCInstance\n" );
2108 tvs = ifTyvarsIn(cls); /* :: [VarId] */
2110 The order of tvs is important for tvsToOffsets.
2111 tvs should be a permutation of ktyvars. Fish the tyvar kinds
2112 out of ktyvars and attach them to tvs.
2114 for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2116 for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2117 if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2119 if (isNull(k)) internal("startGHCInstance: finding kinds");
2120 hd(xs1) = zpair(hd(xs1),k);
2123 cls = tvsToOffsets(line,cls,tvs);
2126 spec = cons(fun(cls),spec);
2129 spec = reverse(spec);
2131 inst(in).line = line;
2132 inst(in).implements = NIL;
2133 inst(in).kinds = simpleKind(length(tvs)); /* do this right */
2134 inst(in).specifics = spec;
2135 inst(in).numSpecifics = length(spec);
2136 inst(in).head = cls;
2138 /* Figure out the name of the class being instanced, and store it
2139 at inst(in).c. finishGHCInstance will resolve it to a real Class. */
2141 Cell cl = inst(in).head;
2142 assert(whatIs(cl)==DICTAP);
2143 cl = unap(DICTAP,cl);
2145 assert ( isQCon(cl) );
2150 Name b = newName( /*inventText()*/ textOf(var),NIL);
2151 name(b).line = line;
2152 name(b).arity = length(spec); /* unused? */ /* and surely wrong */
2153 name(b).number = DFUNNAME;
2154 name(b).parent = in;
2155 inst(in).builder = b;
2156 /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2163 static Void finishGHCInstance ( Inst in )
2170 fprintf ( stderr, "begin finishGHCInstance\n" );
2173 assert (nonNull(in));
2174 line = inst(in).line;
2175 assert (currentModule==inst(in).mod);
2177 /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2178 since startGHCInstance couldn't possibly have resolved it to
2179 a Class at that point. We convert it to a Class now.
2183 c = findQualClassWithoutConsultingExportList(c);
2187 inst(in).head = conidcellsToTycons(line,inst(in).head);
2188 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
2189 cclass(c).instances = cons(in,cclass(c).instances);
2193 /* --------------------------------------------------------------------------
2195 * ------------------------------------------------------------------------*/
2197 /* This is called from the startGHC* functions. It traverses a structure
2198 and converts varidcells, ie, type variables parsed by the interface
2199 parser, into Offsets, which is how Hugs wants to see them internally.
2200 The Offset for a type variable is determined by its place in the list
2201 passed as the second arg; the associated kinds are irrelevant.
2203 ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2206 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2207 static Type tvsToOffsets(line,type,ktyvars)
2210 List ktyvars; { /* [((VarId,Kind))] */
2211 switch (whatIs(type)) {
2218 case ZTUP2: /* convert to the untyped representation */
2219 return ap( tvsToOffsets(line,zfst(type),ktyvars),
2220 tvsToOffsets(line,zsnd(type),ktyvars) );
2222 return ap( tvsToOffsets(line,fun(type),ktyvars),
2223 tvsToOffsets(line,arg(type),ktyvars) );
2227 tvsToOffsets(line,monotypeOf(type),ktyvars)
2231 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2232 tvsToOffsets(line,snd(snd(type)),ktyvars)));
2233 case DICTAP: /* bogus ?? */
2234 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2235 case UNBOXEDTUP: /* bogus?? */
2236 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2237 case BANG: /* bogus?? */
2238 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2239 case VARIDCELL: /* Ha! some real work to do! */
2241 Text tv = textOf(type);
2242 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2245 assert(isZPair(hd(ktyvars)));
2246 varid = zfst(hd(ktyvars));
2248 if (tv == tt) return mkOffset(i);
2250 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2255 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2257 fprintf(stderr,"\n");
2261 return NIL; /* NOTREACHED */
2265 /* This is called from the finishGHC* functions. It traverses a structure
2266 and converts conidcells, ie, type constructors parsed by the interface
2267 parser, into Tycons (or Classes), which is how Hugs wants to see them
2268 internally. Calls to this fn have to be deferred to the second phase
2269 of interface loading (finishGHC* rather than startGHC*) so that all relevant
2270 Tycons or Classes have been loaded into the symbol tables and can be
2273 static Type conidcellsToTycons ( Int line, Type type )
2275 switch (whatIs(type)) {
2285 { Cell t; /* Tycon or Class */
2286 Text m = qmodOf(type);
2287 Module mod = findModule(m);
2290 "Undefined module in qualified name \"%s\"",
2295 t = findQualTyconWithoutConsultingExportList(type);
2296 if (nonNull(t)) return t;
2297 t = findQualClassWithoutConsultingExportList(type);
2298 if (nonNull(t)) return t;
2300 "Undefined qualified class or type \"%s\"",
2308 cl = findQualClass(type);
2309 if (nonNull(cl)) return cl;
2310 if (textOf(type)==findText("[]"))
2311 /* a hack; magically qualify [] into PrelBase.[] */
2312 return conidcellsToTycons(line,
2313 mkQualId(mkCon(findText("PrelBase")),type));
2314 tc = findQualTycon(type);
2315 if (nonNull(tc)) return tc;
2317 "Undefined class or type constructor \"%s\"",
2323 return ap( conidcellsToTycons(line,fun(type)),
2324 conidcellsToTycons(line,arg(type)) );
2325 case ZTUP2: /* convert to std pair */
2326 return ap( conidcellsToTycons(line,zfst(type)),
2327 conidcellsToTycons(line,zsnd(type)) );
2332 conidcellsToTycons(line,monotypeOf(type))
2336 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2337 conidcellsToTycons(line,snd(snd(type)))));
2338 case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2339 Not sure if this is really the right place to
2340 convert it to the form Hugs wants, but will do so anyway.
2342 /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2344 Class cl = fst(unap(DICTAP,type));
2345 List args = snd(unap(DICTAP,type));
2347 conidcellsToTycons(line,pair(cl,args));
2350 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2352 return ap(BANG, conidcellsToTycons(line, snd(type)));
2354 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2357 fprintf(stderr,"\n");
2361 return NIL; /* NOTREACHED */
2365 /* Find out if a type mentions a type constructor not present in
2366 the supplied list of qualified tycons.
2368 static Bool allTypesKnown ( Type type,
2369 List aktys /* [QualId] */,
2372 switch (whatIs(type)) {
2379 return allTypesKnown(fun(type),aktys,thisMod)
2380 && allTypesKnown(arg(type),aktys,thisMod);
2382 return allTypesKnown(zfst(type),aktys,thisMod)
2383 && allTypesKnown(zsnd(type),aktys,thisMod);
2385 return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2388 if (textOf(type)==findText("[]"))
2389 /* a hack; magically qualify [] into PrelBase.[] */
2390 type = mkQualId(mkCon(findText("PrelBase")),type); else
2391 type = mkQualId(thisMod,type);
2394 if (isNull(qualidIsMember(type,aktys))) goto missing;
2400 fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2401 print(type,10);printf("\n");
2402 internal("allTypesKnown");
2403 return TRUE; /*notreached*/
2407 fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
2408 fprintf(stderr,"\n");
2414 /* --------------------------------------------------------------------------
2417 * None of these do lookups or require that lookups have been resolved
2418 * so they can be performed while reading interfaces.
2419 * ------------------------------------------------------------------------*/
2421 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2422 static Kinds tvsToKind(tvs)
2423 List tvs; { /* [((VarId,Kind))] */
2426 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2427 if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2428 if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2429 r = ap(zsnd(hd(rs)),r);
2435 static Int arityInclDictParams ( Type type )
2438 if (isPolyType(type)) type = monotypeOf(type);
2440 if (whatIs(type) == QUAL)
2442 arity += length ( fst(snd(type)) );
2443 type = snd(snd(type));
2445 while (isAp(type) && getHead(type)==typeArrow) {
2452 /* arity of a constructor with this type */
2453 static Int arityFromType(type)
2456 if (isPolyType(type)) {
2457 type = monotypeOf(type);
2459 if (whatIs(type) == QUAL) {
2460 type = snd(snd(type));
2462 if (whatIs(type) == EXIST) {
2463 type = snd(snd(type));
2465 if (whatIs(type)==RANK2) {
2466 type = snd(snd(type));
2468 while (isAp(type) && getHead(type)==typeArrow) {
2476 /* ifTyvarsIn :: Type -> [VarId]
2477 The returned list has no duplicates -- is a set.
2479 static List ifTyvarsIn(type)
2481 List vs = typeVarsIn(type,NIL,NIL,NIL);
2483 for (; nonNull(vs2); vs2=tl(vs2))
2484 if (whatIs(hd(vs2)) != VARIDCELL)
2485 internal("ifTyvarsIn");
2491 /* --------------------------------------------------------------------------
2492 * General object symbol query stuff
2493 * ------------------------------------------------------------------------*/
2495 #define EXTERN_SYMS_ALLPLATFORMS \
2496 Sym(stg_gc_enter_1) \
2497 Sym(stg_gc_noregs) \
2505 Sym(stg_update_PAP) \
2506 Sym(stg_error_entry) \
2507 Sym(__ap_2_upd_info) \
2508 Sym(__ap_3_upd_info) \
2509 Sym(__ap_4_upd_info) \
2510 Sym(__ap_5_upd_info) \
2511 Sym(__ap_6_upd_info) \
2512 Sym(__ap_7_upd_info) \
2513 Sym(__ap_8_upd_info) \
2514 Sym(__sel_0_upd_info) \
2515 Sym(__sel_1_upd_info) \
2516 Sym(__sel_2_upd_info) \
2517 Sym(__sel_3_upd_info) \
2518 Sym(__sel_4_upd_info) \
2519 Sym(__sel_5_upd_info) \
2520 Sym(__sel_6_upd_info) \
2521 Sym(__sel_7_upd_info) \
2522 Sym(__sel_8_upd_info) \
2523 Sym(__sel_9_upd_info) \
2524 Sym(__sel_10_upd_info) \
2525 Sym(__sel_11_upd_info) \
2526 Sym(__sel_12_upd_info) \
2528 Sym(Upd_frame_info) \
2529 Sym(seq_frame_info) \
2530 Sym(CAF_BLACKHOLE_info) \
2531 Sym(IND_STATIC_info) \
2532 Sym(EMPTY_MVAR_info) \
2533 Sym(MUT_ARR_PTRS_FROZEN_info) \
2535 Sym(putMVarzh_fast) \
2536 Sym(newMVarzh_fast) \
2537 Sym(takeMVarzh_fast) \
2542 Sym(killThreadzh_fast) \
2543 Sym(waitReadzh_fast) \
2544 Sym(waitWritezh_fast) \
2545 Sym(CHARLIKE_closure) \
2546 Sym(INTLIKE_closure) \
2547 Sym(suspendThread) \
2549 Sym(stackOverflow) \
2550 Sym(int2Integerzh_fast) \
2551 Sym(stg_gc_unbx_r1) \
2553 Sym(makeForeignObjzh_fast) \
2554 Sym(__encodeDouble) \
2555 Sym(decodeDoublezh_fast) \
2557 Sym(isDoubleInfinite) \
2558 Sym(isDoubleDenormalized) \
2559 Sym(isDoubleNegativeZero) \
2560 Sym(__encodeFloat) \
2561 Sym(decodeFloatzh_fast) \
2563 Sym(isFloatInfinite) \
2564 Sym(isFloatDenormalized) \
2565 Sym(isFloatNegativeZero) \
2566 Sym(__int_encodeFloat) \
2567 Sym(__int_encodeDouble) \
2571 Sym(gcdIntegerzh_fast) \
2572 Sym(newArrayzh_fast) \
2573 Sym(unsafeThawArrayzh_fast) \
2574 Sym(newDoubleArrayzh_fast) \
2575 Sym(newFloatArrayzh_fast) \
2576 Sym(newAddrArrayzh_fast) \
2577 Sym(newWordArrayzh_fast) \
2578 Sym(newIntArrayzh_fast) \
2579 Sym(newCharArrayzh_fast) \
2580 Sym(newMutVarzh_fast) \
2581 Sym(quotRemIntegerzh_fast) \
2582 Sym(quotIntegerzh_fast) \
2583 Sym(remIntegerzh_fast) \
2584 Sym(divExactIntegerzh_fast) \
2585 Sym(divModIntegerzh_fast) \
2586 Sym(timesIntegerzh_fast) \
2587 Sym(minusIntegerzh_fast) \
2588 Sym(plusIntegerzh_fast) \
2589 Sym(addr2Integerzh_fast) \
2590 Sym(mkWeakzh_fast) \
2593 Sym(resetNonBlockingFd) \
2595 Sym(stable_ptr_table) \
2596 Sym(createAdjThunk) \
2597 Sym(shutdownHaskellAndExit) \
2598 Sym(stg_enterStackTop) \
2599 Sym(CAF_UNENTERED_entry) \
2600 Sym(stg_yield_to_Hugs) \
2603 /* needed by libHS_cbits */ \
2642 #define EXTERN_SYMS_cygwin32 \
2643 SymX(GetCurrentProcess) \
2644 SymX(GetProcessTimes) \
2653 Sym(__imp__tzname) \
2654 Sym(__imp__timezone) \
2673 #define EXTERN_SYMS_linux \
2674 Sym(__errno_location) \
2686 #if defined(linux_TARGET_OS)
2687 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
2690 #if defined(solaris2_TARGET_OS)
2691 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
2694 #if defined(cygwin32_TARGET_OS)
2695 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
2701 /* entirely bogus claims about types of these symbols */
2702 #define Sym(vvv) extern void (vvv);
2703 #define SymX(vvv) /**/
2704 EXTERN_SYMS_ALLPLATFORMS
2705 EXTERN_SYMS_THISPLATFORM
2710 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2712 #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2716 EXTERN_SYMS_ALLPLATFORMS
2717 EXTERN_SYMS_THISPLATFORM
2724 /* A kludge to assist Win32 debugging. */
2725 char* nameFromStaticOPtr ( void* ptr )
2728 for (k = 0; rtsTab[k].nm; k++)
2729 if (ptr == rtsTab[k].ad)
2730 return rtsTab[k].nm;
2735 static void* lookupObjName ( char* nm )
2743 int first_real_char;
2746 strncpy(nm2,nm,200);
2748 /* first see if it's an RTS name */
2749 for (k = 0; rtsTab[k].nm; k++)
2750 if (0==strcmp(nm2,rtsTab[k].nm))
2751 return rtsTab[k].ad;
2753 /* perhaps an extra-symbol ? */
2754 a = lookupOExtraTabName ( nm );
2757 /* if not an RTS name, look in the
2758 relevant module's object symbol table
2760 # if LEADING_UNDERSCORE
2761 first_real_char = 1;
2763 first_real_char = 0;
2765 pp = strchr(nm2+first_real_char, '_');
2766 if (!pp || !isupper(nm2[first_real_char])) goto not_found;
2768 t = unZcodeThenFindText(nm2+first_real_char);
2770 if (isNull(m)) goto not_found;
2772 a = lookupOTabName ( m, nm ); /* RATIONALISE */
2777 "lookupObjName: can't resolve name `%s'\n",
2784 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2786 OSectionKind sk = lookupSection(p);
2787 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2788 return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2792 int is_dynamically_loaded_rwdata_ptr ( char* p )
2794 OSectionKind sk = lookupSection(p);
2795 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2796 return (sk == HUGS_SECTIONKIND_RWDATA);
2800 int is_not_dynamically_loaded_ptr ( char* p )
2802 OSectionKind sk = lookupSection(p);
2803 assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2804 return (sk == HUGS_SECTIONKIND_OTHER);
2808 /* --------------------------------------------------------------------------
2810 * ------------------------------------------------------------------------*/
2812 Void interface(what)
2815 case POSTPREL: break;
2819 ifaces_outstanding = NIL;
2822 mark(ifaces_outstanding);
2827 /*-------------------------------------------------------------------------*/