* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.23 $
- * $Date: 2000/01/07 16:56:47 $
+ * $Revision: 1.53 $
+ * $Date: 2000/04/12 09:43:10 $
* ------------------------------------------------------------------------*/
-#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 VERBOSE FALSE
-extern void print ( Cell, Int );
+/*#define DEBUG_IFACE*/
+#define VERBOSE FALSE
/* --------------------------------------------------------------------------
* (This comment is now out of date. JRS, 991216).
* local function prototypes:
* ------------------------------------------------------------------------*/
-static Void startGHCValue Args((Int,VarId,Type));
-static Void finishGHCValue Args((VarId));
-
-static Void startGHCSynonym Args((Int,Cell,List,Type));
-static Void finishGHCSynonym Args((Tycon));
-
-static Void startGHCClass Args((Int,List,Cell,List,List));
-static Void finishGHCClass Args((Class));
+static Void startGHCValue ( Int,VarId,Type );
+static Void finishGHCValue ( VarId );
-static Inst startGHCInstance Args((Int,List,Pair,VarId));
-static Void finishGHCInstance Args((Inst));
+static Void startGHCSynonym ( Int,Cell,List,Type );
+static Void finishGHCSynonym ( Tycon );
-static Void startGHCImports Args((ConId,List));
-static Void finishGHCImports Args((ConId,List));
+static Void startGHCClass ( Int,List,Cell,List,List );
+static Class finishGHCClass ( Class );
-static Void startGHCExports Args((ConId,List));
-static Void finishGHCExports Args((ConId,List));
+static Inst startGHCInstance ( Int,List,Pair,VarId );
+static Void finishGHCInstance ( Inst );
-static Void finishGHCModule Args((Cell));
-static Void startGHCModule Args((Text, Int, Text));
+static Void startGHCImports ( ConId,List );
+static Void finishGHCImports ( ConId,List );
-static Void startGHCDataDecl Args((Int,List,Cell,List,List));
-static Void finishGHCDataDecl ( ConId tyc );
+static Void startGHCExports ( ConId,List );
+static Void finishGHCExports ( ConId,List );
-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 );
* ------------------------------------------------------------------------*/
/* 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 );
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.
+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;
+ }
- Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
-*/
-Bool processInterfaces ( void )
+ 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;
- Bool didPrelude;
+ 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(ifaces_outstanding)) return FALSE;
+ 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.
*/
- didPrelude = FALSE;
+ cls_list = NIL;
+ constructor_list = NIL;
for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
iface = unap(I_INTERFACE,hd(xs));
mname = textOf(zfst(iface));
setCurrModule(mod);
ppModule ( module(mod).text );
- if (mname == textPrelude) didPrelude = TRUE;
-
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
switch(whatIs(decl)) {
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: {
}
}
}
- fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
- fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\n+++++++++++++++++++++++++++++"
+ "++++++++++++++++++++++++++++\n");
+ fprintf(stderr, "+++++++++++++++++++++++++++++++"
+ "++++++++++++++++++++++++++\n");
+# endif
/* Build the module(m).export lists for each module, by running
through the export lists in the iface. Also, do the implicit
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;
-
- return didPrelude;
}
* 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) {
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;
*/
-Void finishGHCModule ( Cell root )
+static Void finishGHCModule ( Cell root )
{
/* root :: I_INTERFACE */
Cell iface = unap(I_INTERFACE,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);
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;
q = mkQualId(exmod,ex);
c = findQualTyconWithoutConsultingExportList ( q );
if (isNull(c)) goto notfound;
+# ifdef DEBUG_IFACE
fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
+# endif
module(mod).exports = cons(pair(c,NIL), module(mod).exports);
addTycon(c);
break;
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
if (abstract) {
module(mod).exports = cons(pair(c,NIL), module(mod).exports);
addTycon(c);
+# ifdef DEBUG_IFACE
fprintf ( stderr, "(abstract) ");
+# endif
} else {
module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
addTycon(c);
/* isVar since could be a field name */
q = mkQualId(exmod,ent2);
c = findQualNameWithoutConsultingExportList ( q );
+# ifdef DEBUG_IFACE
fprintf(stderr, "%s ", textToStr(name(c).text));
+# endif
assert(nonNull(c));
/* module(mod).exports = cons(c, module(mod).exports); */
addName(c);
}
}
+# 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)) {
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); */
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;
}
}
#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");
}
}
* 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 )
+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);
- /* 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 ))
- */
ty = dictapsToQualtype(ty);
tvs = ifTyvarsIn(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;
# 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)
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));
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,ktyvars,cls,var)
+static Inst startGHCInstance (line,ktyvars,cls,var)
Int line;
List ktyvars; /* [((VarId,Kind))] */
Type cls; /* Type */
Inst in = newInst();
# ifdef DEBUG_IFACE
- printf ( "begin startGHCInstance\n" );
+ fprintf ( stderr, "begin startGHCInstance\n" );
# endif
+ line = intOf(line);
+
tvs = ifTyvarsIn(cls); /* :: [VarId] */
/* tvs :: [VarId].
The order of tvs is important for tvsToOffsets.
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));
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;
}
* General object symbol query stuff
* ------------------------------------------------------------------------*/
-#define EXTERN_SYMS \
+#define EXTERN_SYMS_ALLPLATFORMS \
+ Sym(MainRegTable) \
Sym(stg_gc_enter_1) \
Sym(stg_gc_noregs) \
Sym(stg_gc_seq_1) \
Sym(__ap_4_upd_info) \
Sym(__ap_5_upd_info) \
Sym(__ap_6_upd_info) \
+ Sym(__ap_7_upd_info) \
+ Sym(__ap_8_upd_info) \
Sym(__sel_0_upd_info) \
Sym(__sel_1_upd_info) \
Sym(__sel_2_upd_info) \
Sym(__sel_10_upd_info) \
Sym(__sel_11_upd_info) \
Sym(__sel_12_upd_info) \
- Sym(MainRegTable) \
Sym(Upd_frame_info) \
Sym(seq_frame_info) \
Sym(CAF_BLACKHOLE_info) \
Sym(int2Integerzh_fast) \
Sym(stg_gc_unbx_r1) \
Sym(ErrorHdrHook) \
- Sym(makeForeignObjzh_fast) \
+ Sym(mkForeignObjzh_fast) \
Sym(__encodeDouble) \
Sym(decodeDoublezh_fast) \
Sym(isDoubleNaN) \
Sym(prog_argv) \
Sym(prog_argc) \
Sym(resetNonBlockingFd) \
+ Sym(getStablePtr) \
+ Sym(stable_ptr_table) \
+ Sym(createAdjThunk) \
+ Sym(shutdownHaskellAndExit) \
+ Sym(stg_enterStackTop) \
+ Sym(CAF_UNENTERED_entry) \
+ Sym(stg_yield_to_Hugs) \
+ Sym(StgReturn) \
+ Sym(init_stack) \
\
/* needed by libHS_cbits */ \
SymX(malloc) \
- Sym(__errno_location) \
SymX(close) \
- Sym(__xstat) \
- Sym(__fxstat) \
- Sym(__lxstat) \
Sym(mkdir) \
SymX(close) \
Sym(opendir) \
SymX(lseek) \
SymX(write) \
Sym(getrusage) \
- Sym(gettimeofday) \
SymX(realloc) \
SymX(getcwd) \
SymX(free) \
SymX(strcpy) \
- SymX(select) \
Sym(fcntl) \
- SymX(stderr) \
SymX(fprintf) \
SymX(exit) \
Sym(open) \
SymX(rmdir) \
SymX(rename) \
SymX(chdir) \
- Sym(localtime) \
- Sym(strftime) \
- SymX(vfork) \
SymX(execl) \
- SymX(_exit) \
Sym(waitpid) \
- Sym(tzname) \
- Sym(timezone) \
- Sym(mktime) \
- Sym(gmtime) \
+ 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) \
+ Sym(log) \
+ Sym(exp) \
+ Sym(sqrt) \
+ Sym(sin) \
+ Sym(cos) \
+ Sym(tan) \
+ Sym(asin) \
+ Sym(acos) \
+ Sym(atan) \
+ Sym(sinh) \
+ Sym(cosh) \
+ Sym(tanh) \
+ Sym(pow) \
+ Sym(__errno) \
+ Sym(stat) \
+ Sym(fstat) \
+ Sym(gettimeofday) \
+ SymX(localtime) \
+ SymX(strftime) \
+ SymX(mktime) \
+ SymX(gmtime)
-/* AJG Hack */
-#if 0
-#undef EXTERN_SYMS
-#define EXTERN_SYMS
+#define EXTERN_SYMS_linux \
+ Sym(__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
+
+#if defined(solaris2_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
#endif
+#if defined(cygwin32_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
+#endif
+
+
+
+
/* entirely bogus claims about types of these symbols */
-#define Sym(vvv) extern int vvv;
-#define SymX(vvv) /* nothing */
-EXTERN_SYMS
+#define Sym(vvv) extern void (vvv);
+#define SymX(vvv) /**/
+EXTERN_SYMS_ALLPLATFORMS
+EXTERN_SYMS_THISPLATFORM
#undef Sym
#undef SymX
-#define Sym(vvv) { #vvv, &vvv },
-#define SymX(vvv) { #vvv, &vvv },
+
+#define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ &(vvv) },
+#define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ &(vvv) },
OSym rtsTab[]
= {
- EXTERN_SYMS
+ 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 )
{
int k;
Text t;
Module m;
char nm2[200];
+ int first_real_char;
nm2[199] = 0;
strncpy(nm2,nm,200);
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, '_');
- 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;
}
projects / ghc-hetmet.git / blobdiff