X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Finterface.c;h=8b81bfee75784f8320eedd2999bf8d20a40d894a;hb=4a277ee0a14ae0747f82813548119030fbc19b0c;hp=34b9d214d6e13920ffcdcbba98330c85a2c9810e;hpb=51c33894862dfd591d71018a70f4ca3914b17f7b;p=ghc-hetmet.git diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index 34b9d21..8b81bfe 100644 --- a/ghc/interpreter/interface.c +++ b/ghc/interpreter/interface.c @@ -7,39 +7,24 @@ * 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. @@ -70,63 +55,114 @@ extern void print ( Cell, Int ); * * ------------------------------------------------------------------------*/ + +/* +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 ); @@ -136,79 +172,206 @@ static void* lookupObjName ( char* ); * 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); @@ -216,7 +379,9 @@ static Cell cleanIFace ( Cell root ) 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] */ @@ -225,36 +390,287 @@ static Cell cleanIFace ( Cell root ) 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; @@ -265,47 +681,232 @@ Void processInterfaces ( void ) 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); @@ -324,9 +925,16 @@ Void processInterfaces ( void ) 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: { @@ -366,19 +974,26 @@ Void processInterfaces ( void ) } } - 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); @@ -390,11 +1005,13 @@ Void processInterfaces ( void ) 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: { @@ -403,8 +1020,9 @@ Void processInterfaces ( void ) 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: { @@ -413,8 +1031,9 @@ Void processInterfaces ( void ) 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: { @@ -427,15 +1046,25 @@ Void processInterfaces ( void ) } } } +# 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; } @@ -445,59 +1074,96 @@ Void processInterfaces ( void ) * 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" @@ -506,20 +1172,31 @@ Void startGHCModule ( Text mname, Int sizeObj, Text nameObj ) 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); @@ -527,65 +1204,112 @@ Void finishGHCModule ( Cell root ) 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; @@ -593,9 +1317,20 @@ Void finishGHCModule ( Cell root ) 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; @@ -622,9 +1357,16 @@ Void finishGHCModule ( Cell root ) } } } +#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"); + } } @@ -632,18 +1374,18 @@ Void finishGHCModule ( Cell root ) * 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. */ } @@ -653,48 +1395,111 @@ Void finishGHCExports ( ConId mn, List exlist ) * 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)) @@ -703,31 +1508,40 @@ void startGHCValue ( Int line, VarId vid, Type ty ) 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! */ + } } @@ -735,15 +1549,16 @@ void finishGHCValue ( VarId vid ) * 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) @@ -758,9 +1573,6 @@ Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty ) /* prepare for finishGHCSynonym */ tycon(tc).defn = tvsToOffsets(line,ty,tvs); } -# ifdef DEBUG_IFACE - fprintf(stderr, "end startGHCSynonym %s\n", textToStr(t) ); -# endif } @@ -768,6 +1580,9 @@ static Void finishGHCSynonym ( ConId tyc ) { 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); @@ -785,7 +1600,38 @@ static Void finishGHCSynonym ( ConId tyc ) * 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 */ @@ -798,18 +1644,20 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */ */ { 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) @@ -828,7 +1676,7 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */ /* 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)) { @@ -836,81 +1684,63 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */ 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; @@ -948,15 +1778,16 @@ static Name startGHCSel ( Int line, ZPair sel ) } -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); @@ -965,20 +1796,22 @@ static Name startGHCConstr ( Int line, Int conNo, ZTriple constr ) 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"); @@ -986,11 +1819,11 @@ static Void finishGHCDataDecl ( ConId tyc ) 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; } @@ -998,19 +1831,22 @@ static Void finishGHCDataDecl ( ConId tyc ) * 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) @@ -1023,59 +1859,62 @@ Void startGHCNewType ( Int line, List ctx0, 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 } @@ -1083,7 +1922,7 @@ static Void finishGHCNewType ( ConId tyc ) * 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 */ @@ -1093,14 +1932,17 @@ List mems0; { /* [((VarId, Type))] */ 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; @@ -1120,15 +1962,12 @@ List mems0; { /* [((VarId, Type))] */ 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)); @@ -1141,6 +1980,7 @@ List mems0; { /* [((VarId, Type))] */ 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, @@ -1154,16 +1994,24 @@ List mems0; { /* [((VarId, Type))] */ 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); @@ -1174,40 +2022,38 @@ List mems0; { /* [((VarId, Type))] */ 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 ... -> { 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 } @@ -1330,14 +2193,14 @@ static Void finishGHCInstance ( Type cls ) 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: @@ -1372,7 +2235,7 @@ List ktyvars; { /* [(VarId,Kind)] */ 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); @@ -1391,16 +2254,6 @@ assert(isZPair(hd(ktyvars))); 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 @@ -1410,22 +2263,21 @@ static Text kludgeGHCPrelText ( Text m ) 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\"", @@ -1433,10 +2285,10 @@ Type type; { 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) @@ -1446,10 +2298,14 @@ Type 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) @@ -1459,6 +2315,10 @@ Type 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), @@ -1468,10 +2328,21 @@ Type 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)); @@ -1484,6 +2355,55 @@ Type 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 * @@ -1560,414 +2480,269 @@ Type type; { } -/* -------------------------------------------------------------------------- - * ELF specifics - * ------------------------------------------------------------------------*/ - -#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) - -#include - -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 ) @@ -1978,52 +2753,85 @@ 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); } @@ -2031,7 +2839,7 @@ int is_not_dynamically_loaded_ptr ( char* p ) * Control: * ------------------------------------------------------------------------*/ -Void interface(what) +Void interfayce(what) Int what; { switch (what) { case POSTPREL: break;