X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Finterface.c;h=d4719d6deed4bebc36470b277842b8e1fd2709d9;hb=e4706792d290d4c5cb6a020d2973689efb7457ff;hp=321ec98aec2a294ee371f712eb675486fcd21d92;hpb=0f92da1735e3bfbf90aa89f5ddf4b83c89e8a1a7;p=ghc-hetmet.git diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index 321ec98..d4719d6 100644 --- a/ghc/interpreter/interface.c +++ b/ghc/interpreter/interface.c @@ -7,25 +7,21 @@ * Hugs version 1.4, December 1997 * * $RCSfile: interface.c,v $ - * $Revision: 1.14 $ - * $Date: 1999/12/20 16:55:26 $ + * $Revision: 1.54 $ + * $Date: 2000/04/14 15:18:06 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "backend.h" #include "connect.h" #include "errors.h" -#include "link.h" -#include "Assembler.h" /* for wrapping GHC objects */ #include "object.h" +#include "Assembler.h" /* for wrapping GHC objects */ -#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 @@ -121,52 +117,51 @@ viz, the entire Prelude at once: * 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 Inst 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((Cell)); -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 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 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* lookupObjName ( char* ); +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 ( Type ); +static Type tvsToOffsets ( Int,Type,List ); +static Type conidcellsToTycons ( Int,Type ); @@ -177,7 +172,7 @@ static void* lookupObjName ( char* ); * ------------------------------------------------------------------------*/ /* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */ -ConVarId getIEntityName ( Cell c ) +static ConVarId getIEntityName ( Cell c ) { switch (whatIs(c)) { case I_IMPORT: return NIL; @@ -203,10 +198,10 @@ ConVarId getIEntityName ( Cell c ) When a named entity is deleted, filterInterface also deletes the name in the export lists. */ -Cell filterInterface ( Cell root, - Bool (*pred)(Cell,Cell), - Cell extraArgs, - Void (*dumpAction)(Cell) ) +static Cell filterInterface ( Cell root, + Bool (*pred)(Cell,Cell), + Cell extraArgs, + Void (*dumpAction)(Cell) ) { List tops; Cell iface = unap(I_INTERFACE,root); @@ -247,12 +242,10 @@ Cell filterInterface ( Cell root, } -ZPair readInterface(String fname, Long fileSize) +List /* of CONID */ getInterfaceImports ( Cell iface ) { List tops; List imports = NIL; - ZPair iface = parseInterface(fname,fileSize); - assert (whatIs(iface)==I_INTERFACE); for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops)) if (whatIs(hd(tops)) == I_IMPORT) { @@ -260,10 +253,13 @@ ZPair readInterface(String fname, Long fileSize) 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; } @@ -281,14 +277,22 @@ static List getExportDeclsInIFace ( Cell root ) } +/* 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; - List exlist; - List t; + Text tnm; + List exlist; + List t; + String s; ConVarId ife_id = getIEntityName ( ife ); @@ -296,6 +300,11 @@ static Bool isExportedIFaceEntity ( Cell ife, List exlist_list ) 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); @@ -315,11 +324,15 @@ static Bool isExportedIFaceEntity ( Cell ife, List exlist_list ) } } +# 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; } @@ -365,7 +378,9 @@ static Cell deleteUnexportedIFaceEntities ( Cell root ) List exlist_list = NIL; List t; +# ifdef DEBUG_IFACE fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname))); +# endif exlist_list = getExportDeclsInIFace ( root ); /* exlist_list :: [I_EXPORT] */ @@ -374,10 +389,12 @@ static Cell deleteUnexportedIFaceEntities ( 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 return filterInterface ( root, isExportedIFaceEntity, exlist_list, NULL ); @@ -385,7 +402,7 @@ static Cell deleteUnexportedIFaceEntities ( Cell root ) /* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */ -List addTyconsAndClassesFromIFace ( Cell root, List aktys ) +static List addTyconsAndClassesFromIFace ( Cell root, List aktys ) { Cell iface = unap(I_INTERFACE,root); Text mname = textOf(zfst(iface)); @@ -404,20 +421,23 @@ List addTyconsAndClassesFromIFace ( Cell root, List aktys ) } -Void ifentityAllTypesKnown_dumpmsg ( Cell entity ) +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. */ -Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod ) +static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod ) { List t, u; List aktys = zfst ( aktys_mod ); @@ -478,47 +498,12 @@ Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod ) } -#if 0 -I hope this can be nuked. -/* Kludge. Stuff imported from PrelGHC isn't referred to in a - qualified way, so arrange it so it is. -*/ -QualId magicRequalify ( ConId id ) -{ - Text tid; - Text tmid; - assert(isCon(id)); - tid = textOf(id); - - fprintf ( stderr, "$--$--$--$--$--$ magicRequalify: %s", - textToStr(tid) ); - - if (tid == findText("[]")) { - tmid = findText("PrelList"); - } else - if (tid == findText("Ratio")) { - tmid = findText("PrelNum"); - } else - if (tid == findText("Char")) { - tmid = findText("PrelGHC"); - } else { - fprintf(stderr, "??? \n"); - return id; - } - - fprintf ( stderr, " -> %s.%s\n", - textToStr(tmid), textToStr(tid) ); - return mkQualId ( mkCon(tmid), id ); -} -#endif - - /* 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. */ -Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod ) +static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod ) { List t, u; List aktys = zfst ( aktys_mod ); @@ -530,20 +515,23 @@ Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod ) } } -Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity ) + +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 } /* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT */ -List abstractifyExDecl ( Cell root, ConId toabs ) +static List abstractifyExDecl ( Cell root, ConId toabs ) { ZPair exdecl = unap(I_EXPORT,root); List exlist = zsnd(exdecl); @@ -561,19 +549,127 @@ List abstractifyExDecl ( Cell root, ConId toabs ) } -Void ppModule ( Text modt ) +static Void ppModule ( Text modt ) { +# ifdef DEBUG_IFACE fflush(stderr); fflush(stdout); fprintf(stderr, "---------------- MODULE %s ----------------\n", textToStr(modt) ); +# endif } -/* ifaces_outstanding holds a list of parsed interfaces - for which we need to load objects and create symbol - table entries. -*/ -Void processInterfaces ( void ) +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; @@ -586,26 +682,26 @@ Void processInterfaces ( void ) 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 */ - List iface_sizes = NIL; /* :: List Int */ - List iface_onames = NIL; /* :: List Text */ + if (isNull(iface_modnames)) return; + +# ifdef DEBUG_IFACE fprintf ( stderr, "processInterfaces: %d interfaces to process\n", length(ifaces_outstanding) ); +# endif - - /* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */ - for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) { - ifaces = cons ( zfst3(hd(xs)), ifaces ); - iface_onames = cons ( zsnd3(hd(xs)), iface_onames ); - iface_sizes = cons ( zthd3(hd(xs)), iface_sizes ); + 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); - iface_onames = reverse(iface_onames); - iface_sizes = reverse(iface_sizes); + ifaces = reverse(ifaces); /* Clean up interfaces -- dump non-exported value, class, type decls */ for (xs = ifaces; nonNull(xs); xs = tl(xs)) @@ -626,11 +722,15 @@ Void processInterfaces ( void ) */ all_known_types = getAllKnownTyconsAndClasses(); for (xs = ifaces; nonNull(xs); xs=tl(xs)) - all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types ); + all_known_types + = addTyconsAndClassesFromIFace ( hd(xs), all_known_types ); /* Have we reached a fixed point? */ i = length(all_known_types); - printf ( "\n============= %d known types =============\n", i ); +# ifdef DEBUG_IFACE + fprintf ( stderr, + "\n============= %d known types =============\n", i ); +# endif if (num_known_types == i) break; num_known_types = i; @@ -671,7 +771,7 @@ Void processInterfaces ( void ) 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; + if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE; } else if (whatIs(ent)==I_NEWTYPE) { Cell newty = unap(I_NEWTYPE,ent); @@ -684,9 +784,11 @@ Void processInterfaces ( void ) 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 } } @@ -720,7 +822,10 @@ Void processInterfaces ( void ) data = z5ble ( zsel15(data), zsel25(data), zsel35(data), zsel45(data), NIL /* the constr list */ ); hd(es) = ap(I_DATA,data); -fprintf(stderr, "abstractify data %s\n", textToStr(textOf(getIEntityName(ent))) ); +# ifdef DEBUG_IFACE + fprintf(stderr, "abstractify data %s\n", + textToStr(textOf(getIEntityName(ent))) ); +# endif } else if (whatIs(ent)==I_NEWTYPE && isExportedAbstractly ( getIEntityName(ent), @@ -729,7 +834,10 @@ fprintf(stderr, "abstractify data %s\n", textToStr(textOf(getIEntityName(ent))) data = z5ble ( zsel15(data), zsel25(data), zsel35(data), zsel45(data), NIL /* the constr-type pair */ ); hd(es) = ap(I_NEWTYPE,data); -fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent))) ); +# ifdef DEBUG_IFACE + fprintf(stderr, "abstractify newtype %s\n", + textToStr(textOf(getIEntityName(ent))) ); +# endif } } @@ -743,8 +851,9 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) be value defns, classes and instances which refer to unknown types. Delete iteratively until a fixed point is reached. */ -printf("\n"); - +# ifdef DEBUG_IFACE + fprintf(stderr,"\n"); +# endif num_known_types = 999999999; while (TRUE) { Int i; @@ -760,7 +869,10 @@ printf("\n"); /* Have we reached a fixed point? */ i = length(all_known_types); - printf ( "\n------------- %d known types -------------\n", i ); +# ifdef DEBUG_IFACE + fprintf ( stderr, + "\n------------- %d known types -------------\n", i ); +# endif if (num_known_types == i) break; num_known_types = i; @@ -778,15 +890,8 @@ printf("\n"); /* Allocate module table entries and read in object code. */ - for (xs=ifaces; - nonNull(xs); - xs=tl(xs), iface_sizes=tl(iface_sizes), iface_onames=tl(iface_onames)) { - startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))), - intOf(hd(iface_sizes)), - hd(iface_onames) ); - } - assert (isNull(iface_sizes)); - assert (isNull(iface_onames)); + 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 @@ -868,13 +973,19 @@ printf("\n"); } } - fprintf(stderr, "\n=========================================================\n"); - fprintf(stderr, "=========================================================\n"); +# 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 process the export lists; those must wait for later. */ + cls_list = NIL; + constructor_list = NIL; for (xs = ifaces; nonNull(xs); xs = tl(xs)) { iface = unap(I_INTERFACE,hd(xs)); mname = textOf(zfst(iface)); @@ -893,6 +1004,8 @@ printf("\n"); break; } case I_FIXDECL: { + Cell fixdecl = unap(I_FIXDECL,decl); + finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) ); break; } case I_INSTANCE: { @@ -906,8 +1019,9 @@ printf("\n"); 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: { @@ -916,8 +1030,9 @@ printf("\n"); 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: { @@ -930,9 +1045,13 @@ printf("\n"); } } } +# ifdef DEBUG_IFACE + fprintf(stderr, "\n+++++++++++++++++++++++++++++" + "++++++++++++++++++++++++++++\n"); + fprintf(stderr, "+++++++++++++++++++++++++++++++" + "++++++++++++++++++++++++++\n"); +# endif - fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n"); - fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n"); /* 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 @@ -941,6 +1060,10 @@ printf("\n"); 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; } @@ -950,22 +1073,31 @@ printf("\n"); * Modules * ------------------------------------------------------------------------*/ -void startGHCModule_errMsg ( char* msg ) +static void startGHCModule_errMsg ( char* msg ) { fprintf ( stderr, "object error: %s\n", msg ); } -void* startGHCModule_clientLookup ( char* sym ) +static void* startGHCModule_clientLookup ( char* sym ) { +# ifdef DEBUG_IFACE /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */ +# endif return lookupObjName ( sym ); } -ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz ) +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) { @@ -980,43 +1112,41 @@ ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz ) ERRMSG(0) "Validation of object file \"%s\" failed", objNm EEND; } - if (!ocGetNames(oc,0||VERBOSE)) { + if (!ocGetNames(oc,VERBOSE)) { ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm EEND; } return oc; } -Void startGHCModule ( Text mname, Int sizeObj, Text nameObj ) +static Void startGHCModule ( Text mname ) { List xts; Module m = findModule(mname); + assert(nonNull(m)); - if (isNull(m)) { - m = newModule(mname); - fprintf ( stderr, "startGHCIface: name %16s objsize %d\n", - textToStr(mname), sizeObj ); - } else { - if (module(m).fake) { - module(m).fake = FALSE; - } else { - ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname) - EEND; - } - } +# 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(nameObj), sizeObj ); + = 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(nameObj), - textToStr(xtt), - &size ); + String nm = getExtraObjectInfo ( + textToStr(module(m).objName), + textToStr(xtt), + &size + ); if (size == -1) { ERRMSG(0) "Can't find extra object file \"%s\"", nm EEND; @@ -1053,7 +1183,7 @@ Void startGHCModule ( Text mname, Int sizeObj, Text nameObj ) */ -Void finishGHCModule ( Cell root ) +static Void finishGHCModule ( Cell root ) { /* root :: I_INTERFACE */ Cell iface = unap(I_INTERFACE,root); @@ -1063,7 +1193,9 @@ Void finishGHCModule ( Cell root ) List t; ObjectCode* oc; +# ifdef DEBUG_IFACE fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname))); +# endif if (isNull(mod)) internal("finishExports(1)"); setCurrModule(mod); @@ -1090,16 +1222,22 @@ Void finishGHCModule ( Cell root ) 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 */ q = mkQualId(exmod,ex); c = findQualTyconWithoutConsultingExportList ( q ); if (isNull(c)) goto notfound; +# ifdef DEBUG_IFACE fprintf(stderr, " type %s\n", textToStr(textOf(ex)) ); - module(mod).exports = cons(c, module(mod).exports); +# 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 */ @@ -1109,7 +1247,10 @@ Void finishGHCModule ( Cell root ) c = findQualTyconWithoutConsultingExportList ( q ); if (nonNull(c)) { /* data */ - fprintf(stderr, " data/newtype %s = { ", textToStr(textOf(ex)) ); +# 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 @@ -1119,38 +1260,55 @@ Void finishGHCModule ( Cell root ) original (defining) module. */ if (abstract) { - module(mod).exports = cons ( ex, module(mod).exports ); + 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); + /* module(mod).exports = cons(c, module(mod).exports); */ + addName(c); } } +# ifdef DEBUG_IFACE fprintf(stderr, "}\n" ); +# endif } else { /* class */ 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)); q = mkQualId(exmod,ent2); c = findQualNameWithoutConsultingExportList ( q ); +# ifdef DEBUG_IFACE fprintf(stderr, "%s ", textToStr(name(c).text)); +# endif if (isNull(c)) goto notfound; - module(mod).exports = cons(c, module(mod).exports); + /* module(mod).exports = cons(c, module(mod).exports); */ + addName(c); } +# ifdef DEBUG_IFACE fprintf(stderr, "}\n" ); +# endif } break; @@ -1163,12 +1321,15 @@ Void finishGHCModule ( Cell root ) 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; @@ -1195,13 +1356,14 @@ Void finishGHCModule ( Cell root ) } } } +#endif /* Last, but by no means least ... */ - if (!ocResolve(module(mod).object,0||VERBOSE)) + if (!ocResolve(module(mod).object,VERBOSE)) internal("finishGHCModule: object resolution failed"); for (oc=module(mod).objectExtras; oc; oc=oc->next) { - if (!ocResolve(oc, 0||VERBOSE)) + if (!ocResolve(oc, VERBOSE)) internal("finishGHCModule: extra object resolution failed"); } } @@ -1211,18 +1373,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. */ } @@ -1232,48 +1394,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("begin 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)) @@ -1285,10 +1510,11 @@ void startGHCValue ( Int line, VarId vid, Type ty ) name(n).type = ty; name(n).arity = arityInclDictParams(ty); name(n).line = line; + name(n).defn = NIL; } -void finishGHCValue ( VarId vid ) +static void finishGHCValue ( VarId vid ) { Name n = findName ( textOf(vid) ); Int line = name(n).line; @@ -1297,6 +1523,24 @@ void finishGHCValue ( VarId vid ) # endif assert(currentModule == name(n).mod); 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! */ + } } @@ -1304,7 +1548,7 @@ 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))] */ @@ -1313,6 +1557,7 @@ Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty ) # ifdef DEBUG_IFACE 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) @@ -1354,7 +1599,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 */ @@ -1367,19 +1643,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, "begin startGHCDataDecl %s\n",textToStr(t)); # endif + line = intOf(line); if (nonNull(findTycon(t))) { ERRMSG(line) "Repeated definition of type constructor \"%s\"", textToStr(t) @@ -1398,7 +1675,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)) { @@ -1406,48 +1683,34 @@ 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) @@ -1456,12 +1719,12 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */ 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 */ @@ -1472,9 +1735,9 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */ 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 = length(cons)>1 ? 1 : 0; for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) { @@ -1514,15 +1777,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); @@ -1531,20 +1795,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 ( "begin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) ); + fprintf ( stderr, "begin finishGHCDataDecl %s\n", + textToStr(textOf(tyc)) ); # endif if (isNull(tc)) internal("finishGHCDataDecl"); @@ -1552,8 +1818,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; //---???? } + + return tycon(tc).defn; } @@ -1561,8 +1830,8 @@ 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 */ @@ -1574,6 +1843,9 @@ Void startGHCNewType ( Int line, List ctx0, # ifdef DEBUG_IFACE 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) @@ -1624,7 +1896,8 @@ static Void finishGHCNewType ( ConId tyc ) { Tycon tc = findTycon(textOf(tyc)); # ifdef DEBUG_IFACE - printf ( "begin finishGHCNewType %s\n", textToStr(textOf(tyc)) ); + fprintf ( stderr, "begin finishGHCNewType %s\n", + textToStr(textOf(tyc)) ); # endif if (isNull(tc)) internal("finishGHCNewType"); @@ -1648,7 +1921,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 */ @@ -1658,14 +1931,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 ( "begin 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; @@ -1685,15 +1961,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)); @@ -1706,6 +1979,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, @@ -1719,10 +1993,18 @@ 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); @@ -1746,32 +2028,31 @@ List mems0; { /* [((VarId, Type))] */ 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 7 + && strncmp(nm2+first_real_char, "__init_", 7)==0) { + t = unZcodeThenFindText(nm2+first_real_char+7); + if (t == findText("PrelGHC")) return (4+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, '_'); - if (!pp || !isupper(nm2[0])) goto not_found; + pp = strchr(nm2+first_real_char, '_'); + if (!pp || !isupper(nm2[first_real_char])) goto dire_straits; *pp = 0; - t = unZcodeThenFindText(nm2); + t = unZcodeThenFindText(nm2+first_real_char); m = findModule(t); - if (isNull(m)) goto not_found; + if (isNull(m)) goto dire_straits; a = lookupOTabName ( m, nm ); /* RATIONALISE */ if (a) return a; - not_found: + dire_straits: + /* make a desperate, last-ditch attempt to find it */ + a = lookupOTabNameAbsolutelyEverywhere ( nm ); + if (a) return a; + fprintf ( stderr, "lookupObjName: can't resolve name `%s'\n", nm ); -assert(4-4); + assert(0); return NULL; }