From 58cfe8c0196544bd9d53119eb7ebf65bc7245b4a Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 7 Mar 2000 16:18:25 +0000 Subject: [PATCH] [project @ 2000-03-07 16:18:25 by sewardj] Complete the initial implementation and debugging of the Win32 PE (PEi386) linker. --- ghc/interpreter/codegen.c | 30 +++-- ghc/interpreter/interface.c | 267 ++++++++++++++++++++++++++++++++--------- ghc/interpreter/object.c | 276 +++++++++++++++++++++++++++++++++++++------ ghc/interpreter/storage.c | 10 +- ghc/interpreter/storage.h | 12 +- 5 files changed, 488 insertions(+), 107 deletions(-) diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index f442184..781a13c 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: codegen.c,v $ - * $Revision: 1.16 $ - * $Date: 2000/02/08 15:32:29 $ + * $Revision: 1.17 $ + * $Date: 2000/03/07 16:18:25 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -24,6 +24,8 @@ #include "Rts.h" /* IF_DEBUG */ #include "RtsFlags.h" +/*#define DEBUG_CODEGEN*/ + /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ @@ -44,7 +46,6 @@ static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e ); static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts ); static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e ); -//static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e ); static AsmBCO cgLambda ( StgExpr e ); static AsmBCO cgRhs ( StgRhs rhs ); static void beginTop ( StgVar v ); @@ -62,9 +63,10 @@ static Cell cptrFromName ( Name n ) void* p; Module m = name(n).mod; Text mt = module(m).text; - sprintf(buf,"%s_%s_closure", - textToStr(mt), - textToStr( enZcodeThenFindText ( textToStr (name(n).text) ) ) ); + sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"), + textToStr(mt), + textToStr( enZcodeThenFindText ( + textToStr (name(n).text) ) ) ); p = lookupOTabName ( m, buf ); if (!p) { ERRMSG(0) "Can't find object symbol %s", buf @@ -161,8 +163,10 @@ print(e,10);printf("\n"); pushVar(bco,name(e).stgVar); } else { Cell /*CPtr*/ addr = cptrFromName(e); +# ifdef DEBUG_CODEGEN fprintf ( stderr, "nativeAtom: name %s\n", nameFromOPtr(cptrOf(addr)) ); +# endif pushVar(bco,addr); } break; @@ -285,15 +289,6 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e ) } } -#if 0 /* appears to be unused */ -static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e ) -{ - assert(0); /* ToDo: test for patterns */ - map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */ - cgExpr(bco,root,e); -} -#endif - static AsmBCO cgLambda( StgExpr e ) { @@ -558,8 +553,11 @@ static Void build( AsmBCO bco, StgVar v ) if (isCPtr(fun)) { assert(isName(fun0)); itsaPAP = name(fun0).arity > length(args); +# ifdef DEBUG_CODEGEN fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n", - nameFromOPtr(cptrOf(fun)), name(fun0).arity, length(args) ); + nameFromOPtr(cptrOf(fun)), name(fun0).arity, + length(args) ); +# endif } else { itsaPAP = FALSE; if (nonNull(stgVarBody(fun)) diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index d0e753c..15f6803 100644 --- a/ghc/interpreter/interface.c +++ b/ghc/interpreter/interface.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: interface.c,v $ - * $Revision: 1.33 $ - * $Date: 2000/03/02 10:10:33 $ + * $Revision: 1.34 $ + * $Date: 2000/03/07 16:18:25 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -262,7 +262,10 @@ ZPair readInterface(String fname, Long fileSize) 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); @@ -330,11 +333,15 @@ static Bool isExportedIFaceEntity ( Cell ife, List 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; } @@ -380,7 +387,9 @@ static Cell deleteUnexportedIFaceEntities ( Cell root ) 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] */ @@ -422,9 +431,11 @@ static List addTyconsAndClassesFromIFace ( Cell root, List aktys ) 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 } @@ -517,9 +528,11 @@ 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 } @@ -545,9 +558,11 @@ static List abstractifyExDecl ( Cell root, ConId toabs ) static Void ppModule ( Text modt ) { +# ifdef DEBUG_IFACE fflush(stderr); fflush(stdout); fprintf(stderr, "---------------- MODULE %s ----------------\n", textToStr(modt) ); +# endif } @@ -562,7 +577,7 @@ static void* ifFindItblFor ( Name n ) char buf[1000]; Text t; - sprintf ( buf, "%s_%s_con_info", + sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_info"), textToStr( module(name(n).mod).text ), textToStr( name(n).text ) ); t = enZcodeThenFindText(buf); @@ -571,7 +586,7 @@ static void* ifFindItblFor ( Name n ) if (p) return p; if (name(n).arity == 0) { - sprintf ( buf, "%s_%s_static_info", + sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"), textToStr( module(name(n).mod).text ), textToStr( name(n).text ) ); t = enZcodeThenFindText(buf); @@ -690,9 +705,11 @@ Bool processInterfaces ( void ) if (isNull(ifaces_outstanding)) return FALSE; +# 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)) { @@ -728,7 +745,10 @@ Bool processInterfaces ( void ) /* 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; @@ -782,9 +802,11 @@ Bool processInterfaces ( void ) 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 } } @@ -818,7 +840,10 @@ Bool processInterfaces ( void ) 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), @@ -827,7 +852,10 @@ fprintf(stderr, "abstractify data %s\n", textToStr(textOf(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 } } @@ -841,8 +869,9 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) 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; @@ -858,7 +887,10 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) /* 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; @@ -966,8 +998,12 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) } } - 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 @@ -1037,8 +1073,12 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) } } } - 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 @@ -1070,7 +1110,9 @@ static void startGHCModule_errMsg ( char* msg ) static void* startGHCModule_clientLookup ( char* sym ) { +# ifdef DEBUG_IFACE /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */ +# endif return lookupObjName ( sym ); } @@ -1107,8 +1149,10 @@ static Void startGHCModule ( Text mname, Int sizeObj, Text nameObj ) 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; @@ -1176,7 +1220,9 @@ static Void finishGHCModule ( Cell 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); @@ -1203,7 +1249,9 @@ static Void finishGHCModule ( Cell root ) 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; @@ -1212,7 +1260,9 @@ static Void finishGHCModule ( Cell root ) 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; @@ -1224,7 +1274,10 @@ static Void finishGHCModule ( Cell root ) 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 @@ -1236,7 +1289,9 @@ static Void finishGHCModule ( Cell root ) 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); @@ -1246,18 +1301,24 @@ static Void finishGHCModule ( Cell root ) /* 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)) { @@ -1265,12 +1326,16 @@ static Void finishGHCModule ( Cell root ) 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; @@ -1283,8 +1348,10 @@ static Void finishGHCModule ( Cell root ) 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; } } @@ -1336,7 +1403,7 @@ static Void finishGHCModule ( Cell root ) 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. */ } @@ -1344,7 +1411,7 @@ static Void startGHCExports ( 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. */ } @@ -1359,7 +1426,7 @@ static Void startGHCImports ( ConId mn, List syms ) /* 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. */ } @@ -1370,7 +1437,7 @@ static Void finishGHCImports ( ConId nm, List syms ) /* 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. */ } @@ -1447,7 +1514,7 @@ static void startGHCValue ( Int line, VarId vid, Type ty ) 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); @@ -1750,7 +1817,8 @@ 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"); @@ -1836,7 +1904,8 @@ static Void finishGHCNewType ( ConId tyc ) { 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"); @@ -1877,7 +1946,7 @@ List mems0; { /* [((VarId, Type))] */ 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); @@ -1983,7 +2052,7 @@ static Class finishGHCClass ( Tycon cls_tyc ) 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"); @@ -2031,7 +2100,7 @@ VarId var; { /* VarId */ Inst in = newInst(); # ifdef DEBUG_IFACE - printf ( "begin startGHCInstance\n" ); + fprintf ( stderr, "begin startGHCInstance\n" ); # endif line = intOf(line); @@ -2098,7 +2167,7 @@ static Void finishGHCInstance ( Inst in ) Type cls; # ifdef DEBUG_IFACE - printf ( "begin finishGHCInstance\n" ); + fprintf ( stderr, "begin finishGHCInstance\n" ); # endif assert (nonNull(in)); @@ -2334,7 +2403,10 @@ static Bool allTypesKnown ( Type 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; } @@ -2420,7 +2492,25 @@ Type type; { * General object symbol query stuff * ------------------------------------------------------------------------*/ -#define EXTERN_SYMS \ +#if defined(linux_TARGET_OS) +#define IF_linux(xxx) xxx +#define IF_cygwin32(xxx) /**/ +#define IF_solaris2(xxx) /**/ +#endif + +#if defined(solaris2_TARGET_OS) +#define IF_linux(xxx) /**/ +#define IF_cygwin32(xxx) /**/ +#define IF_solaris2(xxx) xxx +#endif + +#if defined(cgywin32_TARGET_OS) +#define IF_linux(xxx) /**/ +#define IF_cygwin32(xxx) xxx +#define IF_solaris2(xxx) /**/ +#endif + +#define EXTERN_SYMS_ALLPLATFORMS \ Sym(stg_gc_enter_1) \ Sym(stg_gc_noregs) \ Sym(stg_gc_seq_1) \ @@ -2522,14 +2612,15 @@ Type type; { Sym(getStablePtr) \ Sym(stable_ptr_table) \ Sym(createAdjThunk) \ + Sym(shutdownHaskellAndExit) \ + Sym(stg_enterStackTop) \ + Sym(CAF_UNENTERED_entry) \ + Sym(stg_yield_to_Hugs) \ + Sym(StgReturn) \ \ /* needed by libHS_cbits */ \ SymX(malloc) \ - Sym(__errno_location) \ SymX(close) \ - Sym(__xstat) \ - Sym(__fxstat) \ - Sym(__lxstat) \ Sym(mkdir) \ SymX(close) \ Sym(opendir) \ @@ -2547,9 +2638,7 @@ Type type; { SymX(getcwd) \ SymX(free) \ SymX(strcpy) \ - SymX(select) \ Sym(fcntl) \ - SymX(stderr) \ SymX(fprintf) \ SymX(exit) \ Sym(open) \ @@ -2561,41 +2650,107 @@ Type type; { SymX(chdir) \ Sym(localtime) \ Sym(strftime) \ - SymX(vfork) \ SymX(execl) \ - SymX(_exit) \ Sym(waitpid) \ - Sym(tzname) \ Sym(timezone) \ Sym(mktime) \ Sym(gmtime) \ - SymX(getenv) \ - Sym(shutdownHaskellAndExit) \ + 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) \ + Sym(__imp__tzname) \ + Sym(__imp__timezone) \ + Sym(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) + + +#if 0 + Sym(__errno_location) \ + Sym(__xstat) \ + Sym(__fxstat) \ + Sym(__lxstat) \ + SymX(select) \ + SymX(vfork) \ + Sym(tzname) \ + SymX(stderr) \ + +#endif -/* AJG Hack; for the moment, make EXTERN_SYMS vanish on Win32 */ -#ifdef _WIN32 -#undef EXTERN_SYMS -#define EXTERN_SYMS +#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; +} + + static void* lookupObjName ( char* nm ) { int k; @@ -2604,6 +2759,7 @@ static void* lookupObjName ( char* nm ) Text t; Module m; char nm2[200]; + int first_real_char; nm2[199] = 0; strncpy(nm2,nm,200); @@ -2620,10 +2776,15 @@ static void* lookupObjName ( char* nm ) /* 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; +# if LEADING_UNDERSCORE + first_real_char = 1; +# else + first_real_char = 0; +# endif + pp = strchr(nm2+first_real_char, '_'); + if (!pp || !isupper(nm2[first_real_char])) goto not_found; *pp = 0; - t = unZcodeThenFindText(nm2); + t = unZcodeThenFindText(nm2+first_real_char); m = findModule(t); if (isNull(m)) goto not_found; diff --git a/ghc/interpreter/object.c b/ghc/interpreter/object.c index 8dc8e5b..fd05a5e 100644 --- a/ghc/interpreter/object.c +++ b/ghc/interpreter/object.c @@ -15,6 +15,7 @@ #include #include #include +#include #include #include "config.h" /* for linux_TARGET_OS etc */ #include "object.h" @@ -487,12 +488,17 @@ typedef /* From PE spec doc, section 5.4.2 and 5.4.4 */ #define IMAGE_SYM_CLASS_EXTERNAL 2 +#define IMAGE_SYM_CLASS_STATIC 3 #define IMAGE_SYM_UNDEFINED 0 /* From PE spec doc, section 4.1 */ #define IMAGE_SCN_CNT_CODE 0x00000020 #define IMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040 +/* From PE spec doc, section 5.2.1 */ +#define IMAGE_REL_I386_DIR32 0x0006 +#define IMAGE_REL_I386_REL32 0x0014 + /* We use myindex to calculate array addresses, rather than simply doing the normal subscript thing. That's because @@ -524,6 +530,96 @@ static void printName ( UChar* name, UChar* strtab ) } +static void copyName ( UChar* name, UChar* strtab, + UChar* dst, int dstSize ) +{ + if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) { + UInt32 strtab_offset = * (UInt32*)(name+4); + strncpy ( dst, strtab+strtab_offset, dstSize ); + dst[dstSize-1] = 0; + } else { + int i = 0; + while (1) { + if (i >= 8) break; + if (name[i] == 0) break; + dst[i] = name[i]; + i++; + } + dst[i] = 0; + } +} + + +static UChar* cstring_from_COFF_symbol_name ( UChar* name, + UChar* strtab ) +{ + UChar* newstr; + /* If the string is longer than 8 bytes, look in the + string table for it -- this will be correctly zero terminated. + */ + if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) { + UInt32 strtab_offset = * (UInt32*)(name+4); + return ((UChar*)strtab) + strtab_offset; + } + /* Otherwise, if shorter than 8 bytes, return the original, + which by defn is correctly terminated. + */ + if (name[7]==0) return name; + /* The annoying case: 8 bytes. Copy into a temporary + (which is never freed ...) + */ + newstr = malloc(9); + if (newstr) { + strncpy(newstr,name,8); + newstr[8] = 0; + } + return newstr; +} + + +/* Just compares the short names (first 8 chars) */ +static COFF_section* findPEi386SectionCalled ( ObjectCode* oc, + char* name ) +{ + int i; + COFF_header* hdr + = (COFF_header*)(oc->oImage); + COFF_section* sectab + = (COFF_section*) ( + ((UChar*)(oc->oImage)) + + sizeof_COFF_header + hdr->SizeOfOptionalHeader + ); + for (i = 0; i < hdr->NumberOfSections; i++) { + UChar* n1; + UChar* n2; + COFF_section* section_i + = (COFF_section*) + myindex ( sizeof_COFF_section, i, sectab ); + n1 = (UChar*) &(section_i->Name); + n2 = name; + if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] && + n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] && + n1[6]==n2[6] && n1[7]==n2[7]) + return section_i; + } + + return NULL; +} + + +static void zapTrailingAtSign ( UChar* sym ) +{ + int i, j; + if (sym[0] == 0) return; + i = 0; + while (sym[i] != 0) i++; + i--; + j = i; + while (j > 0 && isdigit(sym[j])) j--; + if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0; +} + + static int ocVerifyImage_PEi386 ( ObjectCode* oc, int verb ) { int i, j; @@ -531,7 +627,7 @@ static int ocVerifyImage_PEi386 ( ObjectCode* oc, int verb ) COFF_section* sectab; COFF_symbol* symtab; UChar* strtab; - + hdr = (COFF_header*)(oc->oImage); sectab = (COFF_section*) ( ((UChar*)(oc->oImage)) @@ -553,7 +649,7 @@ static int ocVerifyImage_PEi386 ( ObjectCode* oc, int verb ) oc->errMsg("PEi386 with nonempty optional header"); return FALSE; } - if ( (hdr->Characteristics & IMAGE_FILE_RELOCS_STRIPPED) || + if ( /* (hdr->Characteristics & IMAGE_FILE_RELOCS_STRIPPED) || */ (hdr->Characteristics & IMAGE_FILE_EXECUTABLE_IMAGE) || (hdr->Characteristics & IMAGE_FILE_DLL) || (hdr->Characteristics & IMAGE_FILE_SYSTEM) ) { @@ -561,7 +657,6 @@ static int ocVerifyImage_PEi386 ( ObjectCode* oc, int verb ) return FALSE; } if ( (hdr->Characteristics & IMAGE_FILE_BYTES_REVERSED_HI) || - !(hdr->Characteristics & IMAGE_FILE_BYTES_REVERSED_LO) || !(hdr->Characteristics & IMAGE_FILE_32BIT_MACHINE) ) { oc->errMsg("Invalid PEi386 word size or endiannness"); return FALSE; @@ -687,33 +782,6 @@ static int ocVerifyImage_PEi386 ( ObjectCode* oc, int verb ) } -static UChar* cstring_from_COFF_symbol_name ( UChar* name, - UChar* strtab ) -{ - UChar* newstr; - /* If the string is longer than 8 bytes, look in the - string table for it -- this will be correctly zero terminated. - */ - if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) { - UInt32 strtab_offset = * (UInt32*)(name+4); - return ((UChar*)strtab) + strtab_offset; - } - /* Otherwise, if shorter than 8 bytes, return the original, - which by defn is correctly terminated. - */ - if (name[7]==0) return name; - /* The annoying case: 8 bytes. Copy into a temporary - (which is never freed ...) - */ - newstr = malloc(9); - if (newstr) { - strncpy(newstr,name,8); - newstr[8] = 0; - } - return newstr; -} - - static int ocGetNames_PEi386 ( ObjectCode* oc, int verb ) { COFF_header* hdr; @@ -770,9 +838,9 @@ static int ocGetNames_PEi386 ( ObjectCode* oc, int verb ) symtab_i->SectionNumber-1, sectab ); addr = ((UChar*)(oc->oImage)) - + sectabent->PointerToRawData - + symtab_i->Value; - + + (sectabent->PointerToRawData + + symtab_i->Value); + /* fprintf ( stderr, "addSymbol %p `%s'\n", addr,sname); */ if (!addSymbol(oc,sname,addr)) return FALSE; } i += symtab_i->NumberOfAuxSymbols; @@ -789,16 +857,37 @@ static int ocGetNames_PEi386 ( ObjectCode* oc, int verb ) COFF_section* sectab_i = (COFF_section*) myindex ( sizeof_COFF_section, i, sectab ); + /* fprintf ( stderr, "section name = %s\n", sectab_i->Name ); */ +#if 0 + /* I'm sure this is the Right Way to do it. However, the + alternative of testing the sectab_i->Name field seems to + work ok with Cygwin. + */ if (sectab_i->Characteristics & IMAGE_SCN_CNT_CODE || sectab_i->Characteristics & IMAGE_SCN_CNT_INITIALIZED_DATA) kind = HUGS_SECTIONKIND_CODE_OR_RODATA; +#endif + + if (0==strcmp(".text",sectab_i->Name)) + kind = HUGS_SECTIONKIND_CODE_OR_RODATA; + if (0==strcmp(".data",sectab_i->Name) || + 0==strcmp(".bss",sectab_i->Name)) + kind = HUGS_SECTIONKIND_RWDATA; start = ((UChar*)(oc->oImage)) + sectab_i->PointerToRawData; end = start + sectab_i->SizeOfRawData - 1; - addSection ( oc, start, end, kind ); + + if (kind != HUGS_SECTIONKIND_OTHER) { + addSection ( oc, start, end, kind ); + } else { + fprintf ( stderr, "unknown section name = `%s'\n", + sectab_i->Name); + oc->errMsg("Unknown PEi386 section name"); + return FALSE; + } } return TRUE; @@ -807,7 +896,126 @@ static int ocGetNames_PEi386 ( ObjectCode* oc, int verb ) static int ocResolve_PEi386 ( ObjectCode* oc, int verb ) { + COFF_header* hdr; + COFF_section* sectab; + COFF_symbol* symtab; + UChar* strtab; + + UInt32 A; + UInt32 S; + UInt32* pP; + + int i, j; + char symbol[1000]; // ToDo + hdr = (COFF_header*)(oc->oImage); + sectab = (COFF_section*) ( + ((UChar*)(oc->oImage)) + + sizeof_COFF_header + hdr->SizeOfOptionalHeader + ); + symtab = (COFF_symbol*) ( + ((UChar*)(oc->oImage)) + + hdr->PointerToSymbolTable + ); + strtab = ((UChar*)(oc->oImage)) + + hdr->PointerToSymbolTable + + hdr->NumberOfSymbols * sizeof_COFF_symbol; + + for (i = 0; i < hdr->NumberOfSections; i++) { + COFF_section* sectab_i + = (COFF_section*) + myindex ( sizeof_COFF_section, i, sectab ); + COFF_reloc* reltab + = (COFF_reloc*) ( + ((UChar*)(oc->oImage)) + sectab_i->PointerToRelocations + ); + for (j = 0; j < sectab_i->NumberOfRelocations; j++) { + COFF_symbol* sym; + COFF_reloc* reltab_j + = (COFF_reloc*) + myindex ( sizeof_COFF_reloc, j, reltab ); + + /* the location to patch */ + pP = (UInt32*)( + ((UChar*)(oc->oImage)) + + (sectab_i->PointerToRawData + + reltab_j->VirtualAddress) + ); + /* the existing contents of pP */ + A = *pP; + /* the symbol to connect to */ + sym = (COFF_symbol*) + myindex ( sizeof_COFF_symbol, + reltab_j->SymbolTableIndex, symtab ); + if (verb) { + fprintf ( stderr, + "reloc sec %2d num %3d: type 0x%-4x " + "vaddr 0x%-8x name `", + i, j, + (UInt32)reltab_j->Type, + reltab_j->VirtualAddress ); + printName ( sym->Name, strtab ); + fprintf ( stderr, "'\n" ); + } + + if (sym->StorageClass == IMAGE_SYM_CLASS_STATIC) { + COFF_section* section_sym + = findPEi386SectionCalled ( oc, sym->Name ); + if (!section_sym) { + fprintf ( stderr, "bad section = `%s'\n", sym->Name ); + oc->errMsg("Can't find abovementioned PEi386 section"); + return FALSE; + } + S = ((UInt32)(oc->oImage)) + + (section_sym->PointerToRawData + + sym->Value); + } else { + copyName ( sym->Name, strtab, symbol, 1000 ); + zapTrailingAtSign ( symbol ); + S = (UInt32) ocLookupSym ( oc, symbol ); + if (S == 0) + S = (UInt32)(oc->clientLookup ( symbol )); + if (S == 0) { + char errtxt[2000]; + strcpy(errtxt,oc->objFileName); + strcat(errtxt,": unresolvable reference to: "); + strcat(errtxt,symbol); + oc->errMsg(errtxt); + return FALSE; + } + } + + switch (reltab_j->Type) { + case IMAGE_REL_I386_DIR32: + *pP = A + S; + break; + case IMAGE_REL_I386_REL32: + /* Tricky. We have to insert a displacement at + pP which, when added to the PC for the _next_ + insn, gives the address of the target (S). + Problem is to know the address of the next insn + when we only know pP. We assume that this + literal field is always the last in the insn, + so that the address of the next insn is pP+4 + -- hence the constant 4. + Also I don't know if A should be added, but so + far it has always been zero. + */ + assert(A==0); + *pP = S - ((UInt32)pP) - 4; + break; + default: + fprintf(stderr, + "unhandled PEi386 relocation type %d\n", + reltab_j->Type); + oc->errMsg("unhandled PEi386 relocation type"); + return FALSE; + } + + } + } + + return TRUE; } #endif /* defined(cygwin32_TARGET_OS) */ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index cf50bf4..69e9e95 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.46 $ - * $Date: 2000/02/25 10:53:54 $ + * $Revision: 1.47 $ + * $Date: 2000/03/07 16:18:25 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1509,6 +1509,12 @@ char* nameFromOPtr ( void* p ) if (nm) return nm; } } +# if 0 + /* A kludge to assist Win32 debugging; not actually necessary. */ + { char* nm = nameFromStaticOPtr(p); + if (nm) return nm; + } +# endif return NULL; } diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 167fece..3f3ab54 100644 --- a/ghc/interpreter/storage.h +++ b/ghc/interpreter/storage.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: storage.h,v $ - * $Revision: 1.30 $ - * $Date: 2000/03/02 10:10:33 $ + * $Revision: 1.31 $ + * $Date: 2000/03/07 16:18:25 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -1071,4 +1071,12 @@ extern Cell getLastExpr Args((Void)); extern List addTyconsMatching Args((String,List)); extern List addNamesMatching Args((String,List)); +#if LEADING_UNDERSCORE +#define MAYBE_LEADING_UNDERSCORE(sss) _##sss +#define MAYBE_LEADING_UNDERSCORE_STR(sss) "_" sss +#else +#define MAYBE_LEADING_UNDERSCORE(sss) sss +#define MAYBE_LEADING_UNDERSCORE_STR(sss) sss +#endif + /*-------------------------------------------------------------------------*/ -- 1.7.10.4