[project @ 2000-03-07 16:18:25 by sewardj]

Complete the initial implementation and debugging of the Win32 PE
(PEi386) linker.

5 files changed, 488 insertions, 107 deletions

diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c
index f44218488f..781a13c53f 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 d0e753c635..15f6803178 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 8dc8e5b305..fd05a5e37e 100644
--- a/ghc/interpreter/object.c
+++ b/ghc/interpreter/object.c
@@ -15,6 +15,7 @@
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
+#include <ctype.h>
 #include <assert.h>
 #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 cf50bf464b..69e9e95657 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 167fece9f7..3f3ab54013 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
+
 /*-------------------------------------------------------------------------*/