[project @ 2004-08-13 13:04:50 by simonmar]
[ghc-hetmet.git] / ghc / rts / Linker.c
index 1e35285..e6e82aa 100644 (file)
@@ -1,7 +1,6 @@
 /* -----------------------------------------------------------------------------
- * $Id: Linker.c,v 1.117 2003/03/31 12:35:21 simonmar Exp $
  *
- * (c) The GHC Team, 2000-2003
+ * (c) The GHC Team, 2000-2004
  *
  * RTS Object Linker
  *
@@ -10,6 +9,12 @@
 #if 0
 #include "PosixSource.h"
 #endif
+
+//  Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h>.
+#ifdef __linux__
+#define _GNU_SOURCE
+#endif
+
 #include "Rts.h"
 #include "RtsFlags.h"
 #include "HsFFI.h"
@@ -17,8 +22,8 @@
 #include "Linker.h"
 #include "LinkerInternals.h"
 #include "RtsUtils.h"
-#include "StoragePriv.h"
 #include "Schedule.h"
+#include "Storage.h"
 
 #ifdef HAVE_SYS_TYPES_H
 #include <sys/types.h>
 #include <sys/wait.h>
 #endif
 
-#if defined(ia64_TARGET_ARCH)
+#if defined(ia64_TARGET_ARCH) || defined(openbsd_TARGET_OS)
 #define USE_MMAP
 #include <fcntl.h>
 #include <sys/mman.h>
+
+#if defined(openbsd_TARGET_OS) 
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
 #endif
 
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) || defined(freebsd_TARGET_OS) || defined(netbsd_TARGET_OS)
+#endif
+
+#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) || defined(freebsd_TARGET_OS) || defined(netbsd_TARGET_OS) || defined(openbsd_TARGET_OS)
 #  define OBJFORMAT_ELF
 #elif defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 #  define OBJFORMAT_PEi386
@@ -71,6 +83,7 @@
 #  include <mach-o/loader.h>
 #  include <mach-o/nlist.h>
 #  include <mach-o/reloc.h>
+#  include <mach-o/dyld.h>
 #endif
 
 /* Hash table mapping symbol names to Symbol */
@@ -88,11 +101,12 @@ static int ocVerifyImage_PEi386 ( ObjectCode* oc );
 static int ocGetNames_PEi386    ( ObjectCode* oc );
 static int ocResolve_PEi386     ( ObjectCode* oc );
 #elif defined(OBJFORMAT_MACHO)
+static int ocAllocateJumpIslands_MachO ( ObjectCode* oc );
 static int ocVerifyImage_MachO    ( ObjectCode* oc );
 static int ocGetNames_MachO       ( ObjectCode* oc );
 static int ocResolve_MachO        ( ObjectCode* oc );
 
-static void machoInitSymbolsWithoutUnderscore();
+static void machoInitSymbolsWithoutUnderscore( void );
 #endif
 
 /* -----------------------------------------------------------------------------
@@ -127,7 +141,7 @@ typedef struct _RtsSymbolVal {
 #define RTS_MINGW_ONLY_SYMBOLS /**/
 /* Don't have the ability to read import libs / archives, so
  * we have to stupidly list a lot of what libcygwin.a
- * exports; sigh. 
+ * exports; sigh.
  */
 #define RTS_CYGWIN_ONLY_SYMBOLS                 \
       SymX(regfree)                             \
