* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.36 $
- * $Date: 2000/03/10 14:53:00 $
+ * $Revision: 1.49 $
+ * $Date: 2000/04/07 16:25:19 $
* ------------------------------------------------------------------------*/
-#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
* 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 Class 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 finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
-static Void finishGHCModule Args((Cell));
-static Void startGHCModule Args((Text, Int, Text));
+static Void finishGHCModule ( Cell );
+static Void startGHCModule ( Text );
-static Void startGHCDataDecl Args((Int,List,Cell,List,List));
+static Void startGHCDataDecl ( Int,List,Cell,List,List );
static List finishGHCDataDecl ( ConId tyc );
+/* Supporting stuff for {start|finish}GHCDataDecl */
+static List startGHCConstrs ( Int,List,List );
+static Name startGHCSel ( Int,Pair );
+static Name startGHCConstr ( Int,Int,Triple );
-static Void startGHCNewType Args((Int,List,Cell,List,Cell));
+static Void startGHCNewType ( Int,List,Cell,List,Cell );
static Void finishGHCNewType ( 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 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 Kinds tvsToKind ( List );
+static Int arityFromType ( Type );
+static Int arityInclDictParams ( Type );
+static Bool allTypesKnown ( Type type,
+ List aktys /* [QualId] */,
+ ConId thisMod );
-static List ifTyvarsIn Args((Type));
-
-static Type tvsToOffsets Args((Int,Type,List));
-static Type conidcellsToTycons Args((Int,Type));
-
-static void* lookupObjName ( char* );
+static List ifTyvarsIn ( Type );
+static Type tvsToOffsets ( Int,Type,List );
+static Type conidcellsToTycons ( Int,Type );
}
-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) {
# endif
}
}
- return zpair(iface,imports);
+ return imports;
}
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 );
}
-/* ifaces_outstanding holds a list of parsed interfaces
- for which we need to load objects and create symbol
- table entries.
-
- Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
-*/
-Bool processInterfaces ( void )
+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,
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);
/* 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
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)) {
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)) {
case I_DATA: {
Cell ddecl = unap(I_DATA,decl);
List constrs = finishGHCDataDecl ( zsel35(ddecl) );
- constructor_list = appendOnto ( constrs, constructor_list );
+ constructor_list = dupOnto ( constrs, constructor_list );
break;
}
case I_NEWTYPE: {
/* Finished! */
ifaces_outstanding = NIL;
-
- return didPrelude;
}
return lookupObjName ( sym );
}
+static int /*Bool*/ startGHCModule_clientWantsSymbol ( char* sym )
+{
+ if (strcmp(sym,"ghc_cc_ID")==0) return 0;
+ return 1;
+}
+
static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
{
ObjectCode* oc
= ocNew ( startGHCModule_errMsg,
startGHCModule_clientLookup,
+ startGHCModule_clientWantsSymbol,
objNm, objSz );
if (!oc) {
return oc;
}
-static 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);
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
- textToStr(mname), sizeObj );
-# endif
- } 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;
* Data declarations
* ------------------------------------------------------------------------*/
+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))] */
*/
{
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
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;
}
* ------------------------------------------------------------------------*/
#define EXTERN_SYMS_ALLPLATFORMS \
+ Sym(MainRegTable) \
Sym(stg_gc_enter_1) \
Sym(stg_gc_noregs) \
Sym(stg_gc_seq_1) \
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(CAF_UNENTERED_entry) \
Sym(stg_yield_to_Hugs) \
Sym(StgReturn) \
+ Sym(init_stack) \
\
/* needed by libHS_cbits */ \
SymX(malloc) \
SymX(rmdir) \
SymX(rename) \
SymX(chdir) \
- Sym(localtime) \
- Sym(strftime) \
SymX(execl) \
Sym(waitpid) \
- Sym(timezone) \
- Sym(mktime) \
- Sym(gmtime) \
- SymX(getenv)
+ SymX(getenv) \
+ Sym(chmod)
#define EXTERN_SYMS_cygwin32 \
SymX(GetCurrentProcess) \
Sym(setmode) \
SymX(system) \
SymX(sleep) \
- Sym(__imp__tzname) \
- Sym(__imp__timezone) \
- Sym(tzset) \
+ SymX(__imp__tzname) \
+ SymX(__imp__timezone) \
+ SymX(tzset) \
Sym(log) \
Sym(exp) \
Sym(sqrt) \
SymX(stderr) \
SymX(vfork) \
SymX(_exit) \
- Sym(tzname) \
+ SymX(tzname) \
+ SymX(localtime) \
+ SymX(strftime) \
+ SymX(timezone) \
+ SymX(mktime) \
+ SymX(gmtime) \
+ Sym(setitimer) \
#undef SymX
+void init_stack;
+
+
/* A kludge to assist Win32 debugging. */
char* nameFromStaticOPtr ( void* ptr )
{
}
-static void* lookupObjName ( char* nm )
+void* lookupObjName ( char* nm )
{
int k;
char* pp;
a = lookupOExtraTabName ( nm );
if (a) return a;
- /* if not an RTS name, look in the
- relevant module's object symbol table
- */
# 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 not_found;
+ if (!pp || !isupper(nm2[first_real_char])) goto dire_straits;
*pp = 0;
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