* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/12/10 15:59:46 $
+ * $Revision: 1.59 $
+ * $Date: 2000/05/26 10:14:33 $
* ------------------------------------------------------------------------*/
-/* ToDo:
- * o use Z encoding
- * o use vectored CONSTR_entry when appropriate
- * o generate export list
- *
- * Needs GHC changes to generate member selectors,
- * superclass selectors, etc
- * o instance decls
- * o dictionary constructors ?
- *
- * o Get Hugs/GHC to agree on what interface files look like.
- * o figure out how to replace the Hugs Prelude with the GHC Prelude
- */
-
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
-#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "link.h"
+#include "object.h"
+
+#include "Rts.h" /* to make StgPtr visible in Assembler.h */
#include "Assembler.h" /* for wrapping GHC objects */
-#include "dynamic.h"
-#define DEBUG_IFACE
+/*#define DEBUG_IFACE*/
#define VERBOSE FALSE
-extern void print ( Cell, Int );
-
/* --------------------------------------------------------------------------
+ * (This comment is now out of date. JRS, 991216).
* The "addGHC*" functions act as "impedence matchers" between GHC
* interface files and Hugs. Their main job is to convert abstract
* syntax trees into Hugs' internal representations.
*
* ------------------------------------------------------------------------*/
+
+/*
+New comment, 991216, explaining roughly how it all works.
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Interfaces can contain references to unboxed types, and these need to
+be handled carefully. The following is a summary of how the interface
+loader now works. It is applied to groups of interfaces simultaneously,
+viz, the entire Prelude at once:
+
+0. Parse interfaces, chasing imports until a complete
+ strongly-connected-component of ifaces has been parsed.
+ All interfaces in this scc are processed together, in
+ steps 1 .. 8 below.
+
+1. Throw away any entity not mentioned in the export lists.
+
+2. Delete type (not data or newtype) definitions which refer to
+ unknown types in their right hand sides. Because Hugs doesn't
+ know of any unboxed types, this has the side effect of removing
+ all type defns referring to unboxed types. Repeat step 2 until
+ a fixed point is reached.
+
+3. Make abstract all data/newtype defns which refer to an unknown
+ type. eg, data Word = MkW Word# becomes data Word, because
+ Word# is unknown. Hugs is happy to know about abstract boxed
+ Words, but not about Word#s.
+
+4. Step 2 could delete types referred to by values, instances and
+ classes. So filter all entities, and delete those referring to
+ unknown types _or_ classes. This could cause other entities
+ to become invalid, so iterate step 4 to a fixed point.
+
+ After step 4, the interfaces no longer contain anything
+ unpalatable to Hugs.
+
+5. Steps 1-4 operate purely on the iface syntax trees. We now start
+ creating symbol table entries. First, create a module table
+ entry for each interface, and locate and read in the corresponding
+ object file. This is done by the startGHCModule function.
+
+6. Traverse all interfaces. For each entity, create an entry in
+ the name, tycon, class or instance table, and fill in relevant
+ fields, but do not attempt to link tycon/class/instance/name uses
+ to their symbol table entries. This is done by the startGHC*
+ functions.
+
+7. Revisit all symbol table entries created in step 6. We should
+ now be able to replace all references to tycons/classes/instances/
+ names with the relevant symbol table entries. This is done by
+ the finishGHC* functions.
+
+8. Traverse all interfaces. For each iface, examine the export lists
+ and use it to build export lists in the module table. Do the
+ implicit 'import Prelude' thing if necessary. Finally, resolve
+ references in the object code for this module. This is done
+ by the finishGHCModule function.
+*/
+
/* --------------------------------------------------------------------------
* local function prototypes:
* ------------------------------------------------------------------------*/
-static Void startGHCValue Args((Int,VarId,Type));
-static Void finishGHCValue Args((VarId));
+static Void startGHCValue ( Int,VarId,Type );
+static Void finishGHCValue ( VarId );
-static Void startGHCSynonym Args((Int,Cell,List,Type));
-static Void finishGHCSynonym Args((Tycon));
+static Void startGHCSynonym ( Int,Cell,List,Type );
+static Void finishGHCSynonym ( Tycon );
-static Void startGHCClass Args((Int,List,Cell,List,List));
-static Void finishGHCClass Args((Class));
+static Void startGHCClass ( Int,List,Cell,List,List );
+static Class finishGHCClass ( Class );
-static Void startGHCInstance Args((Int,List,Pair,VarId));
-static Void finishGHCInstance Args((Inst));
+static Inst startGHCInstance ( Int,List,Pair,VarId );
+static Void finishGHCInstance ( Inst );
-static Void startGHCImports Args((ConId,List));
-static Void finishGHCImports Args((ConId,List));
+static Void startGHCImports ( ConId,List );
+static Void finishGHCImports ( ConId,List );
-static Void startGHCExports Args((ConId,List));
-static Void finishGHCExports Args((ConId,List));
+static Void startGHCExports ( ConId,List );
+static Void finishGHCExports ( ConId,List );
-static Void finishGHCModule Args((Module));
-static Void startGHCModule Args((Text, Int, Text));
-
-static Void startGHCDataDecl Args((Int,List,Cell,List,List));
-static Void finishGHCDataDecl ( ConId tyc );
-
-static Void startGHCNewType Args((Int,List,Cell,List,Cell));
-static Void finishGHCNewType ( ConId tyc );
+static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
+static Void finishGHCModule ( Cell );
+static Void startGHCModule ( Text );
+static Void startGHCDataDecl ( Int,List,Cell,List,List );
+static List finishGHCDataDecl ( ConId tyc );
/* Supporting stuff for {start|finish}GHCDataDecl */
-static List startGHCConstrs Args((Int,List,List));
-static Name startGHCSel Args((Int,Pair));
-static Name startGHCConstr Args((Int,Int,Triple));
-static Void finishGHCConstr Args((Name));
-
-static Void loadSharedLib Args((String));
+static List startGHCConstrs ( Int,List,List );
+static Name startGHCSel ( Int,Pair );
+static Name startGHCConstr ( Int,Int,Triple );
+static Void startGHCNewType ( Int,List,Cell,List,Cell );
+static Void finishGHCNewType ( ConId tyc );
-static Kinds tvsToKind Args((List));
-static Int arityFromType Args((Type));
-static Int arityInclDictParams Args((Type));
+static Kinds tvsToKind ( List );
+static Int arityFromType ( Type );
+static Int arityInclDictParams ( Type );
+static Bool allTypesKnown ( Type type,
+ List aktys /* [QualId] */,
+ ConId thisMod );
-static List ifTyvarsIn Args((Type));
-
-static Type tvsToOffsets Args((Int,Type,List));
-static Type conidcellsToTycons Args((Int,Type));
-
-static Void resolveReferencesInObjectModule Args((Module,Bool));
-static Bool validateOImage Args((void*, Int, Bool));
-static Void readSyms Args((Module,Bool));
-
-static void* lookupObjName ( char* );
+static List ifTyvarsIn ( Type );
+static Type tvsToOffsets ( Int,Type,List );
+static Type conidcellsToTycons ( Int,Type );
* Top-level interface processing
* ------------------------------------------------------------------------*/
-ZPair readInterface(String fname, Long fileSize)
+/* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
+static ConVarId getIEntityName ( Cell c )
+{
+ switch (whatIs(c)) {
+ case I_IMPORT: return NIL;
+ case I_INSTIMPORT: return NIL;
+ case I_EXPORT: return NIL;
+ case I_FIXDECL: return zthd3(unap(I_FIXDECL,c));
+ case I_INSTANCE: return NIL;
+ case I_TYPE: return zsel24(unap(I_TYPE,c));
+ case I_DATA: return zsel35(unap(I_DATA,c));
+ case I_NEWTYPE: return zsel35(unap(I_NEWTYPE,c));
+ case I_CLASS: return zsel35(unap(I_CLASS,c));
+ case I_VALUE: return zsnd3(unap(I_VALUE,c));
+ default: internal("getIEntityName");
+ }
+}
+
+
+/* Filter the contents of an interface, using the supplied predicate.
+ For flexibility, the predicate is passed as a second arg the value
+ extraArgs. This is a hack to get round the lack of partial applications
+ in C. Pred should not have any side effects. The dumpaction param
+ gives us the chance to print a message or some such for dumped items.
+ When a named entity is deleted, filterInterface also deletes the name
+ in the export lists.
+*/
+static Cell filterInterface ( Cell root,
+ Bool (*pred)(Cell,Cell),
+ Cell extraArgs,
+ Void (*dumpAction)(Cell) )
+{
+ List tops;
+ Cell iface = unap(I_INTERFACE,root);
+ List tops2 = NIL;
+ List deleted_ids = NIL; /* :: [ConVarId] */
+
+ for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
+ if (pred(hd(tops),extraArgs)) {
+ tops2 = cons( hd(tops), tops2 );
+ } else {
+ ConVarId deleted_id = getIEntityName ( hd(tops) );
+ if (nonNull(deleted_id))
+ deleted_ids = cons ( deleted_id, deleted_ids );
+ if (dumpAction)
+ dumpAction ( hd(tops) );
+ }
+ }
+ tops2 = reverse(tops2);
+
+ /* Clean up the export list now. */
+ for (tops=tops2; nonNull(tops); tops=tl(tops)) {
+ if (whatIs(hd(tops))==I_EXPORT) {
+ Cell exdecl = unap(I_EXPORT,hd(tops));
+ List exlist = zsnd(exdecl);
+ List exlist2 = NIL;
+ for (; nonNull(exlist); exlist=tl(exlist)) {
+ Cell ex = hd(exlist);
+ ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
+ assert (isCon(exid) || isVar(exid));
+ if (!varIsMember(textOf(exid),deleted_ids))
+ exlist2 = cons(ex, exlist2);
+ }
+ hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
+ }
+ }
+
+ return ap(I_INTERFACE, zpair(zfst(iface),tops2));
+}
+
+
+List /* of CONID */ getInterfaceImports ( Cell iface )
{
List tops;
List imports = NIL;
- ZPair iface = parseInterface(fname,fileSize);
- assert (whatIs(iface)==I_INTERFACE);
- for (tops = zsnd(snd(iface)); nonNull(tops); tops=tl(tops))
+ for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
if (whatIs(hd(tops)) == I_IMPORT) {
ZPair imp_decl = unap(I_IMPORT,hd(tops));
ConId m_to_imp = zfst(imp_decl);
if (textOf(m_to_imp) != findText("PrelGHC")) {
imports = cons(m_to_imp,imports);
- /* fprintf(stderr, "add iface %s\n", textToStr(textOf(m_to_imp))); */
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "add iface %s\n",
+ textToStr(textOf(m_to_imp)));
+# endif
}
}
- return zpair(iface,imports);
+ return imports;
+}
+
+
+/* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
+static List getExportDeclsInIFace ( Cell root )
+{
+ Cell iface = unap(I_INTERFACE,root);
+ List decls = zsnd(iface);
+ List exports = NIL;
+ List ds;
+ for (ds=decls; nonNull(ds); ds=tl(ds))
+ if (whatIs(hd(ds))==I_EXPORT)
+ exports = cons(hd(ds), exports);
+ return exports;
}
-static Bool elemExportList ( VarId nm, List exlist_list )
+/* Does t start with "$dm" ? */
+static Bool isIfaceDefaultMethodName ( Text t )
{
+ String s = textToStr(t);
+ return (s && s[0]=='$' && s[1]=='d' && s[2]=='m' && s[3]);
+}
+
+
+static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
+{
+ /* ife :: I_IMPORT..I_VALUE */
/* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
- Text tnm = textOf(nm);
- Int tlen = strlen(textToStr(tnm));
- List exlist;
- List t;
- Cell c;
+ Text tnm;
+ List exlist;
+ List t;
+ String s;
+
+ ConVarId ife_id = getIEntityName ( ife );
+
+ if (isNull(ife_id)) return TRUE;
+
+ tnm = textOf(ife_id);
+
+ /* Don't junk default methods, even tho the export list doesn't
+ mention them.
+ */
+ if (isIfaceDefaultMethodName(tnm)) goto retain;
/* for each export list ... */
for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
exlist = hd(exlist_list);
/* for each entity in an export list ... */
- for (t=exlist; nonNull(t); c=tl(t)) {
+ for (t=exlist; nonNull(t); t=tl(t)) {
if (isZPair(hd(t))) {
/* A pair, which means an export entry
of the form ClassName(foo,bar). */
- List subents = zsnd(hd(t));
+ List subents = cons(zfst(hd(t)),zsnd(hd(t)));
for (; nonNull(subents); subents=tl(subents))
- if (textOf(hd(subents)) == tnm) return TRUE;
+ if (textOf(hd(subents)) == tnm) goto retain;
} else {
/* Single name in the list. */
- if (textOf(hd(t)) == tnm) return TRUE;
+ if (textOf(hd(t)) == tnm) goto retain;
}
}
}
- /* fprintf ( stderr, "elemExportList %s\n", textToStr(textOf(nm)) ); */
+# ifdef DEBUG_IFACE
+ fprintf ( stderr, " dump %s\n", textToStr(tnm) );
+# endif
return FALSE;
+
+ retain:
+# ifdef DEBUG_IFACE
+ fprintf ( stderr, " retain %s\n", textToStr(tnm) );
+# endif
+ return TRUE;
}
-/* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
-static List getExportDeclsInIFace ( Cell root )
+static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
{
- Cell iface = unap(I_INTERFACE,root);
- ConId iname = zfst(iface);
- List decls = zsnd(iface);
- List exports = NIL;
- List ds;
- for (ds=decls; nonNull(ds); ds=tl(ds))
- if (whatIs(hd(ds))==I_EXPORT)
- exports = cons(hd(ds), exports);
- return exports;
+ /* ife_id :: ConId */
+ /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
+ Text tnm;
+ List exlist;
+ List t;
+
+ assert (isCon(ife_id));
+ tnm = textOf(ife_id);
+
+ /* for each export list ... */
+ for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
+ exlist = hd(exlist_list);
+
+ /* for each entity in an export list ... */
+ for (t=exlist; nonNull(t); t=tl(t)) {
+ if (isZPair(hd(t))) {
+ /* A pair, which means an export entry
+ of the form ClassName(foo,bar). */
+ if (textOf(zfst(hd(t))) == tnm) return FALSE;
+ } else {
+ if (textOf(hd(t)) == tnm) return TRUE;
+ }
+ }
+ }
+ internal("isExportedAbstractly");
+ return FALSE; /*notreached*/
}
-/* Remove value bindings not mentioned in any of the export lists. */
-static Cell cleanIFace ( Cell root )
+/* Remove entities not mentioned in any of the export lists. */
+static Cell deleteUnexportedIFaceEntities ( Cell root )
{
- Cell c;
- Cell entity;
Cell iface = unap(I_INTERFACE,root);
ConId iname = zfst(iface);
List decls = zsnd(iface);
List exlist_list = NIL;
List t;
- fprintf(stderr, "\ncleaniface: %s\n", textToStr(textOf(iname)));
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
+# endif
exlist_list = getExportDeclsInIFace ( root );
/* exlist_list :: [I_EXPORT] */
hd(t) = zsnd(unap(I_EXPORT,hd(t)));
/* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
+#if 0
if (isNull(exlist_list)) {
ERRMSG(0) "Can't find any export lists in interface file"
EEND;
}
+#endif
- decls2 = NIL;
- for (; nonNull(decls); decls=tl(decls)) {
- entity = hd(decls);
- if (whatIs(entity) != I_VALUE) {
- decls2 = cons(entity, decls2);
- } else
- if (elemExportList(zsnd3(unap(I_VALUE,entity)), exlist_list)) {
- decls2 = cons(entity, decls2);
- fprintf ( stderr, " retain %s\n",
- textToStr(textOf(zsnd3(unap(I_VALUE,entity)))));
- } else {
- fprintf ( stderr, " dump %s\n",
- textToStr(textOf(zsnd3(unap(I_VALUE,entity)))));
+ return filterInterface ( root, isExportedIFaceEntity,
+ exlist_list, NULL );
+}
+
+
+/* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
+static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
+{
+ Cell iface = unap(I_INTERFACE,root);
+ Text mname = textOf(zfst(iface));
+ List defns = zsnd(iface);
+ for (; nonNull(defns); defns = tl(defns)) {
+ Cell defn = hd(defns);
+ Cell what = whatIs(defn);
+ if (what==I_TYPE || what==I_DATA
+ || what==I_NEWTYPE || what==I_CLASS) {
+ QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
+ if (!qualidIsMember ( q, aktys ))
+ aktys = cons ( q, aktys );
+ }
+ }
+ return aktys;
+}
+
+
+static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
+{
+ ConVarId id = getIEntityName ( entity );
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,
+ "dumping %s because of unknown type(s)\n",
+ isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
+# endif
+}
+
+
+/* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
+/* mod is the current module being processed -- so we can qualify unqual'd
+ names. Strange calling convention for aktys and mod is so we can call this
+ from filterInterface.
+*/
+static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
+{
+ List t, u;
+ List aktys = zfst ( aktys_mod );
+ ConId mod = zsnd ( aktys_mod );
+ switch (whatIs(entity)) {
+ case I_IMPORT:
+ case I_INSTIMPORT:
+ case I_EXPORT:
+ case I_FIXDECL:
+ return TRUE;
+ case I_INSTANCE: {
+ Cell inst = unap(I_INSTANCE,entity);
+ List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
+ Type cls = zsel35 ( inst ); /* :: Type */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
+ if (!allTypesKnown(cls, aktys,mod)) return FALSE;
+ return TRUE;
+ }
+ case I_TYPE:
+ return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
+ case I_DATA: {
+ Cell data = unap(I_DATA,entity);
+ List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
+ List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
+ for (t = constrs; nonNull(t); t=tl(t))
+ for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
+ if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
+ return TRUE;
+ }
+ case I_NEWTYPE: {
+ Cell newty = unap(I_NEWTYPE,entity);
+ List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
+ ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
+ if (nonNull(constr)
+ && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
+ return TRUE;
}
+ case I_CLASS: {
+ Cell klass = unap(I_CLASS,entity);
+ List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
+ List sigs = zsel55(klass); /* :: [((VarId,Type))] */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
+ for (t = sigs; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
+ return TRUE;
+ }
+ case I_VALUE:
+ return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
+ default:
+ internal("ifentityAllTypesKnown");
+ }
+}
+
+
+/* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
+/* mod is the current module being processed -- so we can qualify unqual'd
+ names. Strange calling convention for aktys and mod is so we can call this
+ from filterInterface.
+*/
+static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
+{
+ List t, u;
+ List aktys = zfst ( aktys_mod );
+ ConId mod = zsnd ( aktys_mod );
+ if (whatIs(entity) != I_TYPE) {
+ return TRUE;
+ } else {
+ return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
}
+}
+
- return ap(I_INTERFACE, zpair(iname, reverse(decls2)));
+static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
+{
+ ConVarId id = getIEntityName ( entity );
+ assert (whatIs(entity)==I_TYPE);
+ assert (isCon(id));
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,
+ "dumping type %s because of unknown tycon(s)\n",
+ textToStr(textOf(id)) );
+# endif
}
-/* ifaces_outstanding holds a list of parsed interfaces
- for which we need to load objects and create symbol
- table entries.
+/* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
*/
-Void processInterfaces ( void )
+static List abstractifyExDecl ( Cell root, ConId toabs )
+{
+ ZPair exdecl = unap(I_EXPORT,root);
+ List exlist = zsnd(exdecl);
+ List res = NIL;
+ for (; nonNull(exlist); exlist = tl(exlist)) {
+ if (isZPair(hd(exlist))
+ && textOf(toabs) == textOf(zfst(hd(exlist)))) {
+ /* it's toabs, exported non-abstractly */
+ res = cons ( zfst(hd(exlist)), res );
+ } else {
+ res = cons ( hd(exlist), res );
+ }
+ }
+ return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
+}
+
+
+static Void ppModule ( Text modt )
+{
+# ifdef DEBUG_IFACE
+ fflush(stderr); fflush(stdout);
+ fprintf(stderr, "---------------- MODULE %s ----------------\n",
+ textToStr(modt) );
+# endif
+}
+
+
+static void* ifFindItblFor ( Name n )
+{
+ /* n is a constructor for which we want to find the GHC info table.
+ First look for a _con_info symbol. If that doesn't exist, _and_
+ this is a nullary constructor, then it's safe to look for the
+ _static_info symbol instead.
+ */
+ void* p;
+ char buf[1000];
+ Text t;
+
+ sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_info"),
+ textToStr( module(name(n).mod).text ),
+ textToStr( name(n).text ) );
+ t = enZcodeThenFindText(buf);
+ p = lookupOTabName ( name(n).mod, textToStr(t) );
+
+ if (p) return p;
+
+ if (name(n).arity == 0) {
+ sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"),
+ textToStr( module(name(n).mod).text ),
+ textToStr( name(n).text ) );
+ t = enZcodeThenFindText(buf);
+ p = lookupOTabName ( name(n).mod, textToStr(t) );
+ if (p) return p;
+ }
+
+ ERRMSG(0) "Can't find info table %s", textToStr(t)
+ EEND;
+}
+
+
+void ifLinkConstrItbl ( Name n )
+{
+ /* name(n) is either a constructor or a field name.
+ If the latter, ignore it. If it is a non-nullary constructor,
+ find its info table in the object code. If it's nullary,
+ we can skip the info table, since all accesses will go via
+ the _closure label.
+ */
+ if (islower(textToStr(name(n).text)[0])) return;
+ if (name(n).arity == 0) return;
+ name(n).itbl = ifFindItblFor(n);
+}
+
+
+static void ifSetClassDefaultsAndDCon ( Class c )
+{
+ char buf[100];
+ char buf2[1000];
+ String s;
+ Name n;
+ Text t;
+ void* p;
+ List defs; /* :: [Name] */
+ List mems; /* :: [Name] */
+ Module m;
+ assert(isNull(cclass(c).defaults));
+
+ /* Create the defaults list by more-or-less cloning the members list. */
+ defs = NIL;
+ for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
+ strcpy(buf, "$dm");
+ s = textToStr( name(hd(mems)).text );
+ assert(strlen(s) < 95);
+ strcat(buf, s);
+ n = findNameInAnyModule(findText(buf));
+ assert (nonNull(n));
+ defs = cons(n,defs);
+ }
+ defs = rev(defs);
+ cclass(c).defaults = defs;
+
+ /* Create a name table entry for the dictionary datacon.
+ Interface files don't mention them, so it had better not
+ already be present.
+ */
+ strcpy(buf, ":D");
+ s = textToStr( cclass(c).text );
+ assert( strlen(s) < 96 );
+ strcat(buf, s);
+ t = findText(buf);
+ n = findNameInAnyModule(t);
+ assert(isNull(n));
+
+ m = cclass(c).mod;
+ n = newName(t,NIL);
+ name(n).mod = m;
+ name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
+ name(n).number = cfunNo(0);
+ cclass(c).dcon = n;
+
+ /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
+ Because this happens right at the end of loading, we know
+ that we should actually be able to find the symbol in this
+ module's object symbol table. Except that if the dictionary
+ has arity 1, we don't bother, since it will be represented as
+ a newtype and not as a data, so its itbl can remain NULL.
+ */
+ if (name(n).arity == 1) {
+ name(n).itbl = NULL;
+ name(n).defn = nameId;
+ } else {
+ p = ifFindItblFor ( n );
+ name(n).itbl = p;
+ }
+}
+
+
+void processInterfaces ( List /* of CONID */ iface_modnames )
{
List tmp;
List xs;
Text mname;
List decls;
Module mod;
+ List all_known_types;
+ Int num_known_types;
+ List cls_list; /* :: List Class */
+ List constructor_list; /* :: List Name */
+
+ List ifaces = NIL; /* :: List I_INTERFACE */
+ if (isNull(iface_modnames)) return;
+
+# ifdef DEBUG_IFACE
fprintf ( stderr,
"processInterfaces: %d interfaces to process\n",
length(ifaces_outstanding) );
+# endif
+
+ for (xs = iface_modnames; nonNull(xs); xs=tl(xs)) {
+ mod = findModule(textOf(hd(xs)));
+ assert(nonNull(mod));
+ assert(module(mod).mode == FM_OBJECT);
+ ifaces = cons ( module(mod).tree, ifaces );
+ }
+ ifaces = reverse(ifaces);
+
+ /* Clean up interfaces -- dump non-exported value, class, type decls */
+ for (xs = ifaces; nonNull(xs); xs = tl(xs))
+ hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
- /* Clean up interfaces -- dump useless value bindings */
- tmp = NIL;
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
- tr = hd(xs);
- iface = zfst3(tr);
- nameObj = zsnd3(tr);
- sizeObj = zthd3(tr);
- tmp = cons( ztriple(cleanIFace(iface),nameObj,sizeObj), tmp );
+ /* Iteratively delete any type declarations which refer to unknown
+ tycons.
+ */
+ num_known_types = 999999999;
+ while (TRUE) {
+ Int i;
+
+ /* Construct a list of all known tycons. This is a list of QualIds.
+ Unfortunately it also has to contain all known class names, since
+ allTypesKnown cannot distinguish between tycons and classes -- a
+ deficiency of the iface abs syntax.
+ */
+ all_known_types = getAllKnownTyconsAndClasses();
+ for (xs = ifaces; nonNull(xs); xs=tl(xs))
+ all_known_types
+ = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
+
+ /* Have we reached a fixed point? */
+ i = length(all_known_types);
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,
+ "\n============= %d known types =============\n", i );
+# endif
+ if (num_known_types == i) break;
+ num_known_types = i;
+
+ /* Delete all entities which refer to unknown tycons. */
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
+ assert(nonNull(mod));
+ hd(xs) = filterInterface ( hd(xs),
+ ifTypeDoesntRefUnknownTycon,
+ zpair(all_known_types,mod),
+ ifTypeDoesntRefUnknownTycon_dumpmsg );
+ }
}
- ifaces_outstanding = reverse(tmp);
- tmp = NIL;
- /* Allocate module table entries and read in object code. */
+ /* Now abstractify any datas and newtypes which refer to unknown tycons
+ -- including, of course, the type decls just deleted.
+ */
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ List absify = NIL; /* :: [ConId] */
+ ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
+ ConId mod = zfst(iface);
+ List aktys = all_known_types; /* just a renaming */
+ List es,t,u;
+ List exlist_list;
+
+ /* Compute into absify the list of all ConIds (tycons) we need to
+ abstractify.
+ */
+ for (es = zsnd(iface); nonNull(es); es=tl(es)) {
+ Cell ent = hd(es);
+ Bool allKnown = TRUE;
+
+ if (whatIs(ent)==I_DATA) {
+ Cell data = unap(I_DATA,ent);
+ List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
+ List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
+ for (t = constrs; nonNull(t); t=tl(t))
+ for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
+ if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
+ }
+ else if (whatIs(ent)==I_NEWTYPE) {
+ Cell newty = unap(I_NEWTYPE,ent);
+ List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
+ ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
+ if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
+ }
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
- tr = hd(xs);
- iface = unap(I_INTERFACE,zfst3(tr));
- nameObj = zsnd3(tr);
- sizeObj = zthd3(tr);
- mname = textOf(zfst(iface));
- startGHCModule ( mname, intOf(sizeObj), nameObj );
+ if (!allKnown) {
+ absify = cons ( getIEntityName(ent), absify );
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,
+ "abstractifying %s because it uses an unknown type\n",
+ textToStr(textOf(getIEntityName(ent))) );
+# endif
+ }
+ }
+
+ /* mark in exports as abstract all names in absify (modifies iface) */
+ for (; nonNull(absify); absify=tl(absify)) {
+ ConId toAbs = hd(absify);
+ for (es = zsnd(iface); nonNull(es); es=tl(es)) {
+ if (whatIs(hd(es)) != I_EXPORT) continue;
+ hd(es) = abstractifyExDecl ( hd(es), toAbs );
+ }
+ }
+
+ /* For each data/newtype in the export list marked as abstract,
+ remove the constructor lists. This catches all abstractification
+ caused by the code above, and it also catches tycons which really
+ were exported abstractly.
+ */
+
+ exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
+ /* exlist_list :: [I_EXPORT] */
+ for (t=exlist_list; nonNull(t); t=tl(t))
+ hd(t) = zsnd(unap(I_EXPORT,hd(t)));
+ /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
+
+ for (es = zsnd(iface); nonNull(es); es=tl(es)) {
+ Cell ent = hd(es);
+ if (whatIs(ent)==I_DATA
+ && isExportedAbstractly ( getIEntityName(ent),
+ exlist_list )) {
+ Cell data = unap(I_DATA,ent);
+ data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
+ zsel45(data), NIL /* the constr list */ );
+ hd(es) = ap(I_DATA,data);
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "abstractify data %s\n",
+ textToStr(textOf(getIEntityName(ent))) );
+# endif
+ }
+ else if (whatIs(ent)==I_NEWTYPE
+ && isExportedAbstractly ( getIEntityName(ent),
+ exlist_list )) {
+ Cell data = unap(I_NEWTYPE,ent);
+ data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
+ zsel45(data), NIL /* the constr-type pair */ );
+ hd(es) = ap(I_NEWTYPE,data);
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "abstractify newtype %s\n",
+ textToStr(textOf(getIEntityName(ent))) );
+# endif
+ }
+ }
+
+ /* We've finally finished mashing this iface. Update the iface list. */
+ hd(xs) = ap(I_INTERFACE,iface);
+ }
+
+
+ /* At this point, the interfaces are cleaned up so that no type, data or
+ newtype defn refers to a non-existant type. However, there still may
+ be value defns, classes and instances which refer to unknown types.
+ Delete iteratively until a fixed point is reached.
+ */
+# ifdef DEBUG_IFACE
+ fprintf(stderr,"\n");
+# endif
+ num_known_types = 999999999;
+ while (TRUE) {
+ Int i;
+
+ /* Construct a list of all known tycons. This is a list of QualIds.
+ Unfortunately it also has to contain all known class names, since
+ allTypesKnown cannot distinguish between tycons and classes -- a
+ deficiency of the iface abs syntax.
+ */
+ all_known_types = getAllKnownTyconsAndClasses();
+ for (xs = ifaces; nonNull(xs); xs=tl(xs))
+ all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
+
+ /* Have we reached a fixed point? */
+ i = length(all_known_types);
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,
+ "\n------------- %d known types -------------\n", i );
+# endif
+ if (num_known_types == i) break;
+ num_known_types = i;
+
+ /* Delete all entities which refer to unknown tycons. */
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
+ assert(nonNull(mod));
+
+ hd(xs) = filterInterface ( hd(xs),
+ ifentityAllTypesKnown,
+ zpair(all_known_types,mod),
+ ifentityAllTypesKnown_dumpmsg );
+ }
}
+
+ /* Allocate module table entries and read in object code. */
+ for (xs=ifaces; nonNull(xs); xs=tl(xs))
+ startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))) );
+
+
/* Now work through the decl lists of the modules, and call the
startGHC* functions on the entities. This creates names in
various tables but doesn't bind them to anything.
*/
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
- tr = hd(xs);
- iface = unap(I_INTERFACE,zfst3(tr));
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ iface = unap(I_INTERFACE,hd(xs));
mname = textOf(zfst(iface));
mod = findModule(mname);
if (isNull(mod)) internal("processInterfaces(4)");
setCurrModule(mod);
+ ppModule ( module(mod).text );
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
break;
}
case I_INSTANCE: {
+ /* Trying to find the instance table location allocated by
+ startGHCInstance in subsequent processing is a nightmare, so
+ cache it on the tree.
+ */
Cell instance = unap(I_INSTANCE,decl);
- startGHCInstance ( zsel14(instance), zsel24(instance),
- zsel34(instance), zsel44(instance) );
+ Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
+ zsel35(instance), zsel45(instance) );
+ hd(decls) = ap(I_INSTANCE,
+ z5ble( zsel15(instance), zsel25(instance),
+ zsel35(instance), zsel45(instance), in ));
break;
}
case I_TYPE: {
}
}
- fprintf(stderr, "frambozenvla\n" );exit(1);
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\n============================"
+ "=============================\n");
+ fprintf(stderr, "=============================="
+ "===========================\n");
+# endif
/* Traverse again the decl lists of the modules, this time
- calling the finishGHC* functions. But don't try process
+ calling the finishGHC* functions. But don't process
the export lists; those must wait for later.
*/
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
- tr = hd(xs);
- iface = unap(I_INTERFACE,zfst3(tr));
+ cls_list = NIL;
+ constructor_list = NIL;
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ iface = unap(I_INTERFACE,hd(xs));
mname = textOf(zfst(iface));
mod = findModule(mname);
if (isNull(mod)) internal("processInterfaces(3)");
setCurrModule(mod);
+ ppModule ( module(mod).text );
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
break;
}
case I_FIXDECL: {
+ Cell fixdecl = unap(I_FIXDECL,decl);
+ finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
break;
}
case I_INSTANCE: {
Cell instance = unap(I_INSTANCE,decl);
- finishGHCInstance ( zsel34(instance) );
+ finishGHCInstance ( zsel55(instance) );
break;
}
case I_TYPE: {
break;
}
case I_DATA: {
- Cell ddecl = unap(I_DATA,decl);
- finishGHCDataDecl ( zsel35(ddecl) );
+ Cell ddecl = unap(I_DATA,decl);
+ List constrs = finishGHCDataDecl ( zsel35(ddecl) );
+ constructor_list = dupOnto ( constrs, constructor_list );
break;
}
case I_NEWTYPE: {
break;
}
case I_CLASS: {
- Cell klass = unap(I_CLASS,decl);
- finishGHCClass ( zsel35(klass) );
+ Cell klass = unap(I_CLASS,decl);
+ Class cls = finishGHCClass ( zsel35(klass) );
+ cls_list = cons(cls,cls_list);
break;
}
case I_VALUE: {
}
}
}
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\n+++++++++++++++++++++++++++++"
+ "++++++++++++++++++++++++++++\n");
+ fprintf(stderr, "+++++++++++++++++++++++++++++++"
+ "++++++++++++++++++++++++++\n");
+# endif
/* Build the module(m).export lists for each module, by running
through the export lists in the iface. Also, do the implicit
'import Prelude' thing. And finally, do the object code
linking.
*/
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs))
+ for (xs = ifaces; nonNull(xs); xs = tl(xs))
finishGHCModule(hd(xs));
+ mapProc(visitClass,cls_list);
+ mapProc(ifSetClassDefaultsAndDCon,cls_list);
+ mapProc(ifLinkConstrItbl,constructor_list);
+
/* Finished! */
ifaces_outstanding = NIL;
}
* Modules
* ------------------------------------------------------------------------*/
-Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
+static void startGHCModule_errMsg ( char* msg )
{
- FILE* f;
- void* img;
-
- Module m = findModule(mname);
- if (isNull(m)) {
- m = newModule(mname);
- fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
- textToStr(mname), sizeObj );
- } else if (m != modulePrelude) {
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
- EEND;
- }
+ fprintf ( stderr, "object error: %s\n", msg );
+}
- img = malloc ( sizeObj );
- if (!img) {
- ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
- textToStr(mname)
+static void* startGHCModule_clientLookup ( char* sym )
+{
+# ifdef DEBUG_IFACE
+ /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
+# endif
+ return lookupObjName ( sym );
+}
+
+static int /*Bool*/ startGHCModule_clientWantsSymbol ( char* sym )
+{
+ if (strcmp(sym,"ghc_cc_ID")==0) return 0;
+ return 1;
+}
+
+static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
+{
+ ObjectCode* oc
+ = ocNew ( startGHCModule_errMsg,
+ startGHCModule_clientLookup,
+ startGHCModule_clientWantsSymbol,
+ objNm, objSz );
+
+ if (!oc) {
+ ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
EEND;
}
- f = fopen( textToStr(nameObj), "rb" );
- if (!f) {
- /* Really, this shouldn't happen, since makeStackEntry ensures the
- object is available. Nevertheless ...
- */
- ERRMSG(0) "Object file \"%s\" can't be opened to read -- oops!",
- &(textToStr(nameObj)[0])
+ if (!ocLoadImage(oc,VERBOSE)) {
+ ERRMSG(0) "Reading of object file \"%s\" failed", objNm
EEND;
}
- if (sizeObj != fread ( img, 1, sizeObj, f)) {
- ERRMSG(0) "Read of object file \"%s\" failed", textToStr(nameObj)
+ if (!ocVerifyImage(oc,VERBOSE)) {
+ ERRMSG(0) "Validation of object file \"%s\" failed", objNm
EEND;
}
- if (!validateOImage(img,sizeObj,VERBOSE)) {
- ERRMSG(0) "Validation of object file \"%s\" failed",
- textToStr(nameObj)
+ if (!ocGetNames(oc,VERBOSE)) {
+ ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
EEND;
}
-
- assert(!module(m).oImage);
- module(m).oImage = img;
+ return oc;
+}
- readSyms(m,VERBOSE);
+static Void startGHCModule ( Text mname )
+{
+ List xts;
+ Module m = findModule(mname);
+ assert(nonNull(m));
- /* setCurrModule(m); */
+# ifdef DEBUG_IFACE
+ fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
+ textToStr(mname), module(m).objSize );
+# endif
+ if (module(m).fake)
+ module(m).fake = FALSE;
+
+ /* Get hold of the primary object for the module. */
+ module(m).object
+ = startGHCModule_partial_load ( textToStr(module(m).objName),
+ module(m).objSize );
+
+ /* and any extras ... */
+ for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
+ Int size;
+ ObjectCode* oc;
+ Text xtt = hd(xts);
+ String nm = getExtraObjectInfo (
+ textToStr(module(m).objName),
+ textToStr(xtt),
+ &size
+ );
+ if (size == -1) {
+ ERRMSG(0) "Can't find extra object file \"%s\"", nm
+ EEND;
+ }
+ oc = startGHCModule_partial_load ( nm, size );
+ oc->next = module(m).objectExtras;
+ module(m).objectExtras = oc;
+ }
}
/* For the module mod, augment both the export environment (.exports)
and the eval environment (.names, .tycons, .classes)
with the symbols mentioned in exlist. We don't actually need
- to touch the eval environment, since previous processing of the
+ to modify the names, tycons, classes or instances in the eval
+ environment, since previous processing of the
top-level decls in the iface should have done this already.
mn is the module mentioned in the export list; it is the "original"
refer to the original module in which a symbol was defined, rather
than to some module it has been imported into and then re-exported.
- Also do an implicit 'import Prelude' thingy for the module.
+ We take the policy that if something mentioned in an export list
+ can't be found in the symbol tables, it is simply ignored. After all,
+ previous processing of the iface syntax trees has already removed
+ everything which Hugs can't handle, so if there is mention of these
+ things still lurking in export lists somewhere, about the only thing
+ to do is to ignore it.
+
+ Also do an implicit 'import Prelude' thingy for the module,
+ if appropriate.
*/
-Void finishGHCModule ( Cell root )
+
+
+static Void finishGHCModule ( Cell root )
{
/* root :: I_INTERFACE */
- Cell iface = unap(I_INTERFACE,root);
- ConId iname = zfst(iface);
- List decls = zsnd(iface);
- Module mod = findModule(textOf(iname));
- List decls2 = NIL;
- List exlist_list = NIL;
- List t;
+ Cell iface = unap(I_INTERFACE,root);
+ ConId iname = zfst(iface);
+ Module mod = findModule(textOf(iname));
+ List exlist_list = NIL;
+ List t;
+ ObjectCode* oc;
- fprintf(stderr, "\ncleaniface: %s\n", textToStr(textOf(iname)));
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
+# endif
if (isNull(mod)) internal("finishExports(1)");
setCurrModule(mod);
exlist_list = getExportDeclsInIFace ( root );
/* exlist_list :: [I_EXPORT] */
- for (t=exlist_list; nonNull(t); t=tl(t))
- hd(t) = zsnd(unap(I_EXPORT,hd(t)));
- /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
-
for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
- List exlist = hd(exlist_list);
+ ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
+ ConId exmod = zfst(exdecl);
+ List exlist = zsnd(exdecl);
/* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
+
for (; nonNull(exlist); exlist=tl(exlist)) {
- List subents;
- Cell c;
- Cell ex = hd(exlist);
+ Bool abstract;
+ List subents;
+ Cell c;
+ QualId q;
+ Cell ex = hd(exlist);
switch (whatIs(ex)) {
case VARIDCELL: /* variable */
- c = findName ( textOf(ex) );
- assert(nonNull(c));
- fprintf(stderr, "var %s\n", textToStr(textOf(ex)) );
+ q = mkQualId(exmod,ex);
+ c = findQualNameWithoutConsultingExportList ( q );
+ if (isNull(c)) goto notfound;
+# ifdef DEBUG_IFACE
+ fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
+# endif
module(mod).exports = cons(c, module(mod).exports);
+ addName(c);
break;
case CONIDCELL: /* non data tycon */
- c = findTycon ( textOf(ex) );
- assert(nonNull(c));
- fprintf(stderr, "non data tycon %s\n", textToStr(textOf(ex)) );
- module(mod).exports = cons(c, module(mod).exports);
+ q = mkQualId(exmod,ex);
+ c = findQualTyconWithoutConsultingExportList ( q );
+ if (isNull(c)) goto notfound;
+# ifdef DEBUG_IFACE
+ fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
+# endif
+ module(mod).exports = cons(pair(c,NIL), module(mod).exports);
+ addTycon(c);
break;
case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
subents = zsnd(ex); /* :: [ConVarId] */
ex = zfst(ex); /* :: ConId */
- c = findTycon ( textOf(ex) );
+ q = mkQualId(exmod,ex);
+ c = findQualTyconWithoutConsultingExportList ( q );
if (nonNull(c)) { /* data */
- fprintf(stderr, "data %s = ", textToStr(textOf(ex)) );
- module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
- for (; nonNull(subents); subents = tl(subents)) {
- Cell ent2 = hd(subents);
- assert(isCon(ent2));
- c = findName ( textOf(ent2) );
- fprintf(stderr, "%s ", textToStr(name(c).text));
- assert(nonNull(c));
- module(mod).exports = cons(c, module(mod).exports);
+# ifdef DEBUG_IFACE
+ fprintf(stderr, " data/newtype %s = { ",
+ textToStr(textOf(ex)) );
+# endif
+ assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
+ abstract = isNull(tycon(c).defn);
+ /* This data/newtype could be abstract even tho the export list
+ says to export it non-abstractly. That happens if it was
+ imported from some other module and is now being re-exported,
+ and previous cleanup phases have abstractified it in the
+ original (defining) module.
+ */
+ if (abstract) {
+ module(mod).exports = cons(pair(c,NIL), module(mod).exports);
+ addTycon(c);
+# ifdef DEBUG_IFACE
+ fprintf ( stderr, "(abstract) ");
+# endif
+ } else {
+ module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ addTycon(c);
+ for (; nonNull(subents); subents = tl(subents)) {
+ Cell ent2 = hd(subents);
+ assert(isCon(ent2) || isVar(ent2));
+ /* isVar since could be a field name */
+ q = mkQualId(exmod,ent2);
+ c = findQualNameWithoutConsultingExportList ( q );
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "%s ", textToStr(name(c).text));
+# endif
+ assert(nonNull(c));
+ /* module(mod).exports = cons(c, module(mod).exports); */
+ addName(c);
+ }
}
- fprintf(stderr, "\n" );
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "}\n" );
+# endif
} else { /* class */
- c = findClass ( textOf(ex) );
- assert(nonNull(c));
- fprintf(stderr, "class %s where ", textToStr(textOf(ex)) );
+ q = mkQualId(exmod,ex);
+ c = findQualClassWithoutConsultingExportList ( q );
+ if (isNull(c)) goto notfound;
+# ifdef DEBUG_IFACE
+ fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
+# endif
module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ addClass(c);
for (; nonNull(subents); subents = tl(subents)) {
Cell ent2 = hd(subents);
assert(isVar(ent2));
- c = findName ( textOf(ent2) );
+ q = mkQualId(exmod,ent2);
+ c = findQualNameWithoutConsultingExportList ( q );
+# ifdef DEBUG_IFACE
fprintf(stderr, "%s ", textToStr(name(c).text));
- assert(nonNull(c));
- module(mod).exports = cons(c, module(mod).exports);
+# endif
+ if (isNull(c)) goto notfound;
+ /* module(mod).exports = cons(c, module(mod).exports); */
+ addName(c);
}
- fprintf(stderr, "\n" );
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "}\n" );
+# endif
}
break;
internal("finishExports(2)");
} /* switch */
+ continue; /* so notfound: can be placed after this */
+
+ notfound:
+ /* q holds what ain't found */
+ assert(whatIs(q)==QUALIDENT);
+# ifdef DEBUG_IFACE
+ fprintf( stderr, " ------ IGNORED: %s.%s\n",
+ textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
+# endif
+ continue;
}
}
+#if 0
if (preludeLoaded) {
/* do the implicit 'import Prelude' thing */
List pxs = module(modulePrelude).exports;
}
}
}
+#endif
/* Last, but by no means least ... */
- resolveReferencesInObjectModule ( mod, VERBOSE );
+ if (!ocResolve(module(mod).object,VERBOSE))
+ internal("finishGHCModule: object resolution failed");
+
+ for (oc=module(mod).objectExtras; oc; oc=oc->next) {
+ if (!ocResolve(oc, VERBOSE))
+ internal("finishGHCModule: extra object resolution failed");
+ }
}
* Exports
* ------------------------------------------------------------------------*/
-Void startGHCExports ( ConId mn, List exlist )
+static Void startGHCExports ( ConId mn, List exlist )
{
# ifdef DEBUG_IFACE
- printf("startGHCExports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
-Void finishGHCExports ( ConId mn, List exlist )
+static Void finishGHCExports ( ConId mn, List exlist )
{
# ifdef DEBUG_IFACE
- printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
* Imports
* ------------------------------------------------------------------------*/
-Void startGHCImports ( ConId mn, List syms )
+static Void startGHCImports ( ConId mn, List syms )
/* nm the module to import from */
/* syms [ConId | VarId] -- the names to import */
{
# ifdef DEBUG_IFACE
- printf("startGHCImports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
-Void finishGHCImports ( ConId nm, List syms )
+static Void finishGHCImports ( ConId nm, List syms )
/* nm the module to import from */
/* syms [ConId | VarId] -- the names to import */
{
# ifdef DEBUG_IFACE
- printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
+ fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
# endif
/* Nothing to do. */
}
/* --------------------------------------------------------------------------
+ * Fixity decls
+ * ------------------------------------------------------------------------*/
+
+static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
+{
+ Int p = intOf(prec);
+ Int a = intOf(assoc);
+ Name n = findName(textOf(name));
+ assert (nonNull(n));
+ name(n).syntax = mkSyntax ( a, p );
+}
+
+
+/* --------------------------------------------------------------------------
* Vars (values)
* ------------------------------------------------------------------------*/
-void startGHCValue ( Int line, VarId vid, Type ty )
+/* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
+ { C1 a } -> { C2 b } -> T into
+ ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
+*/
+static Type dictapsToQualtype ( Type ty )
+{
+ List pieces = NIL;
+ List preds, dictaps;
+
+ /* break ty into pieces at the top-level arrows */
+ while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
+ pieces = cons ( arg(fun(ty)), pieces );
+ ty = arg(ty);
+ }
+ pieces = cons ( ty, pieces );
+ pieces = reverse ( pieces );
+
+ dictaps = NIL;
+ while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
+ dictaps = cons ( hd(pieces), dictaps );
+ pieces = tl(pieces);
+ }
+
+ /* dictaps holds the predicates, backwards */
+ /* pieces holds the remainder of the type, forwards */
+ assert(nonNull(pieces));
+ pieces = reverse(pieces);
+ ty = hd(pieces);
+ pieces = tl(pieces);
+ for (; nonNull(pieces); pieces=tl(pieces))
+ ty = fn(hd(pieces),ty);
+
+ preds = NIL;
+ for (; nonNull(dictaps); dictaps=tl(dictaps)) {
+ Cell da = hd(dictaps);
+ QualId cl = fst(unap(DICTAP,da));
+ Cell arg = snd(unap(DICTAP,da));
+ preds = cons ( pair(cl,arg), preds );
+ }
+
+ if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
+ return ty;
+}
+
+
+
+static void startGHCValue ( Int line, VarId vid, Type ty )
{
Name n;
List tmp, tvs;
Text v = textOf(vid);
# ifdef DEBUG_IFACE
- printf("\nbegin startGHCValue %s\n", textToStr(v));
+ fprintf(stderr,"begin startGHCValue %s\n", textToStr(v));
# endif
+ line = intOf(line);
n = findName(v);
- if (nonNull(n)) {
- ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
+ if (nonNull(n) && name(n).defn != PREDEFINED) {
+ ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
EEND;
}
- n = newName(v,NIL);
+ if (isNull(n)) n = newName(v,NIL);
+
+ ty = dictapsToQualtype(ty);
tvs = ifTyvarsIn(ty);
for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
ty = mkPolyType(tvsToKind(tvs),ty);
ty = tvsToOffsets(line,ty,tvs);
-
- /* prepare for finishGHCValue */
name(n).type = ty;
name(n).arity = arityInclDictParams(ty);
name(n).line = line;
-# ifdef DEBUG_IFACE
- printf("end startGHCValue %s\n", textToStr(v));
-# endif
+ name(n).defn = NIL;
}
-void finishGHCValue ( VarId vid )
+static void finishGHCValue ( VarId vid )
{
Name n = findName ( textOf(vid) );
Int line = name(n).line;
- Type ty = name(n).type;
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin finishGHCValue %s\n", textToStr(name(n).text) );
+ fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
# endif
assert(currentModule == name(n).mod);
- //setCurrModule(name(n).mod);
- name(n).type = conidcellsToTycons(line,ty);
-# ifdef DEBUG_IFACE
- fprintf(stderr, "end finishGHCValue %s\n", textToStr(name(n).text) );
-# endif
+ name(n).type = conidcellsToTycons(line,name(n).type);
+
+ if (isIfaceDefaultMethodName(name(n).text)) {
+ /* ... we need to set .parent to point to the class
+ ... once we figure out what the class actually is :-)
+ */
+ Type t = name(n).type;
+ assert(isPolyType(t));
+ if (isPolyType(t)) t = monotypeOf(t);
+ assert(isQualType(t));
+ t = fst(snd(t)); /* t :: [(Class,Offset)] */
+ assert(nonNull(t));
+ assert(nonNull(hd(t)));
+ assert(isPair(hd(t)));
+ t = fst(hd(t)); /* t :: Class */
+ assert(isClass(t));
+
+ name(n).parent = t; /* phew! */
+ }
}
* Type synonyms
* ------------------------------------------------------------------------*/
-Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
+static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
{
/* tycon :: ConId */
/* tvs :: [((VarId,Kind))] */
/* ty :: Type */
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin startGHCSynonym %s\n", textToStr(t) );
+ fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
# endif
+ line = intOf(line);
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
/* prepare for finishGHCSynonym */
tycon(tc).defn = tvsToOffsets(line,ty,tvs);
}
-# ifdef DEBUG_IFACE
- fprintf(stderr, "end startGHCSynonym %s\n", textToStr(t) );
-# endif
}
{
Tycon tc = findTycon(textOf(tyc));
Int line = tycon(tc).line;
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
+# endif
assert (currentModule == tycon(tc).mod);
// setCurrModule(tycon(tc).mod);
* Data declarations
* ------------------------------------------------------------------------*/
-Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
+static Type qualifyIfaceType ( Type unqual, List ctx )
+{
+ /* ctx :: [((QConId,VarId))] */
+ /* ctx is a list of (class name, tyvar) pairs.
+ Attach to unqual qualifiers taken from ctx
+ for each tyvar which appears in unqual.
+ */
+ List tyvarsMentioned; /* :: [VarId] */
+ List ctx2 = NIL;
+ Cell kinds = NIL;
+
+ if (isPolyType(unqual)) {
+ kinds = polySigOf(unqual);
+ unqual = monotypeOf(unqual);
+ }
+
+ assert(!isQualType(unqual));
+ tyvarsMentioned = ifTyvarsIn ( unqual );
+ for (; nonNull(ctx); ctx=tl(ctx)) {
+ ZPair ctxElem = hd(ctx); /* :: ((QConId, VarId)) */
+ if (nonNull(varIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
+ ctx2 = cons(ctxElem, ctx2);
+ }
+ if (nonNull(ctx2))
+ unqual = ap(QUAL,pair(reverse(ctx2),unqual));
+ if (nonNull(kinds))
+ unqual = mkPolyType(kinds,unqual);
+ return unqual;
+}
+
+
+static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
Int line;
List ctx0; /* [((QConId,VarId))] */
Cell tycon; /* ConId */
*/
{
Type ty, resTy, selTy, conArgTy;
- List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
- List ctx, ctx2;
+ List tmp, conArgs, sels, constrs, fields;
Triple constr;
Cell conid;
Pair conArg, ctxElem;
Text conArgNm;
Int conArgStrictness;
+ Int conStrictCompCount;
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin startGHCDataDecl %s\n",textToStr(t));
+ fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
# endif
+
+ line = intOf(line);
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
/* make resTy the result type of the constr, T v1 ... vn */
resTy = tycon;
for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,fst(hd(tmp)));
+ resTy = ap(resTy,zfst(hd(tmp)));
/* for each constructor ... */
for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
conid = zfst(constr);
fields = zsnd(constr);
- /* Build type of constr and handle any selectors found.
- Also collect up tyvars occurring in the constr's arg
- types, so we can throw away irrelevant parts of the
- context later.
- */
+ /* Build type of constr and handle any selectors found. */
ty = resTy;
- tyvarsMentioned = NIL;
- /* tyvarsMentioned :: [VarId] */
+ conStrictCompCount = 0;
conArgs = reverse(fields);
for (; nonNull(conArgs); conArgs=tl(conArgs)) {
conArg = hd(conArgs); /* (Type,Text) */
conArgTy = zfst3(conArg);
conArgNm = zsnd3(conArg);
conArgStrictness = intOf(zthd3(conArg));
- tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
- tyvarsMentioned);
- if (conArgStrictness > 0) conArgTy = bang(conArgTy);
+ if (conArgStrictness > 0) conStrictCompCount++;
ty = fn(conArgTy,ty);
if (nonNull(conArgNm)) {
/* a field name is mentioned too */
selTy = fn(resTy,conArgTy);
if (whatIs(tycon(tc).kind) != STAR)
selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
+ selTy = qualifyIfaceType ( selTy, ctx0 );
selTy = tvsToOffsets(line,selTy, ktyvars);
-
sels = cons( zpair(conArgNm,selTy), sels);
}
}
/* Now ty is the constructor's type, not including context.
- Throw away any parts of the context not mentioned in
- tyvarsMentioned, and use it to qualify ty.
+ Throw away any parts of the context not mentioned in ty,
+ and use it to qualify ty.
*/
- ctx2 = NIL;
- for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
- ctxElem = hd(ctx);
- /* ctxElem :: ((QConId,VarId)) */
- if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
- ctx2 = cons(ctxElem, ctx2);
- }
- if (nonNull(ctx2))
- ty = ap(QUAL,pair(ctx2,ty));
+ ty = qualifyIfaceType ( ty, ctx0 );
/* stick the tycon's kind on, if not simply STAR */
if (whatIs(tycon(tc).kind) != STAR)
- ty = pair(POLYTYPE,zpair(tycon(tc).kind, ty));
+ ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
ty = tvsToOffsets(line,ty, ktyvars);
/* Finally, stick the constructor's type onto it. */
- hd(constrs) = ztriple(conid,fields,ty);
+ hd(constrs) = z4ble(conid,fields,ty,mkInt(conStrictCompCount));
}
/* Final result is that
- constrs :: [((ConId,[((Type,Text))],Type))]
- lists the constructors and their types
+ constrs :: [((ConId,[((Type,Text))],Type,Int))]
+ lists the constructors, their types and # strict comps
sels :: [((VarId,Type))]
lists the selectors and their types
*/
tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
}
-# ifdef DEBUG_IFACE
- fprintf(stderr, "end startGHCDataDecl %s\n",textToStr(t));
-# endif
}
static List startGHCConstrs ( Int line, List cons, List sels )
{
- /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
- /* sels :: [((VarId,Type))] */
- /* returns [Name] */
+ /* cons :: [((ConId,[((Type,Text,Int))],Type,Int))] */
+ /* sels :: [((VarId,Type))] */
+ /* returns [Name] */
List cs, ss;
- Int conNo = 0; /* or maybe 1? */
+ Int conNo = length(cons)>1 ? 1 : 0;
for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
Name c = startGHCConstr(line,conNo,hd(cs));
hd(cs) = c;
}
-static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
+static Name startGHCConstr ( Int line, Int conNo, Z4Ble constr )
{
- /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
+ /* constr :: ((ConId,[((Type,Text,Int))],Type,Int)) */
/* (ADR) ToDo: add rank2 annotation and existential annotation
* these affect how constr can be used.
*/
- Text con = textOf(zfst3(constr));
- Type type = zthd3(constr);
- Int arity = arityFromType(type);
+ Text con = textOf(zsel14(constr));
+ Type type = zsel34(constr);
+ Int arity = arityFromType(type);
+ Int nStrict = intOf(zsel44(constr));
Name n = findName(con); /* Allocate constructor fun name */
if (isNull(n)) {
n = newName(con,NIL);
textToStr(con)
EEND;
}
- name(n).arity = arity; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(conNo);
- name(n).type = type;
+ name(n).arity = arity; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(conNo);
+ name(n).type = type;
+ name(n).hasStrict = nStrict > 0;
return n;
}
-static Void finishGHCDataDecl ( ConId tyc )
+static List finishGHCDataDecl ( ConId tyc )
{
List nms;
Tycon tc = findTycon(textOf(tyc));
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
+ fprintf ( stderr, "begin finishGHCDataDecl %s\n",
+ textToStr(textOf(tyc)) );
# endif
if (isNull(tc)) internal("finishGHCDataDecl");
Name n = hd(nms);
Int line = name(n).line;
assert(currentModule == name(n).mod);
- name(n).type = conidcellsToTycons(line,name(n).type);
+ name(n).type = conidcellsToTycons(line,name(n).type);
+ name(n).parent = tc; //---????
}
-# ifdef DEBUG_IFACE
- printf ( "end finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
-# endif
+
+ return tycon(tc).defn;
}
* Newtype decls
* ------------------------------------------------------------------------*/
-Void startGHCNewType ( Int line, List ctx0,
- ConId tycon, List tvs, Cell constr )
+static Void startGHCNewType ( Int line, List ctx0,
+ ConId tycon, List tvs, Cell constr )
{
- /* ctx0 :: [((QConId,VarId))] */
- /* tycon :: ConId */
- /* tvs :: [((VarId,Kind))] */
- /* constr :: ((ConId,Type)) */
+ /* ctx0 :: [((QConId,VarId))] */
+ /* tycon :: ConId */
+ /* tvs :: [((VarId,Kind))] */
+ /* constr :: ((ConId,Type)) or NIL if abstract */
List tmp;
Type resTy;
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin startGHCNewType %s\n", textToStr(t) );
+ fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
# endif
+
+ line = intOf(line);
+
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
tycon(tc).kind = tvsToKind(tvs);
/* can't really do this until I've read in all synonyms */
- {
- /* constr :: ((ConId,Type)) */
- Text con = textOf(zfst(constr));
- Type type = zsnd(constr);
- Name n = findName(con); /* Allocate constructor fun name */
- if (isNull(n)) {
- n = newName(con,NIL);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Repeated definition for constructor \"%s\"",
- textToStr(con)
- EEND;
- }
- name(n).arity = 1; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(0);
- name(n).defn = nameId;
- tycon(tc).defn = singleton(n);
-
- /* make resTy the result type of the constr, T v1 ... vn */
- resTy = tycon;
- for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,zfst(hd(tmp)));
- type = fn(type,resTy);
- if (nonNull(ctx0))
- type = ap(QUAL,pair(ctx0,type));
- type = tvsToOffsets(line,type,tvs);
- name(n).type = type;
+ if (isNull(constr)) {
+ tycon(tc).defn = NIL;
+ } else {
+ /* constr :: ((ConId,Type)) */
+ Text con = textOf(zfst(constr));
+ Type type = zsnd(constr);
+ Name n = findName(con); /* Allocate constructor fun name */
+ if (isNull(n)) {
+ n = newName(con,NIL);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(line) "Repeated definition for constructor \"%s\"",
+ textToStr(con)
+ EEND;
+ }
+ name(n).arity = 1; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(0);
+ name(n).defn = nameId;
+ tycon(tc).defn = singleton(n);
+
+ /* make resTy the result type of the constr, T v1 ... vn */
+ resTy = tycon;
+ for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
+ resTy = ap(resTy,zfst(hd(tmp)));
+ type = fn(type,resTy);
+ if (nonNull(ctx0))
+ type = ap(QUAL,pair(ctx0,type));
+ type = tvsToOffsets(line,type,tvs);
+ name(n).type = type;
}
}
-# ifdef DEBUG_IFACE
- fprintf(stderr, "end startGHCNewType %s\n", textToStr(t) );
-# endif
}
static Void finishGHCNewType ( ConId tyc )
{
- Tycon tc = findTycon(tyc);
+ Tycon tc = findTycon(textOf(tyc));
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
+ fprintf ( stderr, "begin finishGHCNewType %s\n",
+ textToStr(textOf(tyc)) );
# endif
if (isNull(tc)) internal("finishGHCNewType");
- if (length(tycon(tc).defn) != 1) internal("finishGHCNewType(2)");
- {
+
+ if (isNull(tycon(tc).defn)) {
+ /* it's an abstract type */
+ }
+ else if (length(tycon(tc).defn) == 1) {
+ /* As we expect, has a single constructor */
Name n = hd(tycon(tc).defn);
Int line = name(n).line;
assert(currentModule == name(n).mod);
name(n).type = conidcellsToTycons(line,name(n).type);
+ } else {
+ internal("finishGHCNewType(2)");
}
-# ifdef DEBUG_IFACE
- printf ( "end finishGHCNewType %s\n", textToStr(textOf(tyc)) );
-# endif
}
* Class declarations
* ------------------------------------------------------------------------*/
-Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
+static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
Int line;
List ctxt; /* [((QConId, VarId))] */
ConId tc_name; /* ConId */
List mems; /* [((VarId, Type))] */
List tvsInT; /* [VarId] and then [((VarId,Kind))] */
List tvs; /* [((VarId,Kind))] */
+ List ns; /* [Name] */
+ Int mno;
ZPair kinded_tv = hd(kinded_tvs);
Text ct = textOf(tc_name);
Pair newCtx = pair(tc_name, zfst(kinded_tv));
# ifdef DEBUG_IFACE
- printf ( "\nbegin startGHCclass %s\n", textToStr(ct) );
+ fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
# endif
+ line = intOf(line);
if (length(kinded_tvs) != 1) {
ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
EEND;
cclass(nw).line = line;
cclass(nw).arity = 1;
cclass(nw).head = ap(nw,mkOffset(0));
- cclass(nw).kinds = singleton(STAR); /* absolutely no idea at all */
- cclass(nw).instances = NIL; /* what the kind should be */
+ cclass(nw).kinds = singleton( zsnd(kinded_tv) );
+ cclass(nw).instances = NIL;
cclass(nw).numSupers = length(ctxt);
/* Kludge to map the single tyvar in the context to Offset 0.
Need to do something better for multiparam type classes.
-
- cclass(nw).supers = tvsToOffsets(line,ctxt,
- singleton(pair(tv,STAR)));
*/
cclass(nw).supers = tvsToOffsets(line,ctxt,
singleton(kinded_tv));
Name mn;
/* Stick the new context on the member type */
+ memT = dictapsToQualtype(memT);
if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
if (whatIs(memT)==QUAL) {
memT = pair(QUAL,
tvsInT = ifTyvarsIn(memT);
/* tvsInT :: [VarId] */
- /* ToDo: maximally bogus */
- for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
- hd(tvs) = zpair(hd(tvs),STAR);
- /* tvsIntT :: [((VarId,STAR))] */
+ /* ToDo: maximally bogus. We allow the class tyvar to
+ have the kind as supplied by the parser, but we just
+ assume that all others have kind *. It's a kludge.
+ */
+ for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
+ Kind k;
+ if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
+ k = zsnd(kinded_tv); else
+ k = STAR;
+ hd(tvs) = zpair(hd(tvs),k);
+ }
+ /* tvsIntT :: [((VarId,Kind))] */
memT = mkPolyType(tvsToKind(tvsInT),memT);
memT = tvsToOffsets(line,memT,tvsInT);
/* Park the type back on the member */
- snd(mem) = memT;
+ mem = zpair(zfst(mem),memT);
/* Bind code to the member */
mn = findName(mnt);
EEND;
}
mn = newName(mnt,NIL);
+
+ hd(mems) = mem;
}
cclass(nw).members = mems0;
cclass(nw).numMembers = length(mems0);
- /* (ADR) ToDo:
- * cclass(nw).dsels = ?;
- * cclass(nw).dbuild = ?;
- * cclass(nm).dcon = ?;
- * cclass(nm).defaults = ?;
- */
+ ns = NIL;
+ for (mno=0; mno<cclass(nw).numSupers; mno++) {
+ ns = cons(newDSel(nw,mno),ns);
+ }
+ cclass(nw).dsels = rev(ns);
}
-# ifdef DEBUG_IFACE
- printf ( "end startGHCclass %s\n", textToStr(ct) );
-# endif
}
-static Void finishGHCClass ( Tycon cls_tyc )
+static Class finishGHCClass ( Tycon cls_tyc )
{
List mems;
Int line;
Int ctr;
Class nw = findClass ( textOf(cls_tyc) );
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCclass %s\n", textToStr(cclass(nw).text) );
+ fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
# endif
if (isNull(nw)) internal("finishGHCClass");
line = cclass(nw).line;
- ctr = - length(cclass(nw).members);
+ ctr = -2;
assert (currentModule == cclass(nw).mod);
- cclass(nw).level = 0; /* (ADR) ToDo: 1 + max (map level supers) */
+ cclass(nw).level = 0;
cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
Type ty = snd(mem);
Name n = findName(txt);
assert(nonNull(n));
+ name(n).text = txt;
name(n).line = cclass(nw).line;
name(n).type = ty;
- name(n).number = ctr++;
+ name(n).number = ctr--;
+ name(n).arity = arityInclDictParams(name(n).type);
+ name(n).parent = nw;
hd(mems) = n;
}
-# ifdef DEBUG_IFACE
- printf ( "end finishGHCclass %s\n", textToStr(cclass(nw).text) );
-# endif
+
+ return nw;
}
* Instances
* ------------------------------------------------------------------------*/
-Void startGHCInstance (line,ctxt0,cls,var)
+static Inst startGHCInstance (line,ktyvars,cls,var)
Int line;
-List ctxt0; /* [(QConId, VarId)] */
-Type cls; /* Type */
-VarId var; { /* VarId */
- List tmp, tvs, ks;
+List ktyvars; /* [((VarId,Kind))] */
+Type cls; /* Type */
+VarId var; { /* VarId */
+ List tmp, tvs, ks, spec;
+
+ List xs1, xs2;
+ Kind k;
+
Inst in = newInst();
# ifdef DEBUG_IFACE
- printf ( "\nbegin startGHCInstance\n" );
+ fprintf ( stderr, "begin startGHCInstance\n" );
# endif
- /* Make tvs into a list of tyvars with bogus kinds. */
- tvs = ifTyvarsIn(cls);
- /* tvs :: [VarId] */
+ line = intOf(line);
- ks = NIL;
- for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
- hd(tmp) = zpair(hd(tmp),STAR);
- ks = cons(STAR,ks);
+ tvs = ifTyvarsIn(cls); /* :: [VarId] */
+ /* tvs :: [VarId].
+ The order of tvs is important for tvsToOffsets.
+ tvs should be a permutation of ktyvars. Fish the tyvar kinds
+ out of ktyvars and attach them to tvs.
+ */
+ for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
+ k = NIL;
+ for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
+ if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
+ k = zsnd(hd(xs2));
+ if (isNull(k)) internal("startGHCInstance: finding kinds");
+ hd(xs1) = zpair(hd(xs1),k);
+ }
+
+ cls = tvsToOffsets(line,cls,tvs);
+ spec = NIL;
+ while (isAp(cls)) {
+ spec = cons(fun(cls),spec);
+ cls = arg(cls);
}
- /* tvs :: [((VarId,STAR))] */
+ spec = reverse(spec);
inst(in).line = line;
inst(in).implements = NIL;
- inst(in).kinds = ks;
- inst(in).specifics = tvsToOffsets(line,ctxt0,tvs);
- inst(in).numSpecifics = length(ctxt0);
- inst(in).head = tvsToOffsets(line,cls,tvs);
-#if 0
- Is this still needed?
+ inst(in).kinds = simpleKind(length(tvs)); /* do this right */
+ inst(in).specifics = spec;
+ inst(in).numSpecifics = length(spec);
+ inst(in).head = cls;
+
+ /* Figure out the name of the class being instanced, and store it
+ at inst(in).c. finishGHCInstance will resolve it to a real Class. */
+ {
+ Cell cl = inst(in).head;
+ assert(whatIs(cl)==DICTAP);
+ cl = unap(DICTAP,cl);
+ cl = fst(cl);
+ assert ( isQCon(cl) );
+ inst(in).c = cl;
+ }
+
{
- Name b = newName(inventText(),NIL);
+ Name b = newName( /*inventText()*/ textOf(var),NIL);
name(b).line = line;
- name(b).arity = length(ctxt); /* unused? */
+ name(b).arity = length(spec); /* unused? */ /* and surely wrong */
name(b).number = DFUNNAME;
+ name(b).parent = in;
inst(in).builder = b;
- bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
+ /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
}
-#endif
-# ifdef DEBUG_IFACE
- printf ( "end startGHCInstance\n" );
-# endif
+
+ return in;
}
-static Void finishGHCInstance ( Type cls )
+static Void finishGHCInstance ( Inst in )
{
- /* Cls is the { C1 a1 } -> ... -> { Cn an }, where
- an isn't a type variable -- it's a data or tuple. */
- Inst in;
- Int line;
- Cell cl;
- Class c;
- ConId conid_cls;
- ConId conid_ty;
+ Int line;
+ Class c;
+ Type cls;
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCInstance\n" );
+ fprintf ( stderr, "begin finishGHCInstance\n" );
# endif
- cls = snd(cls); /* { Cn an } */
- conid_cls = fst(cls);
- conid_ty = snd(cls);
-
- if (whatIs(conid_cls) != CONIDCELL ||
- whatIs(conid_ty ) != CONIDCELL) internal("finishGHCInstance");
-
- in = findSimpleInstance ( conid_cls, conid_ty );
+ assert (nonNull(in));
line = inst(in).line;
- cl = fst(inst(in).head);
-
assert (currentModule==inst(in).mod);
- c = findClass(textOf(cl));
- if (isNull(c)) {
- ERRMSG(line) "Unknown class \"%s\" in instance",
- textToStr(textOf(cl))
- EEND;
- }
+
+ /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
+ since startGHCInstance couldn't possibly have resolved it to
+ a Class at that point. We convert it to a Class now.
+ */
+ c = inst(in).c;
+ assert(isQCon(c));
+ c = findQualClassWithoutConsultingExportList(c);
+ assert(nonNull(c));
+ inst(in).c = c;
+
inst(in).head = conidcellsToTycons(line,inst(in).head);
inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
cclass(c).instances = cons(in,cclass(c).instances);
-# ifdef DEBUG_IFACE
- printf ( "end finishGHCInstance\n" );
-# endif
}
The Offset for a type variable is determined by its place in the list
passed as the second arg; the associated kinds are irrelevant.
- ((t1,t2)) denotes the typed (z-)pair type of t1 and t2.
+ ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
*/
/* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
static Type tvsToOffsets(line,type,ktyvars)
Int line;
Type type;
-List ktyvars; { /* [(VarId,Kind)] */
+List ktyvars; { /* [((VarId,Kind))] */
switch (whatIs(type)) {
case NIL:
case TUPLE:
for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
Cell varid;
Text tt;
-assert(isZPair(hd(ktyvars)));
+ assert(isZPair(hd(ktyvars)));
varid = zfst(hd(ktyvars));
tt = textOf(varid);
if (tv == tt) return mkOffset(i);
return NIL; /* NOTREACHED */
}
-/* ToDo: nuke this */
-static Text kludgeGHCPrelText ( Text m )
-{
- return m;
-#if 0
- if (strncmp(textToStr(m), "Prel", 4)==0)
- return textPrelude; else return m;
-#endif
-}
-
/* This is called from the finishGHC* functions. It traverses a structure
and converts conidcells, ie, type constructors parsed by the interface
Tycons or Classes have been loaded into the symbol tables and can be
looked up.
*/
-static Type conidcellsToTycons(line,type)
-Int line;
-Type type; {
+static Type conidcellsToTycons ( Int line, Type type )
+{
switch (whatIs(type)) {
case NIL:
case OFFSET:
case TYCON:
case CLASS:
case VARIDCELL:
+ case TUPLE:
+ case STAR:
return type;
case QUALIDENT:
- { List t;
- Text m = kludgeGHCPrelText(qmodOf(type));
- Text v = qtextOf(type);
+ { Cell t; /* Tycon or Class */
+ Text m = qmodOf(type);
Module mod = findModule(m);
- //printf ( "lookup qualident " ); print(type,100); printf("\n");
if (isNull(mod)) {
ERRMSG(line)
"Undefined module in qualified name \"%s\"",
EEND;
return NIL;
}
- for (t=module(mod).tycons; nonNull(t); t=tl(t))
- if (v == tycon(hd(t)).text) return hd(t);
- for (t=module(mod).classes; nonNull(t); t=tl(t))
- if (v == cclass(hd(t)).text) return hd(t);
+ t = findQualTyconWithoutConsultingExportList(type);
+ if (nonNull(t)) return t;
+ t = findQualClassWithoutConsultingExportList(type);
+ if (nonNull(t)) return t;
ERRMSG(line)
"Undefined qualified class or type \"%s\"",
identToStr(type)
case CONIDCELL:
{ Tycon tc;
Class cl;
- tc = findQualTycon(type);
- if (nonNull(tc)) return tc;
cl = findQualClass(type);
if (nonNull(cl)) return cl;
+ if (textOf(type)==findText("[]"))
+ /* a hack; magically qualify [] into PrelBase.[] */
+ return conidcellsToTycons(line,
+ mkQualId(mkCon(findText("PrelBase")),type));
+ tc = findQualTycon(type);
+ if (nonNull(tc)) return tc;
ERRMSG(line)
"Undefined class or type constructor \"%s\"",
identToStr(type)
case AP:
return ap( conidcellsToTycons(line,fun(type)),
conidcellsToTycons(line,arg(type)) );
+ case ZTUP2: /* convert to std pair */
+ return ap( conidcellsToTycons(line,zfst(type)),
+ conidcellsToTycons(line,zsnd(type)) );
+
case POLYTYPE:
return mkPolyType (
polySigOf(type),
case QUAL:
return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
conidcellsToTycons(line,snd(snd(type)))));
- case DICTAP: /* bogus?? */
- return ap(DICTAP, conidcellsToTycons(line, snd(type)));
+ case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
+ Not sure if this is really the right place to
+ convert it to the form Hugs wants, but will do so anyway.
+ */
+ /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
+ {
+ Class cl = fst(unap(DICTAP,type));
+ List args = snd(unap(DICTAP,type));
+ return
+ conidcellsToTycons(line,pair(cl,args));
+ }
case UNBOXEDTUP:
return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
+ case BANG:
+ return ap(BANG, conidcellsToTycons(line, snd(type)));
default:
fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
whatIs(type));
}
+/* Find out if a type mentions a type constructor not present in
+ the supplied list of qualified tycons.
+*/
+static Bool allTypesKnown ( Type type,
+ List aktys /* [QualId] */,
+ ConId thisMod )
+{
+ switch (whatIs(type)) {
+ case NIL:
+ case OFFSET:
+ case VARIDCELL:
+ case TUPLE:
+ return TRUE;
+ case AP:
+ return allTypesKnown(fun(type),aktys,thisMod)
+ && allTypesKnown(arg(type),aktys,thisMod);
+ case ZTUP2:
+ return allTypesKnown(zfst(type),aktys,thisMod)
+ && allTypesKnown(zsnd(type),aktys,thisMod);
+ case DICTAP:
+ return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
+
+ case CONIDCELL:
+ if (textOf(type)==findText("[]"))
+ /* a hack; magically qualify [] into PrelBase.[] */
+ type = mkQualId(mkCon(findText("PrelBase")),type); else
+ type = mkQualId(thisMod,type);
+ /* fall through */
+ case QUALIDENT:
+ if (isNull(qualidIsMember(type,aktys))) goto missing;
+ return TRUE;
+ case TYCON:
+ return TRUE;
+
+ default:
+ fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
+ print(type,10);printf("\n");
+ internal("allTypesKnown");
+ return TRUE; /*notreached*/
+ }
+ missing:
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
+ fprintf(stderr,"\n");
+# endif
+ return FALSE;
+}
+
+
/* --------------------------------------------------------------------------
* Utilities
*
}
-/* --------------------------------------------------------------------------
- * ELF specifics
- * ------------------------------------------------------------------------*/
-
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
-
-#include <elf.h>
-
-static char* findElfSection ( void* objImage, Elf32_Word sh_type )
-{
- Int i;
- char* ehdrC = (char*)objImage;
- Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- char* ptr = NULL;
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == sh_type &&
- i != ehdr->e_shstrndx) {
- ptr = ehdrC + shdr[i].sh_offset;
- break;
- }
- }
- return ptr;
-}
-
-
-static Void resolveReferencesInObjectModule_elf ( Module m,
- Bool verb )
-{
- char symbol[1000]; // ToDo
- int i, j;
- Elf32_Sym* stab = NULL;
- char* strtab;
- char* ehdrC = (char*)(module(m).oImage);
- Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- Elf32_Word* targ;
- // first find "the" symbol table
- // why is this commented out???
- stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
-
- // also go find the string table
- strtab = findElfSection ( ehdrC, SHT_STRTAB );
-
- if (!stab || !strtab)
- internal("resolveReferencesInObjectModule_elf");
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == SHT_REL ) {
- Elf32_Rel* rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
- Int nent = shdr[i].sh_size / sizeof(Elf32_Rel);
- Int target_shndx = shdr[i].sh_info;
- Int symtab_shndx = shdr[i].sh_link;
- stab = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
- targ = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
- if (verb)
- fprintf ( stderr,
- "relocations for section %d using symtab %d\n",
- target_shndx, symtab_shndx );
- for (j = 0; j < nent; j++) {
- Elf32_Addr offset = rtab[j].r_offset;
- Elf32_Word info = rtab[j].r_info;
-
- Elf32_Addr P = ((Elf32_Addr)targ) + offset;
- Elf32_Word* pP = (Elf32_Word*)P;
- Elf32_Addr A = *pP;
- Elf32_Addr S;
-
- if (verb) fprintf ( stderr, "Rel entry %3d is raw(%6p %6p) ",
- j, (void*)offset, (void*)info );
- if (!info) {
- if (verb) fprintf ( stderr, " ZERO\n" );
- S = 0;
- } else {
- if (stab[ ELF32_R_SYM(info)].st_name == 0) {
- if (verb) fprintf ( stderr, "(noname) ");
- /* nameless (local) symbol */
- S = (Elf32_Addr)(ehdrC
- + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
- + stab[ELF32_R_SYM(info)].st_value
- );
- strcpy ( symbol, "(noname)");
- } else {
- strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
- if (verb) fprintf ( stderr, "`%s' ", symbol );
- S = (Elf32_Addr)lookupObjName ( symbol );
- }
- if (verb) fprintf ( stderr, "resolves to %p\n", (void*)S );
- if (!S) {
- fprintf ( stderr, "link failure for `%s'\n",
- strtab+stab[ ELF32_R_SYM(info)].st_name );
- assert(0);
- }
- }
- //fprintf ( stderr, "Reloc: P = %p S = %p A = %p\n\n",
- // (void*)P, (void*)S, (void*)A );
- switch (ELF32_R_TYPE(info)) {
- case R_386_32: *pP = S + A; break;
- case R_386_PC32: *pP = S + A - P; break;
- default: fprintf(stderr,
- "unhandled ELF relocation type %d\n",
- ELF32_R_TYPE(info));
- assert(0);
- }
-
- }
- }
- else
- if (shdr[i].sh_type == SHT_RELA) {
- fprintf ( stderr, "RelA style reloc table -- not yet done" );
- assert(0);
- }
- }
-}
-
-
-static Bool validateOImage_elf ( void* imgV,
- Int size,
- Bool verb )
-{
- Elf32_Shdr* shdr;
- Elf32_Sym* stab;
- int i, j, nent, nstrtab, nsymtabs;
- char* sh_strtab;
- char* strtab;
-
- char* ehdrC = (char*)imgV;
- Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
-
- if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
- ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
- ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
- ehdr->e_ident[EI_MAG3] != ELFMAG3) {
- if (verb) fprintf ( stderr, "Not an ELF header\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is an ELF header\n" );
-
- if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
- if (verb) fprintf ( stderr, "Not 32 bit ELF\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is 32 bit ELF\n" );
-
- if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
- if (verb) fprintf ( stderr, "Is little-endian\n" );
- } else
- if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
- if (verb) fprintf ( stderr, "Is big-endian\n" );
- } else {
- if (verb) fprintf ( stderr, "Unknown endiannness\n" );
- return FALSE;
- }
-
- if (ehdr->e_type != ET_REL) {
- if (verb) fprintf ( stderr, "Not a relocatable object (.o) file\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is a relocatable object (.o) file\n" );
-
- if (verb) fprintf ( stderr, "Architecture is " );
- switch (ehdr->e_machine) {
- case EM_386: if (verb) fprintf ( stderr, "x86\n" ); break;
- case EM_SPARC: if (verb) fprintf ( stderr, "sparc\n" ); break;
- default: if (verb) fprintf ( stderr, "unknown\n" ); return FALSE;
- }
-
- if (verb)
- fprintf ( stderr,
- "\nSection header table: start %d, n_entries %d, ent_size %d\n",
- ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize );
-
- assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
-
- shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
-
- if (ehdr->e_shstrndx == SHN_UNDEF) {
- if (verb) fprintf ( stderr, "No section header string table\n" );
- sh_strtab = NULL;
- return FALSE;
- } else {
- if (verb) fprintf ( stderr,"Section header string table is section %d\n",
- ehdr->e_shstrndx);
- sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
- }
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (verb) fprintf ( stderr, "%2d: ", i );
- if (verb) fprintf ( stderr, "type=%2d ", shdr[i].sh_type );
- if (verb) fprintf ( stderr, "size=%4d ", shdr[i].sh_size );
- if (verb) fprintf ( stderr, "offs=%4d ", shdr[i].sh_offset );
- if (verb) fprintf ( stderr, " (%p .. %p) ",
- ehdrC + shdr[i].sh_offset,
- ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
-
- if (shdr[i].sh_type == SHT_REL && verb) fprintf ( stderr, "Rel " ); else
- if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else
- if (verb) fprintf ( stderr, " " );
- if (sh_strtab && verb)
- fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name );
- if (verb) fprintf ( stderr, "\n" );
- }
-
- if (verb) fprintf ( stderr, "\n\nString tables\n" );
- strtab = NULL;
- nstrtab = 0;
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == SHT_STRTAB &&
- i != ehdr->e_shstrndx) {
- if (verb)
- fprintf ( stderr, " section %d is a normal string table\n", i );
- strtab = ehdrC + shdr[i].sh_offset;
- nstrtab++;
- }
- }
- if (nstrtab != 1) {
- if (verb) fprintf ( stderr, "WARNING: no string tables, or too many\n" );
- return FALSE;
- }
-
- nsymtabs = 0;
- if (verb) fprintf ( stderr, "\n\nSymbol tables\n" );
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type != SHT_SYMTAB) continue;
- if (verb) fprintf ( stderr, "section %d is a symbol table\n", i );
- nsymtabs++;
- stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
- nent = shdr[i].sh_size / sizeof(Elf32_Sym);
- if (verb) fprintf ( stderr, " number of entries is apparently %d (%d rem)\n",
- nent,
- shdr[i].sh_size % sizeof(Elf32_Sym)
- );
- if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
- if (verb) fprintf ( stderr, "non-integral number of symbol table entries\n");
- return FALSE;
- }
- for (j = 0; j < nent; j++) {
- if (verb) fprintf ( stderr, " %2d ", j );
- if (verb) fprintf ( stderr, " sec=%-5d size=%-3d val=%-5p ",
- (int)stab[j].st_shndx,
- (int)stab[j].st_size,
- (char*)stab[j].st_value );
-
- if (verb) fprintf ( stderr, "type=" );
- switch (ELF32_ST_TYPE(stab[j].st_info)) {
- case STT_NOTYPE: if (verb) fprintf ( stderr, "notype " ); break;
- case STT_OBJECT: if (verb) fprintf ( stderr, "object " ); break;
- case STT_FUNC : if (verb) fprintf ( stderr, "func " ); break;
- case STT_SECTION: if (verb) fprintf ( stderr, "section" ); break;
- case STT_FILE: if (verb) fprintf ( stderr, "file " ); break;
- default: if (verb) fprintf ( stderr, "? " ); break;
- }
- if (verb) fprintf ( stderr, " " );
-
- if (verb) fprintf ( stderr, "bind=" );
- switch (ELF32_ST_BIND(stab[j].st_info)) {
- case STB_LOCAL : if (verb) fprintf ( stderr, "local " ); break;
- case STB_GLOBAL: if (verb) fprintf ( stderr, "global" ); break;
- case STB_WEAK : if (verb) fprintf ( stderr, "weak " ); break;
- default: if (verb) fprintf ( stderr, "? " ); break;
- }
- if (verb) fprintf ( stderr, " " );
-
- if (verb) fprintf ( stderr, "name=%s\n", strtab + stab[j].st_name );
- }
- }
-
- if (nsymtabs == 0) {
- if (verb) fprintf ( stderr, "Didn't find any symbol tables\n" );
- return FALSE;
- }
-
- return TRUE;
-}
-
-
-static void readSyms_elf ( Module m, Bool verb )
-{
- int i, j, k, nent;
- Elf32_Sym* stab;
-
- char* ehdrC = (char*)(module(m).oImage);
- Elf32_Ehdr* ehdr = (Elf32_Ehdr*)ehdrC;
- char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
-
- if (!strtab) internal("readSyms_elf");
-
- k = 0;
- for (i = 0; i < ehdr->e_shnum; i++) {
-
- /* make a HugsDLSection entry for relevant sections */
- DLSect kind = HUGS_DL_SECTION_OTHER;
- if (0==strcmp(".data",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".data1",sh_strtab+shdr[i].sh_name))
- kind = HUGS_DL_SECTION_RWDATA;
- if (0==strcmp(".text",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
- kind = HUGS_DL_SECTION_CODE_OR_RODATA;
- if (kind != HUGS_DL_SECTION_OTHER)
- addDLSect (
- m,
- ehdrC + shdr[i].sh_offset,
- ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1,
- kind
- );
-
- if (shdr[i].sh_type != SHT_SYMTAB) continue;
-
- /* copy stuff into this module's object symbol table */
- stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
- nent = shdr[i].sh_size / sizeof(Elf32_Sym);
- for (j = 0; j < nent; j++) {
- if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ||
- ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
- )
- &&
- ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
- ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
- ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE)
- ) {
- char* nm = strtab + stab[j].st_name;
- char* ad = ehdrC
- + shdr[ stab[j].st_shndx ].sh_offset
- + stab[j].st_value;
- assert(nm);
- assert(ad);
- if (verb)
- fprintf(stderr, "addOTabName: %10p %s %s\n",
- ad, textToStr(module(m).text), nm );
- addOTabName ( m, nm, ad );
- }
- //else fprintf(stderr, "skipping `%s'\n", strtab + stab[j].st_name );
- }
-
- }
-}
-
-#endif /* defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) */
-
/* --------------------------------------------------------------------------
- * Arch-independent interface to the runtime linker
+ * General object symbol query stuff
* ------------------------------------------------------------------------*/
-static Bool validateOImage ( void* img, Int size, Bool verb )
-{
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- return
- validateOImage_elf ( img, size, verb );
-#else
- internal("validateOImage: not implemented on this platform");
+#define EXTERN_SYMS_ALLPLATFORMS \
+ SymX(MainRegTable) \
+ Sym(stg_gc_enter_1) \
+ Sym(stg_gc_noregs) \
+ Sym(stg_gc_seq_1) \
+ Sym(stg_gc_d1) \
+ Sym(stg_gc_f1) \
+ Sym(stg_chk_0) \
+ Sym(stg_chk_1) \
+ Sym(stg_gen_chk) \
+ SymX(stg_exit) \
+ SymX(stg_update_PAP) \
+ SymX(stg_error_entry) \
+ SymX(__ap_2_upd_info) \
+ SymX(__ap_3_upd_info) \
+ SymX(__ap_4_upd_info) \
+ SymX(__ap_5_upd_info) \
+ SymX(__ap_6_upd_info) \
+ SymX(__ap_7_upd_info) \
+ SymX(__ap_8_upd_info) \
+ SymX(__sel_0_upd_info) \
+ SymX(__sel_1_upd_info) \
+ SymX(__sel_2_upd_info) \
+ SymX(__sel_3_upd_info) \
+ SymX(__sel_4_upd_info) \
+ SymX(__sel_5_upd_info) \
+ SymX(__sel_6_upd_info) \
+ SymX(__sel_7_upd_info) \
+ SymX(__sel_8_upd_info) \
+ SymX(__sel_9_upd_info) \
+ SymX(__sel_10_upd_info) \
+ SymX(__sel_11_upd_info) \
+ SymX(__sel_12_upd_info) \
+ SymX(upd_frame_info) \
+ SymX(seq_frame_info) \
+ SymX(CAF_BLACKHOLE_info) \
+ SymX(IND_STATIC_info) \
+ SymX(EMPTY_MVAR_info) \
+ SymX(MUT_ARR_PTRS_FROZEN_info) \
+ SymX(newCAF) \
+ SymX(putMVarzh_fast) \
+ SymX(newMVarzh_fast) \
+ SymX(takeMVarzh_fast) \
+ SymX(catchzh_fast) \
+ SymX(raisezh_fast) \
+ SymX(delayzh_fast) \
+ SymX(yieldzh_fast) \
+ SymX(killThreadzh_fast) \
+ SymX(waitReadzh_fast) \
+ SymX(waitWritezh_fast) \
+ SymX(CHARLIKE_closure) \
+ SymX(INTLIKE_closure) \
+ SymX(suspendThread) \
+ SymX(resumeThread) \
+ SymX(stackOverflow) \
+ SymX(int2Integerzh_fast) \
+ Sym(stg_gc_unbx_r1) \
+ SymX(ErrorHdrHook) \
+ SymX(mkForeignObjzh_fast) \
+ SymX(__encodeDouble) \
+ SymX(decodeDoublezh_fast) \
+ SymX(isDoubleNaN) \
+ SymX(isDoubleInfinite) \
+ SymX(isDoubleDenormalized) \
+ SymX(isDoubleNegativeZero) \
+ SymX(__encodeFloat) \
+ SymX(decodeFloatzh_fast) \
+ SymX(isFloatNaN) \
+ SymX(isFloatInfinite) \
+ SymX(isFloatDenormalized) \
+ SymX(isFloatNegativeZero) \
+ SymX(__int_encodeFloat) \
+ SymX(__int_encodeDouble) \
+ SymX(mpz_cmp_si) \
+ SymX(mpz_cmp) \
+ SymX(__mpn_gcd_1) \
+ SymX(gcdIntegerzh_fast) \
+ SymX(newArrayzh_fast) \
+ SymX(unsafeThawArrayzh_fast) \
+ SymX(newDoubleArrayzh_fast) \
+ SymX(newFloatArrayzh_fast) \
+ SymX(newAddrArrayzh_fast) \
+ SymX(newWordArrayzh_fast) \
+ SymX(newIntArrayzh_fast) \
+ SymX(newCharArrayzh_fast) \
+ SymX(newMutVarzh_fast) \
+ SymX(quotRemIntegerzh_fast) \
+ SymX(quotIntegerzh_fast) \
+ SymX(remIntegerzh_fast) \
+ SymX(divExactIntegerzh_fast) \
+ SymX(divModIntegerzh_fast) \
+ SymX(timesIntegerzh_fast) \
+ SymX(minusIntegerzh_fast) \
+ SymX(plusIntegerzh_fast) \
+ SymX(addr2Integerzh_fast) \
+ SymX(mkWeakzh_fast) \
+ SymX(prog_argv) \
+ SymX(prog_argc) \
+ Sym(resetNonBlockingFd) \
+ SymX(getStablePtr) \
+ SymX(stable_ptr_table) \
+ Sym(createAdjThunk) \
+ SymX(shutdownHaskellAndExit) \
+ Sym(stg_enterStackTop) \
+ SymX(CAF_UNENTERED_entry) \
+ Sym(stg_yield_to_Hugs) \
+ Sym(StgReturn) \
+ Sym(init_stack) \
+ SymX(blockAsyncExceptionszh_fast) \
+ SymX(unblockAsyncExceptionszh_fast) \
+ \
+ /* needed by libHS_cbits */ \
+ SymX(malloc) \
+ SymX(close) \
+ SymX(close) \
+ Sym(opendir) \
+ Sym(closedir) \
+ Sym(readdir) \
+ SymX(isatty) \
+ SymX(read) \
+ SymX(lseek) \
+ SymX(write) \
+ SymX(realloc) \
+ SymX(getcwd) \
+ SymX(free) \
+ SymX(strcpy) \
+ SymX(fprintf) \
+ SymX(exit) \
+ SymX(unlink) \
+ SymX(memcpy) \
+ SymX(memchr) \
+ SymX(rmdir) \
+ SymX(rename) \
+ SymX(chdir) \
+ SymX(getenv) \
+
+#define EXTERN_SYMS_cygwin32 \
+ SymX(GetCurrentProcess) \
+ SymX(GetProcessTimes) \
+ Sym(__udivdi3) \
+ SymX(bzero) \
+ Sym(select) \
+ SymX(_impure_ptr) \
+ Sym(lstat) \
+ Sym(setmode) \
+ SymX(system) \
+ SymX(sleep) \
+ SymX(__imp__tzname) \
+ SymX(__imp__timezone) \
+ SymX(tzset) \
+ SymX(log) \
+ SymX(exp) \
+ Sym(sqrt) \
+ Sym(sin) \
+ Sym(cos) \
+ SymX(pow) \
+ SymX(__errno) \
+ Sym(stat) \
+ Sym(fstat) \
+ Sym(gettimeofday) \
+ SymX(localtime) \
+ SymX(strftime) \
+ SymX(mktime) \
+ SymX(execl) \
+ Sym(mkdir) \
+ Sym(open) \
+ Sym(tcgetattr) \
+ Sym(tcsetattr) \
+ Sym(getrusage) \
+ Sym(fcntl) \
+ Sym(waitpid) \
+ SymX(gmtime) \
+
+
+#define EXTERN_SYMS_linux \
+ SymX(__errno_location) \
+ Sym(__xstat) \
+ Sym(__fxstat) \
+ Sym(__lxstat) \
+ SymX(select) \
+ SymX(stderr) \
+ SymX(vfork) \
+ SymX(_exit) \
+ SymX(tzname) \
+ SymX(localtime) \
+ SymX(strftime) \
+ SymX(timezone) \
+ SymX(mktime) \
+ SymX(gmtime) \
+ Sym(setitimer) \
+ Sym(chmod) \
+ SymX(execl) \
+ Sym(mkdir) \
+ Sym(open) \
+ Sym(tcgetattr) \
+ Sym(tcsetattr) \
+ Sym(gettimeofday) \
+ Sym(getrusage) \
+ Sym(waitpid) \
+ Sym(fcntl) \
+
+
+#define EXTERN_SYMS_solaris2 \
+ SymX(gettimeofday) \
+
+
+#if defined(linux_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
#endif
-}
-
-static Void resolveReferencesInObjectModule ( Module m, Bool verb )
-{
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- resolveReferencesInObjectModule_elf ( m, verb );
-#else
- internal("resolveReferencesInObjectModule: not implemented on this platform");
+#if defined(solaris2_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
#endif
-}
+#if defined(cygwin32_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
+#endif
-static Void readSyms ( Module m, Bool verb )
-{
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- readSyms_elf ( m, verb );
-#else
- internal("readSyms: not implemented on this platform");
+#if defined(mingw32_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM /* */
#endif
-}
-/* --------------------------------------------------------------------------
- * General object symbol query stuff
- * ------------------------------------------------------------------------*/
/* entirely bogus claims about types of these symbols */
-extern int stg_gc_enter_1;
-extern int stg_chk_0;
-extern int stg_chk_1;
-extern int stg_update_PAP;
-extern int __ap_2_upd_info;
-extern int MainRegTable;
-extern int Upd_frame_info;
-extern int CAF_BLACKHOLE_info;
-extern int IND_STATIC_info;
-extern int newCAF;
-
+#define Sym(vvv) extern void (vvv);
+#define SymX(vvv) /**/
+EXTERN_SYMS_ALLPLATFORMS
+EXTERN_SYMS_THISPLATFORM
+#undef Sym
+#undef SymX
+
+
+#define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ (void*)(&(vvv)) },
+#define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ (void*)(&(vvv)) },
OSym rtsTab[]
= {
- { "stg_gc_enter_1", &stg_gc_enter_1 },
- { "stg_chk_0", &stg_chk_0 },
- { "stg_chk_1", &stg_chk_1 },
- { "stg_update_PAP", &stg_update_PAP },
- { "__ap_2_upd_info", &__ap_2_upd_info },
- { "MainRegTable", &MainRegTable },
- { "Upd_frame_info", &Upd_frame_info },
- { "CAF_BLACKHOLE_info", &CAF_BLACKHOLE_info },
- { "IND_STATIC_info", &IND_STATIC_info },
- { "newCAF", &newCAF },
+ EXTERN_SYMS_ALLPLATFORMS
+ EXTERN_SYMS_THISPLATFORM
{0,0}
};
+#undef Sym
+#undef SymX
+
+
+
+
+/* A kludge to assist Win32 debugging. */
+char* nameFromStaticOPtr ( void* ptr )
+{
+ int k;
+ for (k = 0; rtsTab[k].nm; k++)
+ if (ptr == rtsTab[k].ad)
+ return rtsTab[k].nm;
+ return NULL;
+}
void* lookupObjName ( char* nm )
Text t;
Module m;
char nm2[200];
+ int first_real_char;
nm2[199] = 0;
strncpy(nm2,nm,200);
- // first see if it's an RTS name
+ /* first see if it's an RTS name */
for (k = 0; rtsTab[k].nm; k++)
if (0==strcmp(nm2,rtsTab[k].nm))
return rtsTab[k].ad;
- // if not an RTS name, look in the
- // relevant module's object symbol table
- pp = strchr(nm2, '_');
- if (!pp) goto not_found;
+ /* perhaps an extra-symbol ? */
+ a = lookupOExtraTabName ( nm );
+ if (a) return a;
+
+# if LEADING_UNDERSCORE
+ first_real_char = 1;
+# else
+ first_real_char = 0;
+# endif
+
+ /* Maybe it's an __init_Module thing? */
+ if (strlen(nm2+first_real_char) > 7
+ && strncmp(nm2+first_real_char, "__init_", 7)==0) {
+ t = unZcodeThenFindText(nm2+first_real_char+7);
+ if (t == findText("PrelGHC")) return (4+(char*)NULL); /* kludge */
+ m = findModule(t);
+ if (isNull(m)) goto dire_straits;
+ a = lookupOTabName ( m, nm );
+ if (a) return a;
+ goto dire_straits;
+ }
+
+ /* if not an RTS name, look in the
+ relevant module's object symbol table
+ */
+ pp = strchr(nm2+first_real_char, '_');
+ if (!pp || !isupper(nm2[first_real_char])) goto dire_straits;
*pp = 0;
- t = kludgeGHCPrelText( unZcodeThenFindText(nm2) );
+ t = unZcodeThenFindText(nm2+first_real_char);
m = findModule(t);
- if (isNull(m)) goto not_found;
- a = lookupOTabName ( m, nm );
+ if (isNull(m)) goto dire_straits;
+
+ a = lookupOTabName ( m, nm ); /* RATIONALISE */
+ if (a) return a;
+
+ dire_straits:
+ /* make a desperate, last-ditch attempt to find it */
+ a = lookupOTabNameAbsolutelyEverywhere ( nm );
if (a) return a;
- not_found:
fprintf ( stderr,
"lookupObjName: can't resolve name `%s'\n",
nm );
+ assert(0);
return NULL;
}
int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
{
- return
- lookupDLSect(p) == HUGS_DL_SECTION_CODE_OR_RODATA;
+ OSectionKind sk = lookupSection(p);
+ assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
+ return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
}
int is_dynamically_loaded_rwdata_ptr ( char* p )
{
- return
- lookupDLSect(p) == HUGS_DL_SECTION_RWDATA;
+ OSectionKind sk = lookupSection(p);
+ assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
+ return (sk == HUGS_SECTIONKIND_RWDATA);
}
int is_not_dynamically_loaded_ptr ( char* p )
{
- return
- lookupDLSect(p) == HUGS_DL_SECTION_OTHER;
+ OSectionKind sk = lookupSection(p);
+ assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
+ return (sk == HUGS_SECTIONKIND_OTHER);
}
* Control:
* ------------------------------------------------------------------------*/
-Void interface(what)
+Void interfayce(what)
Int what; {
switch (what) {
case POSTPREL: break;
projects / ghc-hetmet.git / blobdiff