@@ -205,11 +219,7 @@ typedef struct _RtsSymbolVal {
       SymX(uname)                               \
       SymX(unlink)                              \
       SymX(utime)                               \
-      SymX(waitpid)                             \
-      Sym(__divdi3)                             \
-      Sym(__udivdi3)                            \
-      Sym(__moddi3)                             \
-      Sym(__umoddi3)
+      SymX(waitpid)
 
 #elif !defined(mingw32_TARGET_OS)
 #define RTS_MINGW_ONLY_SYMBOLS /**/
@@ -218,11 +228,21 @@ typedef struct _RtsSymbolVal {
 #define RTS_POSIX_ONLY_SYMBOLS  /**/
 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 
+/* Extra syms gen'ed by mingw-2's gcc-3.2: */
+#if __GNUC__>=3
+#define RTS_MINGW_EXTRA_SYMS                    \
+      Sym(_imp____mb_cur_max)                   \
+      Sym(_imp___pctype)
+#else
+#define RTS_MINGW_EXTRA_SYMS
+#endif
+
 /* These are statically linked from the mingw libraries into the ghc
    executable, so we have to employ this hack. */
 #define RTS_MINGW_ONLY_SYMBOLS                  \
       SymX(asyncReadzh_fast)                   \
       SymX(asyncWritezh_fast)                  \
+      SymX(asyncDoProczh_fast)                 \
       SymX(memset)                              \
       SymX(inet_ntoa)                           \
       SymX(inet_addr)                           \
@@ -282,11 +302,8 @@ typedef struct _RtsSymbolVal {
       Sym(opendir)                              \
       Sym(readdir)                              \
       Sym(rewinddir)                            \
-      Sym(closedir)                             \
-      Sym(__divdi3)                             \
-      Sym(__udivdi3)                            \
-      Sym(__moddi3)                             \
-      Sym(__umoddi3)
+      RTS_MINGW_EXTRA_SYMS                      \
+      Sym(closedir)
 #endif
 
 #ifndef SMP
@@ -295,12 +312,34 @@ typedef struct _RtsSymbolVal {
 # define MAIN_CAP_SYM
 #endif
 
+#ifdef TABLES_NEXT_TO_CODE
+#define RTS_RET_SYMBOLS /* nothing */
+#else
+#define RTS_RET_SYMBOLS                        \
+      SymX(stg_enter_ret)                      \
+      SymX(stg_gc_fun_ret)                     \
+      SymX(stg_ap_0_ret)                       \
+      SymX(stg_ap_v_ret)                       \
+      SymX(stg_ap_f_ret)                       \
+      SymX(stg_ap_d_ret)                       \
+      SymX(stg_ap_l_ret)                       \
+      SymX(stg_ap_n_ret)                       \
+      SymX(stg_ap_p_ret)                       \
+      SymX(stg_ap_pv_ret)                      \
+      SymX(stg_ap_pp_ret)                      \
+      SymX(stg_ap_ppv_ret)                     \
+      SymX(stg_ap_ppp_ret)                     \
+      SymX(stg_ap_pppv_ret)                    \
+      SymX(stg_ap_pppp_ret)                    \
+      SymX(stg_ap_ppppp_ret)                   \
+      SymX(stg_ap_pppppp_ret)
+#endif
+
 #define RTS_SYMBOLS                            \
       Maybe_ForeignObj                         \
       Maybe_Stable_Names                       \
       Sym(StgReturn)                           \
       SymX(stg_enter_info)                     \
-      SymX(stg_enter_ret)                      \
       SymX(stg_gc_void_info)                   \
       SymX(__stg_gc_enter_1)                   \
       SymX(stg_gc_noregs)                      \
@@ -316,7 +355,6 @@ typedef struct _RtsSymbolVal {
       SymX(stg_gc_l1)                          \
       SymX(__stg_gc_fun)                       \
       SymX(stg_gc_fun_info)                    \
-      SymX(stg_gc_fun_ret)                     \
       SymX(stg_gc_gen)                         \
       SymX(stg_gc_gen_info)                    \
       SymX(stg_gc_gen_hp)                      \
@@ -330,17 +368,14 @@ typedef struct _RtsSymbolVal {
       SymX(stg_block_takemvar)                 \
       SymX(stg_block_putmvar)                  \
       SymX(stg_seq_frame_info)                 \
-      SymX(ErrorHdrHook)                       \
       MAIN_CAP_SYM                              \
       SymX(MallocFailHook)                     \
       SymX(OnExitHook)                         \
       SymX(OutOfHeapHook)                      \
-      SymX(PatErrorHdrHook)                    \
-      SymX(PostTraceHook)                      \
-      SymX(PreTraceHook)                       \
       SymX(StackOverflowHook)                  \
       SymX(__encodeDouble)                     \
       SymX(__encodeFloat)                      \
+      SymX(addDLL)                             \
       SymX(__gmpn_gcd_1)                       \
       SymX(__gmpz_cmp)                         \
       SymX(__gmpz_cmp_si)                      \
@@ -350,6 +385,7 @@ typedef struct _RtsSymbolVal {
       SymX(__int_encodeDouble)                 \
       SymX(__int_encodeFloat)                  \
       SymX(andIntegerzh_fast)                  \
+      SymX(barf)                               \
       SymX(blockAsyncExceptionszh_fast)                \
       SymX(catchzh_fast)                       \
       SymX(cmp_thread)                         \
@@ -366,17 +402,21 @@ typedef struct _RtsSymbolVal {
       SymX(divExactIntegerzh_fast)             \
       SymX(divModIntegerzh_fast)               \
       SymX(forkzh_fast)                                \
-      SymX(forkProcesszh_fast)                  \
+      SymX(forkProcess)                                \
+      SymX(forkOS_createThread)                        \
       SymX(freeHaskellFunctionPtr)             \
       SymX(freeStablePtr)                      \
       SymX(gcdIntegerzh_fast)                  \
       SymX(gcdIntegerIntzh_fast)               \
       SymX(gcdIntzh_fast)                      \
+      SymX(genSymZh)                           \
       SymX(getProgArgv)                                \
       SymX(getStablePtr)                       \
+      SymX(initLinker)                         \
       SymX(int2Integerzh_fast)                 \
       SymX(integer2Intzh_fast)                 \
       SymX(integer2Wordzh_fast)                        \
+      SymX(isCurrentThreadBoundzh_fast)                \
       SymX(isDoubleDenormalized)               \
       SymX(isDoubleInfinite)                   \
       SymX(isDoubleNaN)                                \
@@ -387,6 +427,8 @@ typedef struct _RtsSymbolVal {
       SymX(isFloatNaN)                         \
       SymX(isFloatNegativeZero)                        \
       SymX(killThreadzh_fast)                  \
+      SymX(loadObj)                            \
+      SymX(lookupSymbol)                       \
       SymX(makeStablePtrzh_fast)               \
       SymX(minusIntegerzh_fast)                        \
       SymX(mkApUpd0zh_fast)                    \
@@ -402,6 +444,7 @@ typedef struct _RtsSymbolVal {
       SymX(newPinnedByteArrayzh_fast)          \
       SymX(orIntegerzh_fast)                   \
       SymX(performGC)                          \
+      SymX(performMajorGC)                     \
       SymX(plusIntegerzh_fast)                 \
       SymX(prog_argc)                          \
       SymX(prog_argv)                          \
@@ -409,14 +452,17 @@ typedef struct _RtsSymbolVal {
       SymX(quotIntegerzh_fast)                 \
       SymX(quotRemIntegerzh_fast)              \
       SymX(raisezh_fast)                       \
+      SymX(raiseIOzh_fast)                     \
       SymX(remIntegerzh_fast)                  \
       SymX(resetNonBlockingFd)                 \
       SymX(resumeThread)                       \
+      SymX(resolveObjs)                         \
       SymX(rts_apply)                          \
       SymX(rts_checkSchedStatus)               \
       SymX(rts_eval)                           \
       SymX(rts_evalIO)                         \
       SymX(rts_evalLazyIO)                     \
+      SymX(rts_evalStableIO)                   \
       SymX(rts_eval_)                          \
       SymX(rts_getBool)                                \
       SymX(rts_getChar)                                \
@@ -450,7 +496,10 @@ typedef struct _RtsSymbolVal {
       SymX(rts_mkWord64)                       \
       SymX(rts_mkWord8)                                \
       SymX(rts_unlock)                         \
+      SymX(rtsSupportsBoundThreads)            \
       SymX(run_queue_hd)                       \
+      SymX(__hscore_get_saved_termios)         \
+      SymX(__hscore_set_saved_termios)         \
       SymX(setProgArgv)                                \
       SymX(startupHaskell)                     \
       SymX(shutdownHaskell)                    \
@@ -458,6 +507,8 @@ typedef struct _RtsSymbolVal {
       SymX(stable_ptr_table)                   \
       SymX(stackOverflow)                      \
       SymX(stg_CAF_BLACKHOLE_info)             \
+      SymX(stg_BLACKHOLE_BQ_info)              \
+      SymX(awakenBlockedQueue)                 \
       SymX(stg_CHARLIKE_closure)               \
       SymX(stg_EMPTY_MVAR_info)                        \
       SymX(stg_IND_STATIC_info)                        \
@@ -474,25 +525,10 @@ typedef struct _RtsSymbolVal {
       SymX(stg_ap_pp_info)                     \
       SymX(stg_ap_ppv_info)                    \
       SymX(stg_ap_ppp_info)                    \
+      SymX(stg_ap_pppv_info)                   \
       SymX(stg_ap_pppp_info)                   \
       SymX(stg_ap_ppppp_info)                  \
       SymX(stg_ap_pppppp_info)                 \
-      SymX(stg_ap_ppppppp_info)                        \
-      SymX(stg_ap_0_ret)                       \
-      SymX(stg_ap_v_ret)                       \
-      SymX(stg_ap_f_ret)                       \
-      SymX(stg_ap_d_ret)                       \
-      SymX(stg_ap_l_ret)                       \
-      SymX(stg_ap_n_ret)                       \
-      SymX(stg_ap_p_ret)                       \
-      SymX(stg_ap_pv_ret)                      \
-      SymX(stg_ap_pp_ret)                      \
-      SymX(stg_ap_ppv_ret)                     \
-      SymX(stg_ap_ppp_ret)                     \
-      SymX(stg_ap_pppp_ret)                    \
-      SymX(stg_ap_ppppp_ret)                   \
-      SymX(stg_ap_pppppp_ret)                  \
-      SymX(stg_ap_ppppppp_ret)                 \
       SymX(stg_ap_1_upd_info)                  \
       SymX(stg_ap_2_upd_info)                  \
       SymX(stg_ap_3_upd_info)                  \
@@ -500,7 +536,6 @@ typedef struct _RtsSymbolVal {
       SymX(stg_ap_5_upd_info)                  \
       SymX(stg_ap_6_upd_info)                  \
       SymX(stg_ap_7_upd_info)                  \
-      SymX(stg_ap_8_upd_info)                  \
       SymX(stg_exit)                           \
       SymX(stg_sel_0_upd_info)                 \
       SymX(stg_sel_10_upd_info)                        \
@@ -525,6 +560,7 @@ typedef struct _RtsSymbolVal {
       SymX(tryPutMVarzh_fast)                  \
       SymX(tryTakeMVarzh_fast)                 \
       SymX(unblockAsyncExceptionszh_fast)      \
+      SymX(unloadObj)                           \
       SymX(unsafeThawArrayzh_fast)             \
       SymX(waitReadzh_fast)                    \
       SymX(waitWritezh_fast)                   \
@@ -540,12 +576,9 @@ typedef struct _RtsSymbolVal {
 #define RTS_LONG_LONG_SYMS /* nothing */
 #endif
 
-#ifdef ia64_TARGET_ARCH
-/* force these symbols to be present */
-#define RTS_EXTRA_SYMBOLS                      \
-      Sym(__divsf3)
-#elif defined(powerpc_TARGET_ARCH)
-#define RTS_EXTRA_SYMBOLS                      \
+// 64-bit support functions in libgcc.a
+#if defined(__GNUC__) && SIZEOF_VOID_P <= 4
+#define RTS_LIBGCC_SYMBOLS                     \
       Sym(__divdi3)                             \
       Sym(__udivdi3)                            \
       Sym(__moddi3)                             \
@@ -554,27 +587,38 @@ typedef struct _RtsSymbolVal {
       Sym(__ashrdi3)                           \
       Sym(__lshrdi3)                           \
       Sym(__eprintf)
-      
+#elif defined(ia64_TARGET_ARCH)
+#define RTS_LIBGCC_SYMBOLS                     \
+      Sym(__divdi3)                            \
+      Sym(__udivdi3)                            \
+      Sym(__moddi3)                            \
+      Sym(__umoddi3)                           \
+      Sym(__divsf3)                            \
+      Sym(__divdf3)
+#else
+#define RTS_LIBGCC_SYMBOLS
+#endif
+
+#ifdef darwin_TARGET_OS
       // Symbols that don't have a leading underscore
       // on Mac OS X. They have to receive special treatment,
       // see machoInitSymbolsWithoutUnderscore()
 #define RTS_MACHO_NOUNDERLINE_SYMBOLS          \
       Sym(saveFP)                              \
       Sym(restFP)
-#else
-#define RTS_EXTRA_SYMBOLS /* nothing */
 #endif
 
 /* entirely bogus claims about types of these symbols */
-#define Sym(vvv)  extern void (vvv);
+#define Sym(vvv)  extern void vvv(void);
 #define SymX(vvv) /**/
 #define SymX_redirect(vvv,xxx) /**/
 RTS_SYMBOLS
+RTS_RET_SYMBOLS
 RTS_LONG_LONG_SYMS
-RTS_EXTRA_SYMBOLS
 RTS_POSIX_ONLY_SYMBOLS
 RTS_MINGW_ONLY_SYMBOLS
 RTS_CYGWIN_ONLY_SYMBOLS
+RTS_LIBGCC_SYMBOLS
 #undef Sym
 #undef SymX
 #undef SymX_redirect
@@ -598,10 +642,10 @@ RTS_CYGWIN_ONLY_SYMBOLS
 static RtsSymbolVal rtsSyms[] = {
       RTS_SYMBOLS
       RTS_LONG_LONG_SYMS
-      RTS_EXTRA_SYMBOLS
       RTS_POSIX_ONLY_SYMBOLS
       RTS_MINGW_ONLY_SYMBOLS
       RTS_CYGWIN_ONLY_SYMBOLS
+      RTS_LIBGCC_SYMBOLS
       { 0, 0 } /* sentinel */
 };
 
@@ -650,6 +694,11 @@ static int linker_init_done = 0 ;
 static void *dl_prog_handle;
 #endif
 
+/* dlopen(NULL,..) doesn't work so we grab libc explicitly */
+#if defined(openbsd_TARGET_OS)
+static void *dl_libc_handle;
+#endif
+
 void
 initLinker( void )
 {
@@ -674,7 +723,14 @@ initLinker( void )
 #   endif
 
 #   if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
+#   if defined(RTLD_DEFAULT)
+    dl_prog_handle = RTLD_DEFAULT;
+#   else
     dl_prog_handle = dlopen(NULL, RTLD_LAZY);
+#   if defined(openbsd_TARGET_OS)
+    dl_libc_handle = dlopen("libc.so", RTLD_LAZY);
+#   endif
+#   endif // RTLD_DEFAULT
 #   endif
 }
 
@@ -695,7 +751,7 @@ initLinker( void )
  * to give to loadSymbol, so that we can find the symbols.  For such
  * libraries, the LoadLibrary call should be a no-op except for returning
  * the handle.
- * 
+ *
  */
 
 #if defined(OBJFORMAT_PEi386)
@@ -724,6 +780,7 @@ addDLL( char *dll_name )
    initLinker();
 
    hdl= dlopen(dll_name, RTLD_NOW | RTLD_GLOBAL);
+
    if (hdl == NULL) {
       /* dlopen failed; return a ptr to the error msg. */
       errmsg = dlerror();
@@ -802,8 +859,20 @@ lookupSymbol( char *lbl )
     val = lookupStrHashTable(symhash, lbl);
 
     if (val == NULL) {
-#       if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
+#       if defined(OBJFORMAT_ELF)
+#      if defined(openbsd_TARGET_OS)
+       val = dlsym(dl_prog_handle, lbl);
+       return (val != NULL) ? val : dlsym(dl_libc_handle,lbl);
+#      else /* not openbsd */
        return dlsym(dl_prog_handle, lbl);
+#      endif
+#       elif defined(OBJFORMAT_MACHO)
+       if(NSIsSymbolNameDefined(lbl)) {
+           NSSymbol symbol = NSLookupAndBindSymbol(lbl);
+           return NSAddressOfSymbol(symbol);
+       } else {
+           return NULL;
+       }
 #       elif defined(OBJFORMAT_PEi386)
         OpenedDLL* o_dll;
         void* sym;
@@ -911,7 +980,7 @@ loadObj( char *path )
    int r, n;
 #ifdef USE_MMAP
    int fd, pagesize;
-   void *map_addr;
+   void *map_addr = NULL;
 #else
    FILE *f;
 #endif
@@ -920,24 +989,25 @@ loadObj( char *path )
 
    /* fprintf(stderr, "loadObj %s\n", path ); */
 
-   /* Check that we haven't already loaded this object.  Don't give up
-      at this stage; ocGetNames_* will barf later. */
+   /* Check that we haven't already loaded this object. 
+      Ignore requests to load multiple times */
    {
        ObjectCode *o;
        int is_dup = 0;
        for (o = objects; o; o = o->next) {
-          if (0 == strcmp(o->fileName, path))
+          if (0 == strcmp(o->fileName, path)) {
              is_dup = 1;
+             break; /* don't need to search further */
+          }
        }
        if (is_dup) {
-        fprintf(stderr,
-            "\n\n"
+          IF_DEBUG(linker, belch(
             "GHCi runtime linker: warning: looks like you're trying to load the\n"
             "same object file twice:\n"
             "   %s\n"
-            "GHCi will continue, but a duplicate-symbol error may shortly follow.\n"
-            "\n"
-            , path);
+            "GHCi will ignore this, but be warned.\n"
+            , path));
+          return 1; /* success */
        }
    }
 
@@ -976,7 +1046,11 @@ loadObj( char *path )
 
    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
 
+#if defined(openbsd_TARGET_OS)
+   fd = open(path, O_RDONLY, S_IRUSR);
+#else
    fd = open(path, O_RDONLY);
+#endif
    if (fd == -1)
       barf("loadObj: can't open `%s'", path);
 
@@ -1017,6 +1091,11 @@ loadObj( char *path )
 
 #endif /* USE_MMAP */
 
+#  if defined(OBJFORMAT_MACHO)
+   r = ocAllocateJumpIslands_MachO ( oc );
+   if (!r) { return r; }
+#endif
+
    /* verify the in-memory image */
 #  if defined(OBJFORMAT_ELF)
    r = ocVerifyImage_ELF ( oc );
@@ -1089,7 +1168,7 @@ unloadObj( char *path )
     ASSERT(symhash != NULL);
     ASSERT(objects != NULL);
 
-    initLinker(); 
+    initLinker();
 
     prev = NULL;
     for (oc = objects; oc; prev = oc, oc = oc->next) {
@@ -1876,11 +1955,16 @@ ocResolve_PEi386 ( ObjectCode* oc )
         * real count can be found in the first reloc entry.
          *
         * See Section 4.1 (last para) of the PE spec (rev6.0).
+        *
+        * Nov2003 update: the GNU linker still doesn't correctly
+        * handle the generation of relocatable object files with
+        * overflown relocations. Hence the output to warn of potential
+        * troubles.
         */
         COFF_reloc* rel = (COFF_reloc*)
                            myindex ( sizeof_COFF_reloc, reltab, 0 );
        noRelocs = rel->VirtualAddress;
-       fprintf(stderr, "Overflown relocs: %u\n", noRelocs);
+       fprintf(stderr, "WARNING: Overflown relocation field (# relocs found: %u)\n", noRelocs); fflush(stderr);
        j = 1;
       } else {
        noRelocs = sectab_i->NumberOfRelocations;
@@ -1992,6 +2076,9 @@ ocResolve_PEi386 ( ObjectCode* oc )
 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
 #elif defined(i386_TARGET_ARCH)
 #  define ELF_TARGET_386    /* Used inside <elf.h> */
+#elif defined(x86_64_TARGET_ARCH)
+#  define ELF_TARGET_X64_64
+#  define ELF_64BIT
 #elif defined (ia64_TARGET_ARCH)
 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
 #  define ELF_64BIT
@@ -2000,7 +2087,15 @@ ocResolve_PEi386 ( ObjectCode* oc )
 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
 #endif
 
+#if !defined(openbsd_TARGET_OS)
 #include <elf.h>
+#else
+/* openbsd elf has things in different places, with diff names */
+#include <elf_abi.h>
+#include <machine/reloc.h>
+#define R_386_32    RELOC_32
+#define R_386_PC32  RELOC_PC32
+#endif
 
 /*
  * Define a set of types which can be used for both ELF32 and ELF64
@@ -2032,11 +2127,19 @@ ocResolve_PEi386 ( ObjectCode* oc )
 #define Elf_Sym     Elf32_Sym
 #define Elf_Rel     Elf32_Rel
 #define Elf_Rela    Elf32_Rela
+#ifndef ELF_ST_TYPE
 #define ELF_ST_TYPE ELF32_ST_TYPE
+#endif
+#ifndef ELF_ST_BIND
 #define ELF_ST_BIND ELF32_ST_BIND
+#endif
+#ifndef ELF_R_TYPE
 #define ELF_R_TYPE  ELF32_R_TYPE
+#endif
+#ifndef ELF_R_SYM
 #define ELF_R_SYM   ELF32_R_SYM
 #endif
+#endif
 
 
 /*
@@ -2697,8 +2800,8 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
 #ifdef ELF_FUNCTION_DESC
            /* If a function, already a function descriptor - we would
               have to copy it to add an offset. */
-            if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC)
-               assert(A == 0);
+            if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
+               belch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
 #endif
         }
          if (!S) {
@@ -2757,6 +2860,9 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
         case R_IA64_FPTR64LSB:
            *pP = value;
            break;
+        case R_IA64_PCREL64LSB:
+           *pP = value - P;
+           break;
         case R_IA64_SEGREL64LSB:
            addr = findElfSegment(ehdrC, value);
            *pP = value - addr;
@@ -2765,6 +2871,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
            ia64_reloc_gprel22(P, value);
            break;
         case R_IA64_LTOFF22:
+        case R_IA64_LTOFF22X:
         case R_IA64_LTOFF_FPTR22:
            addr = allocateGOTEntry(value);
            ia64_reloc_gprel22(P, addr);
@@ -2772,6 +2879,10 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
         case R_IA64_PCREL21B:
            ia64_reloc_pcrel21(P, S, oc);
            break;
+        case R_IA64_LDXMOV:
+           /* This goes with R_IA64_LTOFF22X and points to the load to
+            * convert into a move.  We don't implement relaxation. */
+           break;
 #        endif
          default:
             belch("%s: unhandled ELF relocation(RelA) type %d\n",
@@ -2936,18 +3047,70 @@ ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
 #if defined(OBJFORMAT_MACHO)
 
 /*
-  Initial support for MachO linking on Darwin/MacOS X on PowerPC chips
+  Support for MachO linking on Darwin/MacOS X on PowerPC chips
   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
-  
+
   I hereby formally apologize for the hackish nature of this code.
   Things that need to be done:
-  *) get common symbols and .bss sections to work properly.
-       Haskell modules seem to work, but C modules can cause problems
   *) implement ocVerifyImage_MachO
-  *) add more sanity checks. The current code just has to segfault if there's a
-     broken .o file.
+  *) add still more sanity checks.
 */
 
+
+/*
+  ocAllocateJumpIslands_MachO
+
+  Allocate additional space at the end of the object file image to make room
+  for jump islands.
+
+  PowerPC relative branch instructions have a 24 bit displacement field.
+  As PPC code is always 4-byte-aligned, this yields a +-32MB range.
+  If a particular imported symbol is outside this range, we have to redirect
+  the jump to a short piece of new code that just loads the 32bit absolute
+  address and jumps there.
+  This function just allocates space for one 16 byte jump island for every
+  undefined symbol in the object file. The code for the islands is filled in by
+  makeJumpIsland below.
+*/
+
+static const int islandSize = 16;
+
+static int ocAllocateJumpIslands_MachO(ObjectCode* oc)
+{
+    char *image = (char*) oc->image;
+    struct mach_header *header = (struct mach_header*) image;
+    struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
+    unsigned i;
+
+    for(i=0;i<header->ncmds;i++)
+    {
+       if(lc->cmd == LC_DYSYMTAB)
+        {
+           struct dysymtab_command *dsymLC = (struct dysymtab_command*) lc;
+            unsigned long nundefsym = dsymLC->nundefsym;
+            oc->island_start_symbol = dsymLC->iundefsym;
+            oc->n_islands = nundefsym;
+
+            if(nundefsym > 0)
+            {
+#ifdef USE_MMAP
+                #error ocAllocateJumpIslands_MachO doesnt want USE_MMAP to be defined
+#else
+                oc->image = stgReallocBytes(
+                    image, oc->fileSize + islandSize * nundefsym,
+                    "ocAllocateJumpIslands_MachO");
+#endif
+                oc->jump_islands = oc->image + oc->fileSize;
+                memset(oc->jump_islands, 0, islandSize * nundefsym);
+            }
+
+            break;  // there can be only one LC_DSYMTAB
+        }
+       lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
+    }
+    return 1;
+}
+
 static int ocVerifyImage_MachO(ObjectCode* oc)
 {
     // FIXME: do some verifying here
@@ -2963,14 +3126,14 @@ static int resolveImports(
     struct nlist *nlist)
 {
     unsigned i;
-    
+
     for(i=0;i*4<sect->size;i++)
     {
        // according to otool, reserved1 contains the first index into the indirect symbol table
        struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
        char *nm = image + symLC->stroff + symbol->n_un.n_strx;
        void *addr = NULL;
-       
+
        if((symbol->n_type & N_TYPE) == N_UNDF
            && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
            addr = (void*) (symbol->n_value);
@@ -2984,19 +3147,67 @@ static int resolveImports(
            return 0;
        }
        ASSERT(addr);
+       checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
        ((void**)(image + sect->offset))[i] = addr;
     }
-    
+
     return 1;
 }
 
-static int relocateSection(char *image, 
+static void* makeJumpIsland(
+    ObjectCode* oc,
+    unsigned long symbolNumber,
+    void* target)
+{
+    if(symbolNumber < oc->island_start_symbol ||
+        symbolNumber - oc->island_start_symbol > oc->n_islands)
+        return NULL;
+    symbolNumber -= oc->island_start_symbol;
+
+    void *island = (void*) ((char*)oc->jump_islands + islandSize * symbolNumber);
+    unsigned long *p = (unsigned long*) island;
+
+        // lis r12, hi16(target)
+    *p++ = 0x3d800000 | ( ((unsigned long) target) >> 16 );
+        // ori r12, r12, lo16(target)
+    *p++ = 0x618c0000 | ( ((unsigned long) target) & 0xFFFF );
+        // mtctr r12
+    *p++ = 0x7d8903a6;
+        // bctr
+    *p++ = 0x4e800420;
+
+    return (void*) island;
+}
+
+static char* relocateAddress(
+    ObjectCode* oc,
+    int nSections,
+    struct section* sections,
+    unsigned long address)
+{
+    int i;
+    for(i = 0; i < nSections; i++)
+    {
+        if(sections[i].addr <= address
+            && address < sections[i].addr + sections[i].size)
+        {
+            return oc->image + sections[i].offset + address - sections[i].addr;
+        }
+    }
+    barf("Invalid Mach-O file:"
+         "Address out of bounds while relocating object file");
+    return NULL;
+}
+
+static int relocateSection(
+    ObjectCode* oc,
+    char *image,
     struct symtab_command *symLC, struct nlist *nlist,
-    struct section* sections, struct section *sect)
+    int nSections, struct section* sections, struct section *sect)
 {
     struct relocation_info *relocs;
     int i,n;
-    
+
     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
        return 1;
     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
@@ -3004,24 +3215,106 @@ static int relocateSection(char *image,
 
     n = sect->nreloc;
     relocs = (struct relocation_info*) (image + sect->reloff);
-    
+
     for(i=0;i<n;i++)
     {
        if(relocs[i].r_address & R_SCATTERED)
        {
            struct scattered_relocation_info *scat =
                (struct scattered_relocation_info*) &relocs[i];
-           
+
            if(!scat->r_pcrel)
            {
-               if(scat->r_length == 2 && scat->r_type == GENERIC_RELOC_VANILLA)
+               if(scat->r_length == 2)
                {
-                   unsigned long* word = (unsigned long*) (image + sect->offset + scat->r_address);
-                   
-                   *word = scat->r_value + sect->offset + ((long) image);
+                   unsigned long word = 0;
+                   unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
+                   checkProddableBlock(oc,wordPtr);
+
+                   // Step 1: Figure out what the relocated value should be
+                   if(scat->r_type == GENERIC_RELOC_VANILLA)
+                   {
+                       word = scat->r_value + sect->offset + ((long) image);
+                   }
+                   else if(scat->r_type == PPC_RELOC_SECTDIFF
+                       || scat->r_type == PPC_RELOC_LO16_SECTDIFF
+                       || scat->r_type == PPC_RELOC_HI16_SECTDIFF
+                       || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
+                   {
+                       struct scattered_relocation_info *pair =
+                               (struct scattered_relocation_info*) &relocs[i+1];
+
+                       if(!pair->r_scattered || pair->r_type != PPC_RELOC_PAIR)
+                           barf("Invalid Mach-O file: "
+                                "PPC_RELOC_*_SECTDIFF not followed by PPC_RELOC_PAIR");
+
+                       word = (unsigned long)
+                              (relocateAddress(oc, nSections, sections, scat->r_value)
+                             - relocateAddress(oc, nSections, sections, pair->r_value));
+                       i++;
+                   }
+                   else if(scat->r_type == PPC_RELOC_HI16
+                         || scat->r_type == PPC_RELOC_LO16
+                         || scat->r_type == PPC_RELOC_HA16
+                         || scat->r_type == PPC_RELOC_LO14)
+                    {   // these are generated by label+offset things
+                       struct relocation_info *pair = &relocs[i+1];
+                        if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
+                           barf("Invalid Mach-O file: "
+                                "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
+                        
+                        if(scat->r_type == PPC_RELOC_LO16)
+                        {
+                            word = ((unsigned short*) wordPtr)[1];
+                            word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
+                        }
+                        else if(scat->r_type == PPC_RELOC_LO14)
+                        {
+                            barf("Unsupported Relocation: PPC_RELOC_LO14");
+                            word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
+                            word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
+                        }
+                        else if(scat->r_type == PPC_RELOC_HI16)
+                        {
+                            word = ((unsigned short*) wordPtr)[1] << 16;
+                            word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
+                        }
+                        else if(scat->r_type == PPC_RELOC_HA16)
+                        {
+                            word = ((unsigned short*) wordPtr)[1] << 16;
+                            word += ((short)relocs[i+1].r_address & (short)0xFFFF);
+                        }
+                       
+                        
+                        word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
+                                                - scat->r_value;
+                        
+                        i++;
+                    }
+                    else
+                       continue;  // ignore the others
+
+                    if(scat->r_type == GENERIC_RELOC_VANILLA
+                        || scat->r_type == PPC_RELOC_SECTDIFF)
+                    {
+                        *wordPtr = word;
+                    }
+                    else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
+                    {
+                        ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
+                    }
+                    else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
+                    {
+                        ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
+                    }
+                    else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
+                    {
+                        ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
+                            + ((word & (1<<15)) ? 1 : 0);
+                    }
                }
            }
-           
+
            continue; // FIXME: I hope it's OK to ignore all the others.
        }
        else
@@ -3029,13 +3322,16 @@ static int relocateSection(char *image,
            struct relocation_info *reloc = &relocs[i];
            if(reloc->r_pcrel && !reloc->r_extern)
                continue;
-               
+
            if(reloc->r_length == 2)
            {
                unsigned long word = 0;
+                unsigned long jumpIsland = 0;
+                long offsetToJumpIsland;
 
                unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
-               
+               checkProddableBlock(oc,wordPtr);
+
                if(reloc->r_type == GENERIC_RELOC_VANILLA)
                {
                    word = *wordPtr;
@@ -3064,28 +3360,42 @@ static int relocateSection(char *image,
 
                if(!reloc->r_extern)
                {
-                   long delta = 
+                   long delta =
                        sections[reloc->r_symbolnum-1].offset
                        - sections[reloc->r_symbolnum-1].addr
                        + ((long) image);
-                   
+
                    word += delta;
                }
                else
                {
                    struct nlist *symbol = &nlist[reloc->r_symbolnum];
                    char *nm = image + symLC->stroff + symbol->n_un.n_strx;
-                   word = (unsigned long) (lookupSymbol(nm));
-                   if(!word)
+                   unsigned long symbolAddress = (unsigned long) (lookupSymbol(nm));
+                   if(!symbolAddress)
                    {
                        belch("\nunknown symbol `%s'", nm);
                        return 0;
                    }
-                   
+
                    if(reloc->r_pcrel)
+                    {  
+                        ASSERT(word == 0);
+                        word = symbolAddress;
+                        jumpIsland = (long) makeJumpIsland(oc,reloc->r_symbolnum,(void*)word);
                        word -= ((long)image) + sect->offset + reloc->r_address;
+                        if(jumpIsland != 0)
+                        {
+                            offsetToJumpIsland = jumpIsland
+                                - (((long)image) + sect->offset + reloc->r_address);
+                        }
+                    }
+                    else
+                    {
+                        word += symbolAddress;
+                    }
                }
-               
+
                if(reloc->r_type == GENERIC_RELOC_VANILLA)
                {
                    *wordPtr = word;
@@ -3109,6 +3419,19 @@ static int relocateSection(char *image,
                }
                else if(reloc->r_type == PPC_RELOC_BR24)
                {
+                    if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
+                    {
+                        // The branch offset is too large.
+                        // Therefore, we try to use a jump island.
+                        if(jumpIsland == 0)
+                            barf("unconditional relative branch out of range: "
+                                 "no jump island available");
+
+                        word = offsetToJumpIsland;
+                        if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
+                            barf("unconditional relative branch out of range: "
+                                 "jump island out of range");
+                    }
                    *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
                    continue;
                }
@@ -3127,7 +3450,7 @@ static int ocGetNames_MachO(ObjectCode* oc)
     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
     unsigned i,curSymbol;
     struct segment_command *segLC = NULL;
-    struct section *sections, *la_ptrs = NULL, *nl_ptrs = NULL;
+    struct section *sections;
     struct symtab_command *symLC = NULL;
     struct dysymtab_command *dsymLC = NULL;
     struct nlist *nlist;
@@ -3146,29 +3469,41 @@ static int ocGetNames_MachO(ObjectCode* oc)
        lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
     }
 
-    sections = (struct section*) (segLC+1); 
+    sections = (struct section*) (segLC+1);
     nlist = (struct nlist*) (image + symLC->symoff);
 
     for(i=0;i<segLC->nsects;i++)
     {
-       if(!strcmp(sections[i].sectname,"__la_symbol_ptr"))
-           la_ptrs = &sections[i];
-       else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
-           nl_ptrs = &sections[i];
-           
-           // for now, only add __text and __const to the sections table
-       else if(!strcmp(sections[i].sectname,"__text"))
-           addSection(oc, SECTIONKIND_CODE_OR_RODATA, 
+        if(sections[i].size == 0)
+            continue;
+
+        if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
+        {
+            char * zeroFillArea = stgCallocBytes(1,sections[i].size,
+                                      "ocGetNames_MachO(common symbols)");
+            sections[i].offset = zeroFillArea - image;
+        }
+
+       if(!strcmp(sections[i].sectname,"__text"))
+           addSection(oc, SECTIONKIND_CODE_OR_RODATA,
                (void*) (image + sections[i].offset),
                (void*) (image + sections[i].offset + sections[i].size));
        else if(!strcmp(sections[i].sectname,"__const"))
-           addSection(oc, SECTIONKIND_RWDATA, 
+           addSection(oc, SECTIONKIND_RWDATA,
                (void*) (image + sections[i].offset),
                (void*) (image + sections[i].offset + sections[i].size));
        else if(!strcmp(sections[i].sectname,"__data"))
-           addSection(oc, SECTIONKIND_RWDATA, 
+           addSection(oc, SECTIONKIND_RWDATA,
                (void*) (image + sections[i].offset),
                (void*) (image + sections[i].offset + sections[i].size));
+       else if(!strcmp(sections[i].sectname,"__bss")
+               || !strcmp(sections[i].sectname,"__common"))
+           addSection(oc, SECTIONKIND_RWDATA,
+               (void*) (image + sections[i].offset),
+               (void*) (image + sections[i].offset + sections[i].size));
+
+        addProddableBlock(oc, (void*) (image + sections[i].offset),
+                                        sections[i].size);
     }
 
        // count external symbols defined here
@@ -3189,35 +3524,35 @@ static int ocGetNames_MachO(ObjectCode* oc)
     }
     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
                                   "ocGetNames_MachO(oc->symbols)");
-    
+
        // insert symbols into hash table
     for(i=dsymLC->iextdefsym,curSymbol=0;i<dsymLC->iextdefsym+dsymLC->nextdefsym;i++)
     {
        if((nlist[i].n_type & N_TYPE) == N_SECT)
        {
            char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
-           ghciInsertStrHashTable(oc->fileName, symhash, nm, image + 
+           ghciInsertStrHashTable(oc->fileName, symhash, nm, image +
                sections[nlist[i].n_sect-1].offset
                - sections[nlist[i].n_sect-1].addr
                + nlist[i].n_value);
            oc->symbols[curSymbol++] = nm;
        }
     }
-    
+
        // insert local symbols into lochash
     for(i=dsymLC->ilocalsym;i<dsymLC->ilocalsym+dsymLC->nlocalsym;i++)
     {
        if((nlist[i].n_type & N_TYPE) == N_SECT)
        {
            char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
-           ghciInsertStrHashTable(oc->fileName, oc->lochash, nm, image + 
+           ghciInsertStrHashTable(oc->fileName, oc->lochash, nm, image +
                sections[nlist[i].n_sect-1].offset
                - sections[nlist[i].n_sect-1].addr
                + nlist[i].n_value);
        }
     }
 
-    
+
     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
     commonCounter = (unsigned long)commonStorage;
     for(i=0;i<symLC->nsyms;i++)
@@ -3227,12 +3562,12 @@ static int ocGetNames_MachO(ObjectCode* oc)
        {
            char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
            unsigned long sz = nlist[i].n_value;
-           
+
            nlist[i].n_value = commonCounter;
-           
+
            ghciInsertStrHashTable(oc->fileName, symhash, nm, (void*)commonCounter);
            oc->symbols[curSymbol++] = nm;
-           
+
            commonCounter += sz;
        }
     }
@@ -3262,8 +3597,8 @@ static int ocResolve_MachO(ObjectCode* oc)
            dsymLC = (struct dysymtab_command*) lc;
        lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
     }
-    
-    sections = (struct section*) (segLC+1); 
+
+    sections = (struct section*) (segLC+1);
     nlist = (struct nlist*) (image + symLC->symoff);
 
     for(i=0;i<segLC->nsects;i++)
@@ -3273,7 +3608,7 @@ static int ocResolve_MachO(ObjectCode* oc)
        else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
            nl_ptrs = &sections[i];
     }
-    
+
     indirectSyms = (unsigned long*) (image + dsymLC->indirectsymoff);
 
     if(la_ptrs)
@@ -3282,16 +3617,33 @@ static int ocResolve_MachO(ObjectCode* oc)
     if(nl_ptrs)
        if(!resolveImports(oc,image,symLC,nl_ptrs,indirectSyms,nlist))
            return 0;
-    
+
     for(i=0;i<segLC->nsects;i++)
     {
-       if(!relocateSection(image,symLC,nlist,sections,&sections[i]))
+       if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
            return 0;
     }
 
     /* Free the local symbol table; we won't need it again. */
     freeHashTable(oc->lochash, NULL);
     oc->lochash = NULL;
+
+    /*
+        Flush the data & instruction caches.
+        Because the PPC has split data/instruction caches, we have to
+        do that whenever we modify code at runtime.
+    */
+    {
+        int n = (oc->fileSize + islandSize * oc->n_islands) / 4;
+        unsigned long *p = (unsigned long*)oc->image;
+        while(n--)
+        {
+            __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
+                                : : "r" (p));
+            p++;
+        }
+        __asm__ volatile ("sync\n\tisync");
+    }
     return 1;
 }
 
@@ -3308,11 +3660,11 @@ static void machoInitSymbolsWithoutUnderscore()
 {
     void *p;
 
-#undef Sym    
+#undef Sym
 #define Sym(x)                                         \
     __asm__ ("lis %0,hi16(" #x ")\n\tori %0,%0,lo16(" #x ")" : "=r" (p));      \
     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, p);
-    
+
     RTS_MACHO_NOUNDERLINE_SYMBOLS
 
 }