* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/10/29 11:41:04 $
+ * $Revision: 1.9 $
+ * $Date: 1999/12/03 17:01:21 $
* ------------------------------------------------------------------------*/
/* ToDo:
#include "Assembler.h" /* for wrapping GHC objects */
#include "dynamic.h"
-#define DEBUG_IFACE
+// #define DEBUG_IFACE
+#define VERBOSE FALSE
extern void print ( Cell, Int );
static Void local resolveReferencesInObjectModule Args((Module,Bool));
static Bool local validateOImage Args((void*, Int, Bool));
-static Void local readSyms Args((Module));
+static Void local readSyms Args((Module,Bool));
static void* local lookupObjName ( char* );
}
// Last, but by no means least ...
- resolveReferencesInObjectModule ( mod, FALSE );
+ resolveReferencesInObjectModule ( mod, TRUE );
}
Void openGHCIface(t)
Module m = findModule(t);
if (isNull(m)) {
m = newModule(t);
-printf ( "new module %s\n", textToStr(t) );
+ //printf ( "new module %s\n", textToStr(t) );
} else if (m != modulePrelude) {
ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
EEND;
ERRMSG(0) "Read of object file \"%s\" failed", nameObj
EEND;
}
- if (!validateOImage(img,sizeObj,FALSE)) {
+ if (!validateOImage(img,sizeObj,VERBOSE)) {
ERRMSG(0) "Validation of object file \"%s\" failed", nameObj
EEND;
}
assert(!module(m).oImage);
module(m).oImage = img;
- readSyms(m);
+ readSyms(m,VERBOSE);
if (!cellIsMember(m, ghcModules))
ghcModules = cons(m, ghcModules);
printf("\naddGHCImport %s\n", textToStr(mn) );
# endif
- // Hack to avoid chasing Prel* junk right now
- if (strncmp(textToStr(mn), "Prel",4)==0) return;
+ /* Don't chase PrelGHC -- it doesn't exist */
+ if (strncmp(textToStr(mn), "PrelGHC",7)==0) return;
found = FALSE;
for (t=ifImports; nonNull(t); t=tl(t)) {
List ctx0; /* [(QConId,VarId)] */
Cell tycon; /* ConId */
List ktyvars; /* [(VarId,Kind)] */
-List constrs0; /* [(ConId,[(Type,Text)],NIL)]
+List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)]
The NIL will become the constr's type
- The Text is an optional field name */
+ The Text is an optional field name
+ The Int indicates strictness */
/* ToDo: worry about being given a decl for (->) ?
* and worry about qualidents for ()
*/
Cell conid;
Pair conArg, ctxElem;
Text conArgNm;
+ Int conArgStrictness;
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
tyvarsMentioned = NIL; /* [VarId] */
conArgs = reverse(fields);
for (; nonNull(conArgs); conArgs=tl(conArgs)) {
- conArg = hd(conArgs); /* (Type,Text) */
- conArgTy = fst(conArg);
- conArgNm = snd(conArg);
+ conArg = hd(conArgs); /* (Type,Text) */
+ conArgTy = fst3(conArg);
+ conArgNm = snd3(conArg);
+ conArgStrictness = intOf(thd3(conArg));
tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
tyvarsMentioned);
+ if (conArgStrictness > 0) conArgTy = bang(conArgTy);
ty = fn(conArgTy,ty);
if (nonNull(conArgNm)) {
/* a field name is mentioned too */
static List local addGHCConstrs(line,cons,sels)
Int line;
-List cons; /* [(ConId,[(Type,Text)],Type)] */
+List cons; /* [(ConId,[(Type,Text,Int)],Type)] */
List sels; { /* [(VarId,Type)] */
List cs, ss;
Int conNo = 0; /* or maybe 1? */
static Name local addGHCConstr(line,conNo,constr)
Int line;
Int conNo;
-Triple constr; { /* (ConId,[(Type,Text)],Type) */
+Triple constr; { /* (ConId,[(Type,Text,Int)],Type) */
/* ToDo: add rank2 annotation and existential annotation
* these affect how constr can be used.
*/
}
}
-Void addGHCClass(line,ctxt,tc_name,tv,mems0)
+Void addGHCClass(line,ctxt,tc_name,kinded_tv,mems0)
Int line;
List ctxt; /* [(QConId, VarId)] */
Cell tc_name; /* ConId */
-Text tv; /* VarId */
+Text kinded_tv; /* (VarId, Kind) */
List mems0; { /* [(VarId, Type)] */
List mems; /* [(VarId, Type)] */
List tvsInT; /* [VarId] and then [(VarId,Kind)] */
List tvs; /* [(VarId,Kind)] */
Text ct = textOf(tc_name);
- Pair newCtx = pair(tc_name, tv);
+ Pair newCtx = pair(tc_name, fst(kinded_tv));
# ifdef DEBUG_IFACE
printf ( "\nbegin addGHCclass %s\n", textToStr(ct) );
# endif
/* 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));
+
for (mems=mems0; nonNull(mems); mems=tl(mems)) {
Pair mem = hd(mems);
Void addGHCInstance (line,ctxt0,cls,var)
Int line;
List ctxt0; /* [(QConId, Type)] */
-Pair cls; /* (ConId, [Type]) */
+List cls; /* [(ConId, Type)] */
Text var; { /* Text */
List tmp, tvs, ks;
Inst in = newInst();
# endif
/* Make tvs into a list of tyvars with bogus kinds. */
- tvs = nubList(ifTyvarsIn(snd(cls)));
+ //print ( cls, 10 ); printf ( "\n");
+ tvs = nubList(ifTyvarsIn(cls));
+ //print ( tvs, 10 );
ks = NIL;
for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
hd(tmp) = pair(hd(tmp),STAR);
case QUAL:
return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
tvsToOffsets(line,snd(snd(type)),ktyvars)));
+ case DICTAP: /* bogus ?? */
+ return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
+ case UNBOXEDTUP: /* bogus?? */
+ return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
+ case BANG: /* bogus?? */
+ return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
case VARIDCELL: /* Ha! some real work to do! */
{ Int i = 0;
Text tv = textOf(type);
return NIL; /* NOTREACHED */
}
+/* ToDo: nuke this */
+static Text kludgeGHCPrelText ( Text m )
+{
+ return m;
+#if 0
+ if (strncmp(textToStr(m), "Prel", 4)==0)
+ return textPrelude; else return m;
+#endif
+}
+
/* This is called from the finishGHC* functions. It traverses a structure
and converts conidcells, ie, type constructors parsed by the interface
Tycons or Classes have been loaded into the symbol tables and can be
looked up.
*/
+
static Type local conidcellsToTycons(line,type)
Int line;
Type type; {
return type;
case QUALIDENT:
{ List t;
- Text m = qmodOf(type);
+ Text m = kludgeGHCPrelText(qmodOf(type));
Text v = qtextOf(type);
Module mod = findModule(m);
//printf ( "lookup qualident " ); print(type,100); printf("\n");
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 UNBOXEDTUP:
+ return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
default:
fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
whatIs(type));
{
char symbol[1000]; // ToDo
int i, j;
- Elf32_Sym* stab;
+ 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
- //stab = findElfSection ( objImage, SHT_SYMTAB );
+ // why is this commented out???
+ stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
// also go find the string table
strtab = findElfSection ( ehdrC, SHT_STRTAB );
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 (sh_strtab && verb)
+ fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name );
if (verb) fprintf ( stderr, "\n" );
}
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 );
+ if (verb)
+ fprintf ( stderr, " section %d is a normal string table\n", i );
strtab = ehdrC + shdr[i].sh_offset;
nstrtab++;
}
}
-static void readSyms_elf ( Module m )
+static void readSyms_elf ( Module m, Bool verb )
{
int i, j, k, nent;
Elf32_Sym* stab;
)
&&
( 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_OBJECT ||
+ ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE)
) {
char* nm = strtab + stab[j].st_name;
char* ad = ehdrC
+ stab[j].st_value;
assert(nm);
assert(ad);
- /* fprintf(stderr, "addOTabName: %s %s %p\n",
- textToStr(module(m).text), nm, 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 );
}
}
}
-static Void local readSyms ( Module m )
+static Void local readSyms ( Module m, Bool verb )
{
#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- readSyms_elf ( m );
+ readSyms_elf ( m, verb );
#else
internal("readSyms: not implemented on this platform");
#endif
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;
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 },
+ { "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 },
{0,0}
};
pp = strchr(nm2, '_');
if (!pp) goto not_found;
*pp = 0;
- t = findText(nm2);
+ t = kludgeGHCPrelText( unZcodeThenFindText(nm2) );
m = findModule(t);
if (isNull(m)) goto not_found;
a = lookupOTabName ( m, nm );
projects / ghc-hetmet.git / blobdiff