* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.38 $
- * $Date: 2000/03/13 11:37:16 $
+ * $Revision: 1.45 $
+ * $Date: 2000/04/05 09:22:28 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
static Void finishGHCModule ( Cell );
-static Void startGHCModule ( Text, Int, Text );
+static Void startGHCModule ( Text );
static Void startGHCDataDecl ( Int,List,Cell,List,List );
static List finishGHCDataDecl ( ConId tyc );
static List ifTyvarsIn ( Type );
static Type tvsToOffsets ( Int,Type,List );
static Type conidcellsToTycons ( Int,Type );
-static void* lookupObjName ( char* );
}
-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;
conArgStrictness = intOf(zthd3(conArg));
tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
tyvarsMentioned);
- if (conArgStrictness > 0) conArgTy = bang(conArgTy);
+ /* Not sure what the deal is with strictness. Do we need
+ to notify the symbol table, or not? The Hugs desugarer?
+ Currently disabled. */
+ /* if (conArgStrictness > 0) conArgTy = bang(conArgTy); */
ty = fn(conArgTy,ty);
if (nonNull(conArgNm)) {
/* a field name is mentioned too */
* ------------------------------------------------------------------------*/
#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)
#define EXTERN_SYMS_cygwin32 \
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 not_found;
+ a = lookupOTabName ( m, nm );
+ if (a) return a;
+ goto not_found;
+ }
+
+ /* 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;
*pp = 0;
fprintf ( stderr,
"lookupObjName: can't resolve name `%s'\n",
nm );
-assert(4-4);
+ assert(4-4);
return NULL;
}
projects / ghc-hetmet.git / blobdiff