* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.12 $
- * $Date: 1999/12/16 16:42:56 $
+ * $Revision: 1.58 $
+ * $Date: 2000/05/12 13:34:07 $
* ------------------------------------------------------------------------*/
-/* 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
* 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 resolveReferencesInObjectModule Args((Module,Bool));
-static Bool validateOImage Args((void*, Int, Bool));
-static Void readSyms Args((Module,Bool));
-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 );
* ------------------------------------------------------------------------*/
/* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
-ConVarId getIEntityName ( Cell c )
+static ConVarId getIEntityName ( Cell c )
{
switch (whatIs(c)) {
case I_IMPORT: return NIL;
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);
}
-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) {
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;
}
}
+/* 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 );
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);
}
}
+# 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;
}
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] */
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 );
/* 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));
}
-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 );
}
-#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 );
}
}
-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);
}
-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;
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))
*/
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;
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);
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
}
}
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),
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
}
}
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;
/* 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;
/* 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
}
}
- 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));
break;
}
case I_FIXDECL: {
+ Cell fixdecl = unap(I_FIXDECL,decl);
+ finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
break;
}
case I_INSTANCE: {
break;
}
case I_DATA: {
- Cell ddecl = unap(I_DATA,decl);
- finishGHCDataDecl ( zsel35(ddecl) );
+ Cell ddecl = unap(I_DATA,decl);
+ List constrs = finishGHCDataDecl ( zsel35(ddecl) );
+ constructor_list = dupOnto ( constrs, constructor_list );
break;
}
case I_NEWTYPE: {
break;
}
case I_CLASS: {
- Cell klass = unap(I_CLASS,decl);
- finishGHCClass ( zsel35(klass) );
+ Cell klass = unap(I_CLASS,decl);
+ Class cls = finishGHCClass ( zsel35(klass) );
+ cls_list = cons(cls,cls_list);
break;
}
case I_VALUE: {
}
}
}
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\n+++++++++++++++++++++++++++++"
+ "++++++++++++++++++++++++++++\n");
+ fprintf(stderr, "+++++++++++++++++++++++++++++++"
+ "++++++++++++++++++++++++++\n");
+# endif
- 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
for (xs = ifaces; nonNull(xs); xs = tl(xs))
finishGHCModule(hd(xs));
+ mapProc(visitClass,cls_list);
+ mapProc(ifSetClassDefaultsAndDCon,cls_list);
+ mapProc(ifLinkConstrItbl,constructor_list);
+
/* Finished! */
ifaces_outstanding = NIL;
}
* Modules
* ------------------------------------------------------------------------*/
-Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
+static void startGHCModule_errMsg ( char* msg )
{
- FILE* f;
- void* img;
-
- Module m = findModule(mname);
- if (isNull(m)) {
- m = newModule(mname);
- fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
- textToStr(mname), sizeObj );
- } else {
- if (module(m).fake) {
- module(m).fake = FALSE;
- } else {
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
- EEND;
- }
- }
+ fprintf ( stderr, "object error: %s\n", msg );
+}
+
+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;
+}
- img = malloc ( sizeObj );
- if (!img) {
- ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
- textToStr(mname)
+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;
+ }
}
*/
-Void finishGHCModule ( Cell root )
+static Void finishGHCModule ( Cell root )
{
/* root :: I_INTERFACE */
- Cell iface = unap(I_INTERFACE,root);
- ConId iname = zfst(iface);
- Module mod = findModule(textOf(iname));
- 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;
+# ifdef DEBUG_IFACE
fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
+# endif
if (isNull(mod)) internal("finishExports(1)");
setCurrModule(mod);
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 */
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
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;
notfound:
/* q holds what ain't found */
assert(whatIs(q)==QUALIDENT);
+# ifdef DEBUG_IFACE
fprintf( stderr, " ------ IGNORED: %s.%s\n",
textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
+# endif
continue;
}
}
+#if 0
if (preludeLoaded) {
/* do the implicit 'import Prelude' thing */
List pxs = module(modulePrelude).exports;
}
}
}
+#endif
/* Last, but by no means least ... */
- resolveReferencesInObjectModule ( mod, VERBOSE );
+ if (!ocResolve(module(mod).object,VERBOSE))
+ internal("finishGHCModule: object resolution failed");
+
+ for (oc=module(mod).objectExtras; oc; oc=oc->next) {
+ if (!ocResolve(oc, VERBOSE))
+ internal("finishGHCModule: extra object resolution failed");
+ }
}
* Exports
* ------------------------------------------------------------------------*/
-Void startGHCExports ( ConId mn, List exlist )
+static Void startGHCExports ( ConId mn, List exlist )
{
# ifdef DEBUG_IFACE
- printf("startGHCExports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
-Void finishGHCExports ( ConId mn, List exlist )
+static Void finishGHCExports ( ConId mn, List exlist )
{
# ifdef DEBUG_IFACE
- printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
* Imports
* ------------------------------------------------------------------------*/
-Void startGHCImports ( ConId mn, List syms )
+static Void startGHCImports ( ConId mn, List syms )
/* nm the module to import from */
/* syms [ConId | VarId] -- the names to import */
{
# ifdef DEBUG_IFACE
- printf("startGHCImports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
-Void finishGHCImports ( ConId nm, List syms )
+static Void finishGHCImports ( ConId nm, List syms )
/* nm the module to import from */
/* syms [ConId | VarId] -- the names to import */
{
# ifdef DEBUG_IFACE
- printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
+ fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
# endif
/* Nothing to do. */
}
/* --------------------------------------------------------------------------
+ * Fixity decls
+ * ------------------------------------------------------------------------*/
+
+static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
+{
+ Int p = intOf(prec);
+ Int a = intOf(assoc);
+ Name n = findName(textOf(name));
+ assert (nonNull(n));
+ name(n).syntax = mkSyntax ( a, p );
+}
+
+
+/* --------------------------------------------------------------------------
* Vars (values)
* ------------------------------------------------------------------------*/
-void startGHCValue ( Int line, VarId vid, Type ty )
+/* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
+ { C1 a } -> { C2 b } -> T into
+ ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
+*/
+static Type dictapsToQualtype ( Type ty )
+{
+ List pieces = NIL;
+ List preds, dictaps;
+
+ /* break ty into pieces at the top-level arrows */
+ while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
+ pieces = cons ( arg(fun(ty)), pieces );
+ ty = arg(ty);
+ }
+ pieces = cons ( ty, pieces );
+ pieces = reverse ( pieces );
+
+ dictaps = NIL;
+ while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
+ dictaps = cons ( hd(pieces), dictaps );
+ pieces = tl(pieces);
+ }
+
+ /* dictaps holds the predicates, backwards */
+ /* pieces holds the remainder of the type, forwards */
+ assert(nonNull(pieces));
+ pieces = reverse(pieces);
+ ty = hd(pieces);
+ pieces = tl(pieces);
+ for (; nonNull(pieces); pieces=tl(pieces))
+ ty = fn(hd(pieces),ty);
+
+ preds = NIL;
+ for (; nonNull(dictaps); dictaps=tl(dictaps)) {
+ Cell da = hd(dictaps);
+ QualId cl = fst(unap(DICTAP,da));
+ Cell arg = snd(unap(DICTAP,da));
+ preds = cons ( pair(cl,arg), preds );
+ }
+
+ if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
+ return ty;
+}
+
+
+
+static void startGHCValue ( Int line, VarId vid, Type ty )
{
Name n;
List tmp, tvs;
Text v = textOf(vid);
# ifdef DEBUG_IFACE
- printf("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))
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;
# 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! */
+ }
}
* 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))] */
# 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)
* Data declarations
* ------------------------------------------------------------------------*/
-Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
+static Type qualifyIfaceType ( Type unqual, List ctx )
+{
+ /* ctx :: [((QConId,VarId))] */
+ /* ctx is a list of (class name, tyvar) pairs.
+ Attach to unqual qualifiers taken from ctx
+ for each tyvar which appears in unqual.
+ */
+ List tyvarsMentioned; /* :: [VarId] */
+ List ctx2 = NIL;
+ Cell kinds = NIL;
+
+ if (isPolyType(unqual)) {
+ kinds = polySigOf(unqual);
+ unqual = monotypeOf(unqual);
+ }
+
+ assert(!isQualType(unqual));
+ tyvarsMentioned = ifTyvarsIn ( unqual );
+ for (; nonNull(ctx); ctx=tl(ctx)) {
+ ZPair ctxElem = hd(ctx); /* :: ((QConId, VarId)) */
+ if (nonNull(varIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
+ ctx2 = cons(ctxElem, ctx2);
+ }
+ if (nonNull(ctx2))
+ unqual = ap(QUAL,pair(reverse(ctx2),unqual));
+ if (nonNull(kinds))
+ unqual = mkPolyType(kinds,unqual);
+ return unqual;
+}
+
+
+static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
Int line;
List ctx0; /* [((QConId,VarId))] */
Cell tycon; /* ConId */
*/
{
Type ty, resTy, selTy, conArgTy;
- List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
- List ctx, ctx2;
+ List tmp, conArgs, sels, constrs, fields;
Triple constr;
Cell conid;
Pair conArg, ctxElem;
Text conArgNm;
Int conArgStrictness;
+ Int conStrictCompCount;
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
# endif
+ line = intOf(line);
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
/* make resTy the result type of the constr, T v1 ... vn */
resTy = tycon;
for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,fst(hd(tmp)));
+ resTy = ap(resTy,zfst(hd(tmp)));
/* for each constructor ... */
for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
conid = zfst(constr);
fields = zsnd(constr);
- /* Build type of constr and handle any selectors found.
- Also collect up tyvars occurring in the constr's arg
- types, so we can throw away irrelevant parts of the
- context later.
- */
+ /* Build type of constr and handle any selectors found. */
ty = resTy;
- tyvarsMentioned = NIL;
- /* tyvarsMentioned :: [VarId] */
+ conStrictCompCount = 0;
conArgs = reverse(fields);
for (; nonNull(conArgs); conArgs=tl(conArgs)) {
conArg = hd(conArgs); /* (Type,Text) */
conArgTy = zfst3(conArg);
conArgNm = zsnd3(conArg);
conArgStrictness = intOf(zthd3(conArg));
- tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
- tyvarsMentioned);
- if (conArgStrictness > 0) conArgTy = bang(conArgTy);
+ if (conArgStrictness > 0) conStrictCompCount++;
ty = fn(conArgTy,ty);
if (nonNull(conArgNm)) {
/* a field name is mentioned too */
selTy = fn(resTy,conArgTy);
if (whatIs(tycon(tc).kind) != STAR)
selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
+ selTy = qualifyIfaceType ( selTy, ctx0 );
selTy = tvsToOffsets(line,selTy, ktyvars);
sels = cons( zpair(conArgNm,selTy), sels);
}
}
/* Now ty is the constructor's type, not including context.
- Throw away any parts of the context not mentioned in
- tyvarsMentioned, and use it to qualify ty.
+ Throw away any parts of the context not mentioned in ty,
+ and use it to qualify ty.
*/
- ctx2 = NIL;
- for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
- ctxElem = hd(ctx);
- /* ctxElem :: ((QConId,VarId)) */
- if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
- ctx2 = cons(ctxElem, ctx2);
- }
- if (nonNull(ctx2))
- ty = ap(QUAL,pair(ctx2,ty));
+ ty = qualifyIfaceType ( ty, ctx0 );
/* stick the tycon's kind on, if not simply STAR */
if (whatIs(tycon(tc).kind) != STAR)
ty = 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
*/
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++) {
}
-static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
+static Name startGHCConstr ( Int line, Int conNo, Z4Ble constr )
{
- /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
+ /* constr :: ((ConId,[((Type,Text,Int))],Type,Int)) */
/* (ADR) ToDo: add rank2 annotation and existential annotation
* these affect how constr can be used.
*/
- Text con = textOf(zfst3(constr));
- Type type = zthd3(constr);
- Int arity = arityFromType(type);
+ Text con = textOf(zsel14(constr));
+ Type type = zsel34(constr);
+ Int arity = arityFromType(type);
+ Int nStrict = intOf(zsel44(constr));
Name n = findName(con); /* Allocate constructor fun name */
if (isNull(n)) {
n = newName(con,NIL);
textToStr(con)
EEND;
}
- name(n).arity = arity; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(conNo);
- name(n).type = type;
+ name(n).arity = arity; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(conNo);
+ name(n).type = type;
+ name(n).hasStrict = nStrict > 0;
return n;
}
-static Void finishGHCDataDecl ( ConId tyc )
+static List finishGHCDataDecl ( ConId tyc )
{
List nms;
Tycon tc = findTycon(textOf(tyc));
# ifdef DEBUG_IFACE
- printf ( "begin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
+ fprintf ( stderr, "begin finishGHCDataDecl %s\n",
+ textToStr(textOf(tyc)) );
# endif
if (isNull(tc)) internal("finishGHCDataDecl");
Name n = hd(nms);
Int line = name(n).line;
assert(currentModule == name(n).mod);
- name(n).type = conidcellsToTycons(line,name(n).type);
+ name(n).type = conidcellsToTycons(line,name(n).type);
+ name(n).parent = tc; //---????
}
+
+ return tycon(tc).defn;
}
* Newtype decls
* ------------------------------------------------------------------------*/
-Void startGHCNewType ( Int line, List ctx0,
- ConId tycon, List tvs, Cell constr )
+static Void startGHCNewType ( Int line, List ctx0,
+ ConId tycon, List tvs, Cell constr )
{
/* ctx0 :: [((QConId,VarId))] */
/* tycon :: ConId */
# 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)
{
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");
* Class declarations
* ------------------------------------------------------------------------*/
-Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
+static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
Int line;
List ctxt; /* [((QConId, VarId))] */
ConId tc_name; /* ConId */
List mems; /* [((VarId, Type))] */
List tvsInT; /* [VarId] and then [((VarId,Kind))] */
List tvs; /* [((VarId,Kind))] */
+ List ns; /* [Name] */
+ Int mno;
ZPair kinded_tv = hd(kinded_tvs);
Text ct = textOf(tc_name);
Pair newCtx = pair(tc_name, zfst(kinded_tv));
# ifdef DEBUG_IFACE
- printf ( "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;
cclass(nw).line = line;
cclass(nw).arity = 1;
cclass(nw).head = ap(nw,mkOffset(0));
- cclass(nw).kinds = singleton(STAR); /* absolutely no idea at all */
- cclass(nw).instances = NIL; /* what the kind should be */
+ cclass(nw).kinds = singleton( zsnd(kinded_tv) );
+ cclass(nw).instances = NIL;
cclass(nw).numSupers = length(ctxt);
/* Kludge to map the single tyvar in the context to Offset 0.
Need to do something better for multiparam type classes.
-
- cclass(nw).supers = tvsToOffsets(line,ctxt,
- singleton(pair(tv,STAR)));
*/
cclass(nw).supers = tvsToOffsets(line,ctxt,
singleton(kinded_tv));
Name mn;
/* Stick the new context on the member type */
+ memT = dictapsToQualtype(memT);
if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
if (whatIs(memT)==QUAL) {
memT = pair(QUAL,
tvsInT = ifTyvarsIn(memT);
/* tvsInT :: [VarId] */
- /* ToDo: maximally bogus */
- for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
- hd(tvs) = zpair(hd(tvs),STAR);
- /* tvsIntT :: [((VarId,STAR))] */
+ /* ToDo: maximally bogus. We allow the class tyvar to
+ have the kind as supplied by the parser, but we just
+ assume that all others have kind *. It's a kludge.
+ */
+ for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
+ Kind k;
+ if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
+ k = zsnd(kinded_tv); else
+ k = STAR;
+ hd(tvs) = zpair(hd(tvs),k);
+ }
+ /* tvsIntT :: [((VarId,Kind))] */
memT = mkPolyType(tvsToKind(tvsInT),memT);
memT = tvsToOffsets(line,memT,tvsInT);
cclass(nw).members = mems0;
cclass(nw).numMembers = length(mems0);
- /* (ADR) ToDo:
- * cclass(nw).dsels = ?;
- * cclass(nw).dbuild = ?;
- * cclass(nm).dcon = ?;
- * cclass(nm).defaults = ?;
- */
+ ns = NIL;
+ for (mno=0; mno<cclass(nw).numSupers; mno++) {
+ ns = cons(newDSel(nw,mno),ns);
+ }
+ cclass(nw).dsels = rev(ns);
}
}
-static Void finishGHCClass ( Tycon cls_tyc )
+static Class finishGHCClass ( Tycon cls_tyc )
{
List mems;
Int line;
Int ctr;
Class nw = findClass ( textOf(cls_tyc) );
# ifdef DEBUG_IFACE
- printf ( "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
+ fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
# endif
if (isNull(nw)) internal("finishGHCClass");
line = cclass(nw).line;
- ctr = - length(cclass(nw).members);
+ ctr = -2;
assert (currentModule == cclass(nw).mod);
- cclass(nw).level = 0; /* (ADR) ToDo: 1 + max (map level supers) */
+ cclass(nw).level = 0;
cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
Type ty = snd(mem);
Name n = findName(txt);
assert(nonNull(n));
+ name(n).text = txt;
name(n).line = cclass(nw).line;
name(n).type = ty;
- name(n).number = ctr++;
+ name(n).number = ctr--;
+ name(n).arity = arityInclDictParams(name(n).type);
+ name(n).parent = nw;
hd(mems) = n;
}
+
+ return nw;
}
* Instances
* ------------------------------------------------------------------------*/
-Inst startGHCInstance (line,ctxt0,cls,var)
+static Inst startGHCInstance (line,ktyvars,cls,var)
Int line;
-List ctxt0; /* [((QConId, VarId))] */
-Type cls; /* Type */
-VarId var; { /* VarId */
- List tmp, tvs, ks;
+List ktyvars; /* [((VarId,Kind))] */
+Type cls; /* Type */
+VarId var; { /* VarId */
+ List tmp, tvs, ks, spec;
+
+ List xs1, xs2;
+ Kind k;
+
Inst in = newInst();
# ifdef DEBUG_IFACE
- printf ( "begin startGHCInstance\n" );
+ fprintf ( stderr, "begin startGHCInstance\n" );
# endif
- /* Make tvs into a list of tyvars with bogus kinds. */
- tvs = ifTyvarsIn(cls);
- /* tvs :: [VarId] */
+ line = intOf(line);
- ks = NIL;
- for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
- hd(tmp) = zpair(hd(tmp),STAR);
- ks = cons(STAR,ks);
+ tvs = ifTyvarsIn(cls); /* :: [VarId] */
+ /* tvs :: [VarId].
+ The order of tvs is important for tvsToOffsets.
+ tvs should be a permutation of ktyvars. Fish the tyvar kinds
+ out of ktyvars and attach them to tvs.
+ */
+ for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
+ k = NIL;
+ for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
+ if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
+ k = zsnd(hd(xs2));
+ if (isNull(k)) internal("startGHCInstance: finding kinds");
+ hd(xs1) = zpair(hd(xs1),k);
}
- /* tvs :: [((VarId,STAR))] */
+
+ cls = tvsToOffsets(line,cls,tvs);
+ spec = NIL;
+ while (isAp(cls)) {
+ spec = cons(fun(cls),spec);
+ cls = arg(cls);
+ }
+ spec = reverse(spec);
+
inst(in).line = line;
inst(in).implements = NIL;
- inst(in).kinds = ks;
- inst(in).specifics = tvsToOffsets(line,ctxt0,tvs);
- inst(in).numSpecifics = length(ctxt0);
- inst(in).head = tvsToOffsets(line,cls,tvs);
+ inst(in).kinds = simpleKind(length(tvs)); /* do this right */
+ inst(in).specifics = spec;
+ inst(in).numSpecifics = length(spec);
+ inst(in).head = cls;
/* Figure out the name of the class being instanced, and store it
at inst(in).c. finishGHCInstance will resolve it to a real Class. */
{
Cell cl = inst(in).head;
- while (isAp(cl)) cl = arg(cl);
assert(whatIs(cl)==DICTAP);
cl = unap(DICTAP,cl);
cl = fst(cl);
inst(in).c = cl;
}
-#if 0
- Is this still needed?
{
- Name b = newName(inventText(),NIL);
+ Name b = newName( /*inventText()*/ textOf(var),NIL);
name(b).line = line;
- name(b).arity = length(ctxt); /* unused? */
+ name(b).arity = length(spec); /* unused? */ /* and surely wrong */
name(b).number = DFUNNAME;
+ name(b).parent = in;
inst(in).builder = b;
- bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
+ /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
}
-#endif
+
return in;
}
Type cls;
# ifdef DEBUG_IFACE
- printf ( "begin finishGHCInstance\n" );
+ fprintf ( stderr, "begin finishGHCInstance\n" );
# endif
assert (nonNull(in));
assert (currentModule==inst(in).mod);
/* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
- since beginGHCInstance couldn't possibly have resolved it to
+ 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;
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:
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));
return TRUE; /*notreached*/
}
missing:
- printf ( "allTypesKnown: unknown " ); print(type,10); printf("\n");
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
+ fprintf(stderr,"\n");
+# endif
return FALSE;
}
}
-/* --------------------------------------------------------------------------
- * ELF specifics
- * ------------------------------------------------------------------------*/
-
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
-
-#include <elf.h>
-
-static char* findElfSection ( void* objImage, Elf32_Word sh_type )
-{
- Int i;
- char* ehdrC = (char*)objImage;
- Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- char* ptr = NULL;
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == sh_type &&
- i != ehdr->e_shstrndx) {
- ptr = ehdrC + shdr[i].sh_offset;
- break;
- }
- }
- return ptr;
-}
-
-
-static Void resolveReferencesInObjectModule_elf ( Module m,
- Bool verb )
-{
- char symbol[1000]; // ToDo
- int i, j;
- Elf32_Sym* stab = NULL;
- char* strtab;
- char* ehdrC = (char*)(module(m).oImage);
- Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- Elf32_Word* targ;
- // first find "the" symbol table
- // why is this commented out???
- stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
-
- // also go find the string table
- strtab = findElfSection ( ehdrC, SHT_STRTAB );
-
- if (!stab || !strtab)
- internal("resolveReferencesInObjectModule_elf");
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == SHT_REL ) {
- Elf32_Rel* rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
- Int nent = shdr[i].sh_size / sizeof(Elf32_Rel);
- Int target_shndx = shdr[i].sh_info;
- Int symtab_shndx = shdr[i].sh_link;
- stab = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
- targ = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
- if (verb)
- fprintf ( stderr,
- "relocations for section %d using symtab %d\n",
- target_shndx, symtab_shndx );
- for (j = 0; j < nent; j++) {
- Elf32_Addr offset = rtab[j].r_offset;
- Elf32_Word info = rtab[j].r_info;
-
- Elf32_Addr P = ((Elf32_Addr)targ) + offset;
- Elf32_Word* pP = (Elf32_Word*)P;
- Elf32_Addr A = *pP;
- Elf32_Addr S;
-
- if (verb) fprintf ( stderr, "Rel entry %3d is raw(%6p %6p) ",
- j, (void*)offset, (void*)info );
- if (!info) {
- if (verb) fprintf ( stderr, " ZERO\n" );
- S = 0;
- } else {
- if (stab[ ELF32_R_SYM(info)].st_name == 0) {
- if (verb) fprintf ( stderr, "(noname) ");
- /* nameless (local) symbol */
- S = (Elf32_Addr)(ehdrC
- + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
- + stab[ELF32_R_SYM(info)].st_value
- );
- strcpy ( symbol, "(noname)");
- } else {
- strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
- if (verb) fprintf ( stderr, "`%s' ", symbol );
- S = (Elf32_Addr)lookupObjName ( symbol );
- }
- if (verb) fprintf ( stderr, "resolves to %p\n", (void*)S );
- if (!S) {
- fprintf ( stderr, "link failure for `%s'\n",
- strtab+stab[ ELF32_R_SYM(info)].st_name );
- assert(0);
- }
- }
- //fprintf ( stderr, "Reloc: P = %p S = %p A = %p\n\n",
- // (void*)P, (void*)S, (void*)A );
- switch (ELF32_R_TYPE(info)) {
- case R_386_32: *pP = S + A; break;
- case R_386_PC32: *pP = S + A - P; break;
- default: fprintf(stderr,
- "unhandled ELF relocation type %d\n",
- ELF32_R_TYPE(info));
- assert(0);
- }
-
- }
- }
- else
- if (shdr[i].sh_type == SHT_RELA) {
- fprintf ( stderr, "RelA style reloc table -- not yet done" );
- assert(0);
- }
- }
-}
-
-
-static Bool validateOImage_elf ( void* imgV,
- Int size,
- Bool verb )
-{
- Elf32_Shdr* shdr;
- Elf32_Sym* stab;
- int i, j, nent, nstrtab, nsymtabs;
- char* sh_strtab;
- char* strtab;
-
- char* ehdrC = (char*)imgV;
- Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
-
- if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
- ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
- ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
- ehdr->e_ident[EI_MAG3] != ELFMAG3) {
- if (verb) fprintf ( stderr, "Not an ELF header\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is an ELF header\n" );
-
- if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
- if (verb) fprintf ( stderr, "Not 32 bit ELF\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is 32 bit ELF\n" );
-
- if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
- if (verb) fprintf ( stderr, "Is little-endian\n" );
- } else
- if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
- if (verb) fprintf ( stderr, "Is big-endian\n" );
- } else {
- if (verb) fprintf ( stderr, "Unknown endiannness\n" );
- return FALSE;
- }
-
- if (ehdr->e_type != ET_REL) {
- if (verb) fprintf ( stderr, "Not a relocatable object (.o) file\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is a relocatable object (.o) file\n" );
-
- if (verb) fprintf ( stderr, "Architecture is " );
- switch (ehdr->e_machine) {
- case EM_386: if (verb) fprintf ( stderr, "x86\n" ); break;
- case EM_SPARC: if (verb) fprintf ( stderr, "sparc\n" ); break;
- default: if (verb) fprintf ( stderr, "unknown\n" ); return FALSE;
- }
-
- if (verb)
- fprintf ( stderr,
- "\nSection header table: start %d, n_entries %d, ent_size %d\n",
- ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize );
-
- assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
-
- shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
-
- if (ehdr->e_shstrndx == SHN_UNDEF) {
- if (verb) fprintf ( stderr, "No section header string table\n" );
- sh_strtab = NULL;
- return FALSE;
- } else {
- if (verb) fprintf ( stderr,"Section header string table is section %d\n",
- ehdr->e_shstrndx);
- sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
- }
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (verb) fprintf ( stderr, "%2d: ", i );
- if (verb) fprintf ( stderr, "type=%2d ", shdr[i].sh_type );
- if (verb) fprintf ( stderr, "size=%4d ", shdr[i].sh_size );
- if (verb) fprintf ( stderr, "offs=%4d ", shdr[i].sh_offset );
- if (verb) fprintf ( stderr, " (%p .. %p) ",
- ehdrC + shdr[i].sh_offset,
- ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
-
- if (shdr[i].sh_type == SHT_REL && verb) fprintf ( stderr, "Rel " ); else
- if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else
- if (verb) fprintf ( stderr, " " );
- if (sh_strtab && verb)
- fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name );
- if (verb) fprintf ( stderr, "\n" );
- }
-
- if (verb) fprintf ( stderr, "\n\nString tables\n" );
- strtab = NULL;
- nstrtab = 0;
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == SHT_STRTAB &&
- i != ehdr->e_shstrndx) {
- if (verb)
- fprintf ( stderr, " section %d is a normal string table\n", i );
- strtab = ehdrC + shdr[i].sh_offset;
- nstrtab++;
- }
- }
- if (nstrtab != 1) {
- if (verb) fprintf ( stderr, "WARNING: no string tables, or too many\n" );
- return FALSE;
- }
-
- nsymtabs = 0;
- if (verb) fprintf ( stderr, "\n\nSymbol tables\n" );
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type != SHT_SYMTAB) continue;
- if (verb) fprintf ( stderr, "section %d is a symbol table\n", i );
- nsymtabs++;
- stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
- nent = shdr[i].sh_size / sizeof(Elf32_Sym);
- if (verb) fprintf ( stderr, " number of entries is apparently %d (%d rem)\n",
- nent,
- shdr[i].sh_size % sizeof(Elf32_Sym)
- );
- if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
- if (verb) fprintf ( stderr, "non-integral number of symbol table entries\n");
- return FALSE;
- }
- for (j = 0; j < nent; j++) {
- if (verb) fprintf ( stderr, " %2d ", j );
- if (verb) fprintf ( stderr, " sec=%-5d size=%-3d val=%-5p ",
- (int)stab[j].st_shndx,
- (int)stab[j].st_size,
- (char*)stab[j].st_value );
-
- if (verb) fprintf ( stderr, "type=" );
- switch (ELF32_ST_TYPE(stab[j].st_info)) {
- case STT_NOTYPE: if (verb) fprintf ( stderr, "notype " ); break;
- case STT_OBJECT: if (verb) fprintf ( stderr, "object " ); break;
- case STT_FUNC : if (verb) fprintf ( stderr, "func " ); break;
- case STT_SECTION: if (verb) fprintf ( stderr, "section" ); break;
- case STT_FILE: if (verb) fprintf ( stderr, "file " ); break;
- default: if (verb) fprintf ( stderr, "? " ); break;
- }
- if (verb) fprintf ( stderr, " " );
-
- if (verb) fprintf ( stderr, "bind=" );
- switch (ELF32_ST_BIND(stab[j].st_info)) {
- case STB_LOCAL : if (verb) fprintf ( stderr, "local " ); break;
- case STB_GLOBAL: if (verb) fprintf ( stderr, "global" ); break;
- case STB_WEAK : if (verb) fprintf ( stderr, "weak " ); break;
- default: if (verb) fprintf ( stderr, "? " ); break;
- }
- if (verb) fprintf ( stderr, " " );
-
- if (verb) fprintf ( stderr, "name=%s\n", strtab + stab[j].st_name );
- }
- }
-
- if (nsymtabs == 0) {
- if (verb) fprintf ( stderr, "Didn't find any symbol tables\n" );
- return FALSE;
- }
-
- return TRUE;
-}
-
-
-static void readSyms_elf ( Module m, Bool verb )
-{
- int i, j, k, nent;
- Elf32_Sym* stab;
-
- char* ehdrC = (char*)(module(m).oImage);
- Elf32_Ehdr* ehdr = (Elf32_Ehdr*)ehdrC;
- char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
-
- if (!strtab) internal("readSyms_elf");
-
- k = 0;
- for (i = 0; i < ehdr->e_shnum; i++) {
-
- /* make a HugsDLSection entry for relevant sections */
- DLSect kind = HUGS_DL_SECTION_OTHER;
- if (0==strcmp(".data",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".data1",sh_strtab+shdr[i].sh_name))
- kind = HUGS_DL_SECTION_RWDATA;
- if (0==strcmp(".text",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
- kind = HUGS_DL_SECTION_CODE_OR_RODATA;
- if (kind != HUGS_DL_SECTION_OTHER)
- addDLSect (
- m,
- ehdrC + shdr[i].sh_offset,
- ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1,
- kind
- );
-
- if (shdr[i].sh_type != SHT_SYMTAB) continue;
-
- /* copy stuff into this module's object symbol table */
- stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
- nent = shdr[i].sh_size / sizeof(Elf32_Sym);
- for (j = 0; j < nent; j++) {
- if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ||
- ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
- )
- &&
- ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
- ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
- ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE)
- ) {
- char* nm = strtab + stab[j].st_name;
- char* ad = ehdrC
- + shdr[ stab[j].st_shndx ].sh_offset
- + stab[j].st_value;
- assert(nm);
- assert(ad);
- if (verb)
- fprintf(stderr, "addOTabName: %10p %s %s\n",
- ad, textToStr(module(m).text), nm );
- addOTabName ( m, nm, ad );
- }
- //else fprintf(stderr, "skipping `%s'\n", strtab + stab[j].st_name );
- }
-
- }
-}
-
-#endif /* defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) */
-
/* --------------------------------------------------------------------------
- * Arch-independent interface to the runtime linker
+ * General object symbol query stuff
* ------------------------------------------------------------------------*/
-static Bool validateOImage ( void* img, Int size, Bool verb )
-{
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- return
- validateOImage_elf ( img, size, verb );
-#else
- internal("validateOImage: not implemented on this platform");
+#define EXTERN_SYMS_ALLPLATFORMS \
+ SymX(MainRegTable) \
+ Sym(stg_gc_enter_1) \
+ Sym(stg_gc_noregs) \
+ Sym(stg_gc_seq_1) \
+ Sym(stg_gc_d1) \
+ Sym(stg_gc_f1) \
+ Sym(stg_chk_0) \
+ Sym(stg_chk_1) \
+ Sym(stg_gen_chk) \
+ SymX(stg_exit) \
+ SymX(stg_update_PAP) \
+ SymX(stg_error_entry) \
+ SymX(__ap_2_upd_info) \
+ SymX(__ap_3_upd_info) \
+ SymX(__ap_4_upd_info) \
+ SymX(__ap_5_upd_info) \
+ SymX(__ap_6_upd_info) \
+ SymX(__ap_7_upd_info) \
+ SymX(__ap_8_upd_info) \
+ SymX(__sel_0_upd_info) \
+ SymX(__sel_1_upd_info) \
+ SymX(__sel_2_upd_info) \
+ SymX(__sel_3_upd_info) \
+ SymX(__sel_4_upd_info) \
+ SymX(__sel_5_upd_info) \
+ SymX(__sel_6_upd_info) \
+ SymX(__sel_7_upd_info) \
+ SymX(__sel_8_upd_info) \
+ SymX(__sel_9_upd_info) \
+ SymX(__sel_10_upd_info) \
+ SymX(__sel_11_upd_info) \
+ SymX(__sel_12_upd_info) \
+ SymX(Upd_frame_info) \
+ SymX(seq_frame_info) \
+ SymX(CAF_BLACKHOLE_info) \
+ SymX(IND_STATIC_info) \
+ SymX(EMPTY_MVAR_info) \
+ SymX(MUT_ARR_PTRS_FROZEN_info) \
+ SymX(newCAF) \
+ SymX(putMVarzh_fast) \
+ SymX(newMVarzh_fast) \
+ SymX(takeMVarzh_fast) \
+ SymX(catchzh_fast) \
+ SymX(raisezh_fast) \
+ SymX(delayzh_fast) \
+ SymX(yieldzh_fast) \
+ SymX(killThreadzh_fast) \
+ SymX(waitReadzh_fast) \
+ SymX(waitWritezh_fast) \
+ SymX(CHARLIKE_closure) \
+ SymX(INTLIKE_closure) \
+ SymX(suspendThread) \
+ SymX(resumeThread) \
+ Sym(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) \
+ Sym(mkdir) \
+ SymX(close) \
+ Sym(opendir) \
+ Sym(closedir) \
+ Sym(readdir) \
+ Sym(tcgetattr) \
+ Sym(tcsetattr) \
+ SymX(isatty) \
+ SymX(read) \
+ SymX(lseek) \
+ SymX(write) \
+ Sym(getrusage) \
+ SymX(realloc) \
+ SymX(getcwd) \
+ SymX(free) \
+ SymX(strcpy) \
+ Sym(fcntl) \
+ SymX(fprintf) \
+ SymX(exit) \
+ Sym(open) \
+ SymX(unlink) \
+ SymX(memcpy) \
+ SymX(memchr) \
+ SymX(rmdir) \
+ SymX(rename) \
+ SymX(chdir) \
+ SymX(execl) \
+ Sym(waitpid) \
+ 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(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) \
+ Sym(gettimeofday) \
+
+#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
-}
-
-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(cygwin32_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
#endif
-}
-/* --------------------------------------------------------------------------
- * General object symbol query stuff
- * ------------------------------------------------------------------------*/
/* entirely bogus claims about types of these symbols */
-extern int stg_gc_enter_1;
-extern int stg_chk_0;
-extern int stg_chk_1;
-extern int stg_update_PAP;
-extern int __ap_2_upd_info;
-extern int MainRegTable;
-extern int Upd_frame_info;
-extern int CAF_BLACKHOLE_info;
-extern int IND_STATIC_info;
-extern int newCAF;
-
+#define Sym(vvv) extern void (vvv);
+#define SymX(vvv) /**/
+EXTERN_SYMS_ALLPLATFORMS
+EXTERN_SYMS_THISPLATFORM
+#undef Sym
+#undef SymX
+
+
+#define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ (void*)(&(vvv)) },
+#define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ (void*)(&(vvv)) },
OSym rtsTab[]
= {
- { "stg_gc_enter_1", &stg_gc_enter_1 },
- { "stg_chk_0", &stg_chk_0 },
- { "stg_chk_1", &stg_chk_1 },
- { "stg_update_PAP", &stg_update_PAP },
- { "__ap_2_upd_info", &__ap_2_upd_info },
- { "MainRegTable", &MainRegTable },
- { "Upd_frame_info", &Upd_frame_info },
- { "CAF_BLACKHOLE_info", &CAF_BLACKHOLE_info },
- { "IND_STATIC_info", &IND_STATIC_info },
- { "newCAF", &newCAF },
+ EXTERN_SYMS_ALLPLATFORMS
+ EXTERN_SYMS_THISPLATFORM
{0,0}
};
+#undef Sym
+#undef SymX
+
+
+
+
+/* A kludge to assist Win32 debugging. */
+char* nameFromStaticOPtr ( void* ptr )
+{
+ int k;
+ for (k = 0; rtsTab[k].nm; k++)
+ if (ptr == rtsTab[k].ad)
+ return rtsTab[k].nm;
+ return NULL;
+}
void* lookupObjName ( char* nm )
Text t;
Module m;
char nm2[200];
+ int first_real_char;
nm2[199] = 0;
strncpy(nm2,nm,200);
- // first see if it's an RTS name
+ /* first see if it's an RTS name */
for (k = 0; rtsTab[k].nm; k++)
if (0==strcmp(nm2,rtsTab[k].nm))
return rtsTab[k].ad;
- // if not an RTS name, look in the
- // relevant module's object symbol table
- pp = strchr(nm2, '_');
- if (!pp) goto not_found;
+ /* perhaps an extra-symbol ? */
+ a = lookupOExtraTabName ( nm );
+ if (a) return a;
+
+# if LEADING_UNDERSCORE
+ first_real_char = 1;
+# else
+ first_real_char = 0;
+# endif
+
+ /* Maybe it's an __init_Module thing? */
+ if (strlen(nm2+first_real_char) > 7
+ && strncmp(nm2+first_real_char, "__init_", 7)==0) {
+ t = unZcodeThenFindText(nm2+first_real_char+7);
+ if (t == findText("PrelGHC")) return (4+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 = unZcodeThenFindText(nm2);
+ t = unZcodeThenFindText(nm2+first_real_char);
m = findModule(t);
- if (isNull(m)) goto not_found;
-fprintf(stderr, " %%%% %s\n", nm );
- 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);
}
projects / ghc-hetmet.git / blobdiff