Fix for feature request #655 (Loading the GHC library from GHCi.)
[ghc-hetmet.git] / ghc / rts / Linker.c
index cb40fbd..87fda47 100644 (file)
@@ -132,19 +132,17 @@ typedef struct _RtsSymbolVal {
 
 
 #if !defined(PAR)
-#define Maybe_ForeignObj        SymX(mkForeignObjzh_fast)
-
 #define Maybe_Stable_Names      SymX(mkWeakzh_fast)                    \
                                SymX(makeStableNamezh_fast)             \
                                SymX(finalizzeWeakzh_fast)
 #else
 /* These are not available in GUM!!! -- HWL */
-#define Maybe_ForeignObj
 #define Maybe_Stable_Names
 #endif
 
 #if !defined (mingw32_HOST_OS)
 #define RTS_POSIX_ONLY_SYMBOLS                  \
+      SymX(signal_handlers)                    \
       SymX(stg_sig_install)                    \
       Sym(nocldstop)
 #endif
@@ -321,6 +319,56 @@ typedef struct _RtsSymbolVal {
       Sym(closedir)
 #endif
 
+#if defined(darwin_TARGET_OS) && HAVE_PRINTF_LDBLSTUB
+#define RTS_DARWIN_ONLY_SYMBOLS                        \
+     Sym(asprintf$LDBLStub)                     \
+     Sym(err$LDBLStub)                          \
+     Sym(errc$LDBLStub)                         \
+     Sym(errx$LDBLStub)                         \
+     Sym(fprintf$LDBLStub)                      \
+     Sym(fscanf$LDBLStub)                       \
+     Sym(fwprintf$LDBLStub)                     \
+     Sym(fwscanf$LDBLStub)                      \
+     Sym(printf$LDBLStub)                       \
+     Sym(scanf$LDBLStub)                        \
+     Sym(snprintf$LDBLStub)                     \
+     Sym(sprintf$LDBLStub)                      \
+     Sym(sscanf$LDBLStub)                       \
+     Sym(strtold$LDBLStub)                      \
+     Sym(swprintf$LDBLStub)                     \
+     Sym(swscanf$LDBLStub)                      \
+     Sym(syslog$LDBLStub)                       \
+     Sym(vasprintf$LDBLStub)                    \
+     Sym(verr$LDBLStub)                         \
+     Sym(verrc$LDBLStub)                        \
+     Sym(verrx$LDBLStub)                        \
+     Sym(vfprintf$LDBLStub)                     \
+     Sym(vfscanf$LDBLStub)                      \
+     Sym(vfwprintf$LDBLStub)                    \
+     Sym(vfwscanf$LDBLStub)                     \
+     Sym(vprintf$LDBLStub)                      \
+     Sym(vscanf$LDBLStub)                       \
+     Sym(vsnprintf$LDBLStub)                    \
+     Sym(vsprintf$LDBLStub)                     \
+     Sym(vsscanf$LDBLStub)                      \
+     Sym(vswprintf$LDBLStub)                    \
+     Sym(vswscanf$LDBLStub)                     \
+     Sym(vsyslog$LDBLStub)                      \
+     Sym(vwarn$LDBLStub)                        \
+     Sym(vwarnc$LDBLStub)                       \
+     Sym(vwarnx$LDBLStub)                       \
+     Sym(vwprintf$LDBLStub)                     \
+     Sym(vwscanf$LDBLStub)                      \
+     Sym(warn$LDBLStub)                         \
+     Sym(warnc$LDBLStub)                        \
+     Sym(warnx$LDBLStub)                        \
+     Sym(wcstold$LDBLStub)                      \
+     Sym(wprintf$LDBLStub)                      \
+     Sym(wscanf$LDBLStub)
+#else
+#define RTS_DARWIN_ONLY_SYMBOLS
+#endif
+
 #ifndef SMP
 # define MAIN_CAP_SYM SymX(MainCapability)
 #else
@@ -329,7 +377,6 @@ typedef struct _RtsSymbolVal {
 
 #if !defined(mingw32_HOST_OS)
 #define RTS_USER_SIGNALS_SYMBOLS \
-   SymX(startSignalHandler) \
    SymX(setIOManagerPipe)
 #else
 #define RTS_USER_SIGNALS_SYMBOLS /* nothing */
@@ -359,7 +406,6 @@ typedef struct _RtsSymbolVal {
 #endif
 
 #define RTS_SYMBOLS                            \
-      Maybe_ForeignObj                         \
       Maybe_Stable_Names                       \
       Sym(StgReturn)                           \
       SymX(stg_enter_info)                     \
@@ -428,6 +474,7 @@ typedef struct _RtsSymbolVal {
       SymX(delayzh_fast)                       \
       SymX(deRefWeakzh_fast)                   \
       SymX(deRefStablePtrzh_fast)              \
+      SymX(dirty_MUT_VAR)                      \
       SymX(divExactIntegerzh_fast)             \
       SymX(divModIntegerzh_fast)               \
       SymX(forkzh_fast)                                \
@@ -537,7 +584,6 @@ typedef struct _RtsSymbolVal {
       SymX(rts_mkWord8)                                \
       SymX(rts_unlock)                         \
       SymX(rtsSupportsBoundThreads)            \
-      SymX(run_queue_hd)                       \
       SymX(__hscore_get_saved_termios)         \
       SymX(__hscore_set_saved_termios)         \
       SymX(setProgArgv)                                \
@@ -552,6 +598,7 @@ typedef struct _RtsSymbolVal {
       SymX(stg_EMPTY_MVAR_info)                        \
       SymX(stg_IND_STATIC_info)                        \
       SymX(stg_INTLIKE_closure)                        \
+      SymX(stg_MUT_ARR_PTRS_DIRTY_info)                \
       SymX(stg_MUT_ARR_PTRS_FROZEN_info)       \
       SymX(stg_MUT_ARR_PTRS_FROZEN0_info)      \
       SymX(stg_WEAK_info)                       \
@@ -609,6 +656,19 @@ typedef struct _RtsSymbolVal {
       SymX(writeTVarzh_fast)                   \
       SymX(xorIntegerzh_fast)                  \
       SymX(yieldzh_fast)                        \
+      SymX(stg_interp_constr_entry)             \
+      SymX(stg_interp_constr1_entry)            \
+      SymX(stg_interp_constr2_entry)            \
+      SymX(stg_interp_constr3_entry)            \
+      SymX(stg_interp_constr4_entry)            \
+      SymX(stg_interp_constr5_entry)            \
+      SymX(stg_interp_constr6_entry)            \
+      SymX(stg_interp_constr7_entry)            \
+      SymX(stg_interp_constr8_entry)            \
+      SymX(stgMallocBytesRWX)                   \
+      SymX(getAllocations)                      \
+      SymX(revertCAFs)                          \
+      SymX(RtsFlags)                            \
       RTS_USER_SIGNALS_SYMBOLS
 
 #ifdef SUPPORT_LONG_LONGS
@@ -662,6 +722,7 @@ RTS_LONG_LONG_SYMS
 RTS_POSIX_ONLY_SYMBOLS
 RTS_MINGW_ONLY_SYMBOLS
 RTS_CYGWIN_ONLY_SYMBOLS
+RTS_DARWIN_ONLY_SYMBOLS
 RTS_LIBGCC_SYMBOLS
 #undef Sym
 #undef SymX
@@ -1017,7 +1078,7 @@ void ghci_enquire ( char* addr )
             // debugBelch("ghci_enquire: can't find %s\n", sym);
          }
          else if (addr-DELTA <= a && a <= addr+DELTA) {
-            debugBelch("%p + %3d  ==  `%s'\n", addr, a - addr, sym);
+            debugBelch("%p + %3d  ==  `%s'\n", addr, (int)(a - addr), sym);
          }
       }
    }
@@ -1165,6 +1226,7 @@ loadObj( char *path )
     // reading the file, and then we misalign oc->image on purpose so
     // that the actual sections end up aligned again.
    misalignment = machoGetMisalignment(f);
+   oc->misalignment = misalignment;
 #else
    misalignment = 0;
 #endif
@@ -1381,6 +1443,10 @@ static int ocAllocateJumpIslands( ObjectCode* oc, int count, int first )
   int pagesize, n, m;
 #endif
   int aligned;
+  int misalignment = 0;
+#if darwin_HOST_OS
+  misalignment = oc->misalignment;
+#endif
 
   if( count > 0 )
   {
@@ -1396,28 +1462,46 @@ static int ocAllocateJumpIslands( ObjectCode* oc, int count, int first )
     n = ROUND_UP( oc->fileSize, pagesize );
     m = ROUND_UP( aligned + sizeof (ppcJumpIsland) * count, pagesize );
 
-    /* The effect of this mremap() call is only the ensure that we have
-     * a sufficient number of virtually contiguous pages.  As returned from
-     * mremap, the pages past the end of the file are not backed.  We give
-     * them a backing by using MAP_FIXED to map in anonymous pages.
+    /* If we have a half-page-size file and map one page of it then
+     * the part of the page after the size of the file remains accessible.
+     * If, however, we map in 2 pages, the 2nd page is not accessible
+     * and will give a "Bus Error" on access.  To get around this, we check
+     * if we need any extra pages for the jump islands and map them in
+     * anonymously.  We must check that we actually require extra pages
+     * otherwise the attempt to mmap 0 pages of anonymous memory will
+     * fail -EINVAL.
      */
-    if( (oc->image = mremap( oc->image, n, m, MREMAP_MAYMOVE )) == MAP_FAILED )
-    {
-      errorBelch( "Unable to mremap for Jump Islands\n" );
-      return 0;
-    }
 
-    if( mmap( oc->image + n, m - n, PROT_READ | PROT_WRITE | PROT_EXEC,
-              MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED, 0, 0 ) == MAP_FAILED )
+    if( m > n )
     {
-      errorBelch( "Unable to mmap( MAP_FIXED ) for Jump Islands\n" );
-      return 0;
+      /* The effect of this mremap() call is only the ensure that we have
+       * a sufficient number of virtually contiguous pages.  As returned from
+       * mremap, the pages past the end of the file are not backed.  We give
+       * them a backing by using MAP_FIXED to map in anonymous pages.
+       */
+      oc->image = mremap( oc->image, n, m, MREMAP_MAYMOVE );
+
+      if( oc->image == MAP_FAILED )
+      {
+        errorBelch( "Unable to mremap for Jump Islands\n" );
+        return 0;
+      }
+
+      if( mmap( oc->image + n, m - n, PROT_READ | PROT_WRITE | PROT_EXEC,
+                MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED, 0, 0 ) == MAP_FAILED )
+      {
+        errorBelch( "Unable to mmap( MAP_FIXED ) for Jump Islands\n" );
+        return 0;
+      }
     }
 
 #else
+    oc->image -= misalignment;
     oc->image = stgReallocBytes( oc->image,
+                                 misalignment + 
                                  aligned + sizeof (ppcJumpIsland) * count,
                                  "ocAllocateJumpIslands" );
+    oc->image += misalignment;
 #endif /* USE_MMAP */
 
     oc->jump_islands = (ppcJumpIsland *) (oc->image + aligned);
@@ -1964,19 +2048,37 @@ ocGetNames_PEi386 ( ObjectCode* oc )
    /* Allocate space for any (local, anonymous) .bss sections. */
 
    for (i = 0; i < hdr->NumberOfSections; i++) {
+      UInt32 bss_sz;
       UChar* zspace;
       COFF_section* sectab_i
          = (COFF_section*)
            myindex ( sizeof_COFF_section, sectab, i );
       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
-      if (sectab_i->VirtualSize == 0) continue;
+      /* sof 10/05: the PE spec text isn't too clear regarding what
+       * the SizeOfRawData field is supposed to hold for object
+       * file sections containing just uninitialized data -- for executables,
+       * it is supposed to be zero; unclear what it's supposed to be
+       * for object files. However, VirtualSize is guaranteed to be
+       * zero for object files, which definitely suggests that SizeOfRawData
+       * will be non-zero (where else would the size of this .bss section be
+       * stored?) Looking at the COFF_section info for incoming object files,
+       * this certainly appears to be the case.
+       *
+       * => I suspect we've been incorrectly handling .bss sections in (relocatable)
+       * object files up until now. This turned out to bite us with ghc-6.4.1's use
+       * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
+       * variable decls into to the .bss section. (The specific function in Q which
+       * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
+       */
+      if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
       /* This is a non-empty .bss section.  Allocate zeroed space for
          it, and set its PointerToRawData field such that oc->image +
          PointerToRawData == addr_of_zeroed_space.  */
-      zspace = stgCallocBytes(1, sectab_i->VirtualSize,
-                              "ocGetNames_PEi386(anonymous bss)");
+      bss_sz = sectab_i->VirtualSize;
+      if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
+      zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
-      addProddableBlock(oc, zspace, sectab_i->VirtualSize);
+      addProddableBlock(oc, zspace, bss_sz);
       /* debugBelch("BSS anon section at 0x%x\n", zspace); */
    }
 
@@ -2187,8 +2289,14 @@ ocResolve_PEi386 ( ObjectCode* oc )
         COFF_reloc* rel = (COFF_reloc*)
                            myindex ( sizeof_COFF_reloc, reltab, 0 );
        noRelocs = rel->VirtualAddress;
+
+       /* 10/05: we now assume (and check for) a GNU ld that is capable
+        * of handling object files with (>2^16) of relocs.
+        */
+#if 0
        debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
                   noRelocs);
+#endif
        j = 1;
       } else {
        noRelocs = sectab_i->NumberOfRelocations;
@@ -2662,8 +2770,8 @@ ocVerifyImage_ELF ( ObjectCode* oc )
    }
 
    IF_DEBUG(linker,debugBelch(
-             "\nSection header table: start %d, n_entries %d, ent_size %d\n",
-             ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
+             "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
+             (long)ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
 
    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
 
@@ -2728,9 +2836,9 @@ ocVerifyImage_ELF ( ObjectCode* oc )
       nsymtabs++;
       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
       nent = shdr[i].sh_size / sizeof(Elf_Sym);
-      IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%d rem)\n",
+      IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%ld rem)\n",
                nent,
-               shdr[i].sh_size % sizeof(Elf_Sym)
+               (long)shdr[i].sh_size % sizeof(Elf_Sym)
              ));
       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
@@ -3039,8 +3147,8 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
          case R_386_PC32: *pP = value - P; break;
 #        endif
          default:
-            errorBelch("%s: unhandled ELF relocation(Rel) type %d\n",
-                 oc->fileName, ELF_R_TYPE(info));
+            errorBelch("%s: unhandled ELF relocation(Rel) type %lu\n",
+                 oc->fileName, (lnat)ELF_R_TYPE(info));
             return 0;
       }
 
@@ -3056,7 +3164,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
                           Elf_Sym*  stab, char* strtab )
 {
    int j;
-   char *symbol;
+   char *symbol = NULL;
    Elf_Addr targ;
    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
@@ -3280,8 +3388,8 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
 #endif
 
          default:
-            errorBelch("%s: unhandled ELF relocation(RelA) type %d\n",
-                 oc->fileName, ELF_R_TYPE(info));
+            errorBelch("%s: unhandled ELF relocation(RelA) type %lu\n",
+                 oc->fileName, (lnat)ELF_R_TYPE(info));
             return 0;
       }