rts/Linker.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 2000-2004
   4  *
   5  * RTS Object Linker
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 #if 0
  10 #include "PosixSource.h"
  11 #endif
  12
  13 /* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and
  14    MREMAP_MAYMOVE from <sys/mman.h>.
  15  */
  16 #ifdef __linux__
  17 #define _GNU_SOURCE
  18 #endif
  19
  20 #include "Rts.h"
  21 #include "RtsFlags.h"
  22 #include "HsFFI.h"
  23 #include "Hash.h"
  24 #include "Linker.h"
  25 #include "LinkerInternals.h"
  26 #include "RtsUtils.h"
  27 #include "Schedule.h"
  28 #include "Sparks.h"
  29 #include "RtsTypeable.h"
  30
  31 #ifdef HAVE_SYS_TYPES_H
  32 #include <sys/types.h>
  33 #endif
  34
  35 #include <stdlib.h>
  36 #include <string.h>
  37
  38 #ifdef HAVE_SYS_STAT_H
  39 #include <sys/stat.h>
  40 #endif
  41
  42 #if defined(HAVE_DLFCN_H)
  43 #include <dlfcn.h>
  44 #endif
  45
  46 #if defined(cygwin32_HOST_OS)
  47 #ifdef HAVE_DIRENT_H
  48 #include <dirent.h>
  49 #endif
  50
  51 #ifdef HAVE_SYS_TIME_H
  52 #include <sys/time.h>
  53 #endif
  54 #include <regex.h>
  55 #include <sys/fcntl.h>
  56 #include <sys/termios.h>
  57 #include <sys/utime.h>
  58 #include <sys/utsname.h>
  59 #include <sys/wait.h>
  60 #endif
  61
  62 #if defined(ia64_HOST_ARCH) || defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
  63 #define USE_MMAP
  64 #include <fcntl.h>
  65 #include <sys/mman.h>
  66
  67 #if defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
  68 #ifdef HAVE_UNISTD_H
  69 #include <unistd.h>
  70 #endif
  71 #endif
  72
  73 #endif
  74
  75 #if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS)
  76 #  define OBJFORMAT_ELF
  77 #elif defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
  78 #  define OBJFORMAT_PEi386
  79 #  include <windows.h>
  80 #  include <math.h>
  81 #elif defined(darwin_HOST_OS)
  82 #  define OBJFORMAT_MACHO
  83 #  include <mach-o/loader.h>
  84 #  include <mach-o/nlist.h>
  85 #  include <mach-o/reloc.h>
  86 #  include <mach-o/dyld.h>
  87 #if defined(powerpc_HOST_ARCH)
  88 #  include <mach-o/ppc/reloc.h>
  89 #endif
  90 #if defined(x86_64_HOST_ARCH)
  91 #  include <mach-o/x86_64/reloc.h>
  92 #endif
  93 #endif
  94
  95 /* Hash table mapping symbol names to Symbol */
  96 static /*Str*/HashTable *symhash;
  97
  98 /* Hash table mapping symbol names to StgStablePtr */
  99 static /*Str*/HashTable *stablehash;
 100
 101 /* List of currently loaded objects */
 102 ObjectCode *objects = NULL;     /* initially empty */
 103
 104 #if defined(OBJFORMAT_ELF)
 105 static int ocVerifyImage_ELF    ( ObjectCode* oc );
 106 static int ocGetNames_ELF       ( ObjectCode* oc );
 107 static int ocResolve_ELF        ( ObjectCode* oc );
 108 #if defined(powerpc_HOST_ARCH)
 109 static int ocAllocateSymbolExtras_ELF ( ObjectCode* oc );
 110 #endif
 111 #elif defined(OBJFORMAT_PEi386)
 112 static int ocVerifyImage_PEi386 ( ObjectCode* oc );
 113 static int ocGetNames_PEi386    ( ObjectCode* oc );
 114 static int ocResolve_PEi386     ( ObjectCode* oc );
 115 #elif defined(OBJFORMAT_MACHO)
 116 static int ocVerifyImage_MachO    ( ObjectCode* oc );
 117 static int ocGetNames_MachO       ( ObjectCode* oc );
 118 static int ocResolve_MachO        ( ObjectCode* oc );
 119
 120 static int machoGetMisalignment( FILE * );
 121 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
 122 static int ocAllocateSymbolExtras_MachO ( ObjectCode* oc );
 123 #endif
 124 #ifdef powerpc_HOST_ARCH
 125 static void machoInitSymbolsWithoutUnderscore( void );
 126 #endif
 127 #endif
 128
 129 #if defined(x86_64_HOST_ARCH) && defined(OBJFORMAT_ELF)
 130 static void*x86_64_high_symbol( char *lbl, void *addr );
 131 #endif
 132
 133 /* -----------------------------------------------------------------------------
 134  * Built-in symbols from the RTS
 135  */
 136
 137 typedef struct _RtsSymbolVal {
 138     char   *lbl;
 139     void   *addr;
 140 } RtsSymbolVal;
 141
 142
 143 #if !defined(PAR)
 144 #define Maybe_Stable_Names      SymX(mkWeakzh_fast)                     \
 145                                 SymX(makeStableNamezh_fast)             \
 146                                 SymX(finalizzeWeakzh_fast)
 147 #else
 148 /* These are not available in GUM!!! -- HWL */
 149 #define Maybe_Stable_Names
 150 #endif
 151
 152 #if !defined (mingw32_HOST_OS)
 153 #define RTS_POSIX_ONLY_SYMBOLS                  \
 154       SymX(signal_handlers)                     \
 155       SymX(stg_sig_install)                     \
 156       Sym(nocldstop)
 157 #endif
 158
 159 #if defined (cygwin32_HOST_OS)
 160 #define RTS_MINGW_ONLY_SYMBOLS /**/
 161 /* Don't have the ability to read import libs / archives, so
 162  * we have to stupidly list a lot of what libcygwin.a
 163  * exports; sigh.
 164  */
 165 #define RTS_CYGWIN_ONLY_SYMBOLS                 \
 166       SymX(regfree)                             \
 167       SymX(regexec)                             \
 168       SymX(regerror)                            \
 169       SymX(regcomp)                             \
 170       SymX(__errno)                             \
 171       SymX(access)                              \
 172       SymX(chmod)                               \
 173       SymX(chdir)                               \
 174       SymX(close)                               \
 175       SymX(creat)                               \
 176       SymX(dup)                                 \
 177       SymX(dup2)                                \
 178       SymX(fstat)                               \
 179       SymX(fcntl)                               \
 180       SymX(getcwd)                              \
 181       SymX(getenv)                              \
 182       SymX(lseek)                               \
 183       SymX(open)                                \
 184       SymX(fpathconf)                           \
 185       SymX(pathconf)                            \
 186       SymX(stat)                                \
 187       SymX(pow)                                 \
 188       SymX(tanh)                                \
 189       SymX(cosh)                                \
 190       SymX(sinh)                                \
 191       SymX(atan)                                \
 192       SymX(acos)                                \
 193       SymX(asin)                                \
 194       SymX(tan)                                 \
 195       SymX(cos)                                 \
 196       SymX(sin)                                 \
 197       SymX(exp)                                 \
 198       SymX(log)                                 \
 199       SymX(sqrt)                                \
 200       SymX(localtime_r)                         \
 201       SymX(gmtime_r)                            \
 202       SymX(mktime)                              \
 203       Sym(_imp___tzname)                        \
 204       SymX(gettimeofday)                        \
 205       SymX(timezone)                            \
 206       SymX(tcgetattr)                           \
 207       SymX(tcsetattr)                           \
 208       SymX(memcpy)                              \
 209       SymX(memmove)                             \
 210       SymX(realloc)                             \
 211       SymX(malloc)                              \
 212       SymX(free)                                \
 213       SymX(fork)                                \
 214       SymX(lstat)                               \
 215       SymX(isatty)                              \
 216       SymX(mkdir)                               \
 217       SymX(opendir)                             \
 218       SymX(readdir)                             \
 219       SymX(rewinddir)                           \
 220       SymX(closedir)                            \
 221       SymX(link)                                \
 222       SymX(mkfifo)                              \
 223       SymX(pipe)                                \
 224       SymX(read)                                \
 225       SymX(rename)                              \
 226       SymX(rmdir)                               \
 227       SymX(select)                              \
 228       SymX(system)                              \
 229       SymX(write)                               \
 230       SymX(strcmp)                              \
 231       SymX(strcpy)                              \
 232       SymX(strncpy)                             \
 233       SymX(strerror)                            \
 234       SymX(sigaddset)                           \
 235       SymX(sigemptyset)                         \
 236       SymX(sigprocmask)                         \
 237       SymX(umask)                               \
 238       SymX(uname)                               \
 239       SymX(unlink)                              \
 240       SymX(utime)                               \
 241       SymX(waitpid)
 242
 243 #elif !defined(mingw32_HOST_OS)
 244 #define RTS_MINGW_ONLY_SYMBOLS /**/
 245 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 246 #else /* defined(mingw32_HOST_OS) */
 247 #define RTS_POSIX_ONLY_SYMBOLS  /**/
 248 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 249
 250 /* Extra syms gen'ed by mingw-2's gcc-3.2: */
 251 #if __GNUC__>=3
 252 #define RTS_MINGW_EXTRA_SYMS                    \
 253       Sym(_imp____mb_cur_max)                   \
 254       Sym(_imp___pctype)
 255 #else
 256 #define RTS_MINGW_EXTRA_SYMS
 257 #endif
 258
 259 #if HAVE_GETTIMEOFDAY
 260 #define RTS_MINGW_GETTIMEOFDAY_SYM Sym(gettimeofday)
 261 #else
 262 #define RTS_MINGW_GETTIMEOFDAY_SYM /**/
 263 #endif
 264
 265 /* These are statically linked from the mingw libraries into the ghc
 266    executable, so we have to employ this hack. */
 267 #define RTS_MINGW_ONLY_SYMBOLS                  \
 268       SymX(asyncReadzh_fast)                    \
 269       SymX(asyncWritezh_fast)                   \
 270       SymX(asyncDoProczh_fast)                  \
 271       SymX(memset)                              \
 272       SymX(inet_ntoa)                           \
 273       SymX(inet_addr)                           \
 274       SymX(htonl)                               \
 275       SymX(recvfrom)                            \
 276       SymX(listen)                              \
 277       SymX(bind)                                \
 278       SymX(shutdown)                            \
 279       SymX(connect)                             \
 280       SymX(htons)                               \
 281       SymX(ntohs)                               \
 282       SymX(getservbyname)                       \
 283       SymX(getservbyport)                       \
 284       SymX(getprotobynumber)                    \
 285       SymX(getprotobyname)                      \
 286       SymX(gethostbyname)                       \
 287       SymX(gethostbyaddr)                       \
 288       SymX(gethostname)                         \
 289       SymX(strcpy)                              \
 290       SymX(strncpy)                             \
 291       SymX(abort)                               \
 292       Sym(_alloca)                              \
 293       Sym(isxdigit)                             \
 294       Sym(isupper)                              \
 295       Sym(ispunct)                              \
 296       Sym(islower)                              \
 297       Sym(isspace)                              \
 298       Sym(isprint)                              \
 299       Sym(isdigit)                              \
 300       Sym(iscntrl)                              \
 301       Sym(isalpha)                              \
 302       Sym(isalnum)                              \
 303       SymX(strcmp)                              \
 304       SymX(memmove)                             \
 305       SymX(realloc)                             \
 306       SymX(malloc)                              \
 307       SymX(pow)                                 \
 308       SymX(tanh)                                \
 309       SymX(cosh)                                \
 310       SymX(sinh)                                \
 311       SymX(atan)                                \
 312       SymX(acos)                                \
 313       SymX(asin)                                \
 314       SymX(tan)                                 \
 315       SymX(cos)                                 \
 316       SymX(sin)                                 \
 317       SymX(exp)                                 \
 318       SymX(log)                                 \
 319       SymX(sqrt)                                \
 320       SymX(powf)                                 \
 321       SymX(tanhf)                                \
 322       SymX(coshf)                                \
 323       SymX(sinhf)                                \
 324       SymX(atanf)                                \
 325       SymX(acosf)                                \
 326       SymX(asinf)                                \
 327       SymX(tanf)                                 \
 328       SymX(cosf)                                 \
 329       SymX(sinf)                                 \
 330       SymX(expf)                                 \
 331       SymX(logf)                                 \
 332       SymX(sqrtf)                                \
 333       SymX(memcpy)                              \
 334       SymX(rts_InstallConsoleEvent)             \
 335       SymX(rts_ConsoleHandlerDone)              \
 336       Sym(mktime)                               \
 337       Sym(_imp___timezone)                      \
 338       Sym(_imp___tzname)                        \
 339       Sym(_imp__tzname)                         \
 340       Sym(_imp___iob)                           \
 341       Sym(_imp___osver)                         \
 342       Sym(localtime)                            \
 343       Sym(gmtime)                               \
 344       Sym(opendir)                              \
 345       Sym(readdir)                              \
 346       Sym(rewinddir)                            \
 347       RTS_MINGW_EXTRA_SYMS                      \
 348       RTS_MINGW_GETTIMEOFDAY_SYM                \
 349       Sym(closedir)
 350 #endif
 351
 352 #if defined(darwin_TARGET_OS) && HAVE_PRINTF_LDBLSTUB
 353 #define RTS_DARWIN_ONLY_SYMBOLS                 \
 354      Sym(asprintf$LDBLStub)                     \
 355      Sym(err$LDBLStub)                          \
 356      Sym(errc$LDBLStub)                         \
 357      Sym(errx$LDBLStub)                         \
 358      Sym(fprintf$LDBLStub)                      \
 359      Sym(fscanf$LDBLStub)                       \
 360      Sym(fwprintf$LDBLStub)                     \
 361      Sym(fwscanf$LDBLStub)                      \
 362      Sym(printf$LDBLStub)                       \
 363      Sym(scanf$LDBLStub)                        \
 364      Sym(snprintf$LDBLStub)                     \
 365      Sym(sprintf$LDBLStub)                      \
 366      Sym(sscanf$LDBLStub)                       \
 367      Sym(strtold$LDBLStub)                      \
 368      Sym(swprintf$LDBLStub)                     \
 369      Sym(swscanf$LDBLStub)                      \
 370      Sym(syslog$LDBLStub)                       \
 371      Sym(vasprintf$LDBLStub)                    \
 372      Sym(verr$LDBLStub)                         \
 373      Sym(verrc$LDBLStub)                        \
 374      Sym(verrx$LDBLStub)                        \
 375      Sym(vfprintf$LDBLStub)                     \
 376      Sym(vfscanf$LDBLStub)                      \
 377      Sym(vfwprintf$LDBLStub)                    \
 378      Sym(vfwscanf$LDBLStub)                     \
 379      Sym(vprintf$LDBLStub)                      \
 380      Sym(vscanf$LDBLStub)                       \
 381      Sym(vsnprintf$LDBLStub)                    \
 382      Sym(vsprintf$LDBLStub)                     \
 383      Sym(vsscanf$LDBLStub)                      \
 384      Sym(vswprintf$LDBLStub)                    \
 385      Sym(vswscanf$LDBLStub)                     \
 386      Sym(vsyslog$LDBLStub)                      \
 387      Sym(vwarn$LDBLStub)                        \
 388      Sym(vwarnc$LDBLStub)                       \
 389      Sym(vwarnx$LDBLStub)                       \
 390      Sym(vwprintf$LDBLStub)                     \
 391      Sym(vwscanf$LDBLStub)                      \
 392      Sym(warn$LDBLStub)                         \
 393      Sym(warnc$LDBLStub)                        \
 394      Sym(warnx$LDBLStub)                        \
 395      Sym(wcstold$LDBLStub)                      \
 396      Sym(wprintf$LDBLStub)                      \
 397      Sym(wscanf$LDBLStub)
 398 #else
 399 #define RTS_DARWIN_ONLY_SYMBOLS
 400 #endif
 401
 402 #ifndef SMP
 403 # define MAIN_CAP_SYM SymX(MainCapability)
 404 #else
 405 # define MAIN_CAP_SYM
 406 #endif
 407
 408 #if !defined(mingw32_HOST_OS)
 409 #define RTS_USER_SIGNALS_SYMBOLS \
 410    SymX(setIOManagerPipe)
 411 #else
 412 #define RTS_USER_SIGNALS_SYMBOLS \
 413    SymX(sendIOManagerEvent) \
 414    SymX(readIOManagerEvent) \
 415    SymX(getIOManagerEvent) \
 416    SymX(console_handler)
 417 #endif
 418
 419 #ifdef TABLES_NEXT_TO_CODE
 420 #define RTS_RET_SYMBOLS /* nothing */
 421 #else
 422 #define RTS_RET_SYMBOLS                         \
 423       SymX(stg_enter_ret)                       \
 424       SymX(stg_gc_fun_ret)                      \
 425       SymX(stg_ap_v_ret)                        \
 426       SymX(stg_ap_f_ret)                        \
 427       SymX(stg_ap_d_ret)                        \
 428       SymX(stg_ap_l_ret)                        \
 429       SymX(stg_ap_n_ret)                        \
 430       SymX(stg_ap_p_ret)                        \
 431       SymX(stg_ap_pv_ret)                       \
 432       SymX(stg_ap_pp_ret)                       \
 433       SymX(stg_ap_ppv_ret)                      \
 434       SymX(stg_ap_ppp_ret)                      \
 435       SymX(stg_ap_pppv_ret)                     \
 436       SymX(stg_ap_pppp_ret)                     \
 437       SymX(stg_ap_ppppp_ret)                    \
 438       SymX(stg_ap_pppppp_ret)
 439 #endif
 440
 441 #define RTS_SYMBOLS                             \
 442       Maybe_Stable_Names                        \
 443       Sym(StgReturn)                            \
 444       SymX(stg_enter_info)                      \
 445       SymX(stg_gc_void_info)                    \
 446       SymX(__stg_gc_enter_1)                    \
 447       SymX(stg_gc_noregs)                       \
 448       SymX(stg_gc_unpt_r1_info)                 \
 449       SymX(stg_gc_unpt_r1)                      \
 450       SymX(stg_gc_unbx_r1_info)                 \
 451       SymX(stg_gc_unbx_r1)                      \
 452       SymX(stg_gc_f1_info)                      \
 453       SymX(stg_gc_f1)                           \
 454       SymX(stg_gc_d1_info)                      \
 455       SymX(stg_gc_d1)                           \
 456       SymX(stg_gc_l1_info)                      \
 457       SymX(stg_gc_l1)                           \
 458       SymX(__stg_gc_fun)                        \
 459       SymX(stg_gc_fun_info)                     \
 460       SymX(stg_gc_gen)                          \
 461       SymX(stg_gc_gen_info)                     \
 462       SymX(stg_gc_gen_hp)                       \
 463       SymX(stg_gc_ut)                           \
 464       SymX(stg_gen_yield)                       \
 465       SymX(stg_yield_noregs)                    \
 466       SymX(stg_yield_to_interpreter)            \
 467       SymX(stg_gen_block)                       \
 468       SymX(stg_block_noregs)                    \
 469       SymX(stg_block_1)                         \
 470       SymX(stg_block_takemvar)                  \
 471       SymX(stg_block_putmvar)                   \
 472       MAIN_CAP_SYM                              \
 473       SymX(MallocFailHook)                      \
 474       SymX(OnExitHook)                          \
 475       SymX(OutOfHeapHook)                       \
 476       SymX(StackOverflowHook)                   \
 477       SymX(__encodeDouble)                      \
 478       SymX(__encodeFloat)                       \
 479       SymX(addDLL)                              \
 480       SymX(__gmpn_gcd_1)                        \
 481       SymX(__gmpz_cmp)                          \
 482       SymX(__gmpz_cmp_si)                       \
 483       SymX(__gmpz_cmp_ui)                       \
 484       SymX(__gmpz_get_si)                       \
 485       SymX(__gmpz_get_ui)                       \
 486       SymX(__int_encodeDouble)                  \
 487       SymX(__int_encodeFloat)                   \
 488       SymX(andIntegerzh_fast)                   \
 489       SymX(atomicallyzh_fast)                   \
 490       SymX(barf)                                \
 491       SymX(debugBelch)                          \
 492       SymX(errorBelch)                          \
 493       SymX(blockAsyncExceptionszh_fast)         \
 494       SymX(catchzh_fast)                        \
 495       SymX(catchRetryzh_fast)                   \
 496       SymX(catchSTMzh_fast)                     \
 497       SymX(checkzh_fast)                        \
 498       SymX(closure_flags)                       \
 499       SymX(cmp_thread)                          \
 500       SymX(cmpIntegerzh_fast)                   \
 501       SymX(cmpIntegerIntzh_fast)                \
 502       SymX(complementIntegerzh_fast)            \
 503       SymX(createAdjustor)                      \
 504       SymX(decodeDoublezh_fast)                 \
 505       SymX(decodeFloatzh_fast)                  \
 506       SymX(defaultsHook)                        \
 507       SymX(delayzh_fast)                        \
 508       SymX(deRefWeakzh_fast)                    \
 509       SymX(deRefStablePtrzh_fast)               \
 510       SymX(dirty_MUT_VAR)                       \
 511       SymX(divExactIntegerzh_fast)              \
 512       SymX(divModIntegerzh_fast)                \
 513       SymX(forkzh_fast)                         \
 514       SymX(forkOnzh_fast)                       \
 515       SymX(forkProcess)                         \
 516       SymX(forkOS_createThread)                 \
 517       SymX(freeHaskellFunctionPtr)              \
 518       SymX(freeStablePtr)                       \
 519       SymX(getOrSetTypeableStore)               \
 520       SymX(gcdIntegerzh_fast)                   \
 521       SymX(gcdIntegerIntzh_fast)                \
 522       SymX(gcdIntzh_fast)                       \
 523       SymX(genSymZh)                            \
 524       SymX(genericRaise)                        \
 525       SymX(getProgArgv)                         \
 526       SymX(getStablePtr)                        \
 527       SymX(hs_init)                             \
 528       SymX(hs_exit)                             \
 529       SymX(hs_set_argv)                         \
 530       SymX(hs_add_root)                         \
 531       SymX(hs_perform_gc)                       \
 532       SymX(hs_free_stable_ptr)                  \
 533       SymX(hs_free_fun_ptr)                     \
 534       SymX(initLinker)                          \
 535       SymX(unpackClosurezh_fast)                \
 536       SymX(getApStackValzh_fast)                \
 537       SymX(int2Integerzh_fast)                  \
 538       SymX(integer2Intzh_fast)                  \
 539       SymX(integer2Wordzh_fast)                 \
 540       SymX(isCurrentThreadBoundzh_fast)         \
 541       SymX(isDoubleDenormalized)                \
 542       SymX(isDoubleInfinite)                    \
 543       SymX(isDoubleNaN)                         \
 544       SymX(isDoubleNegativeZero)                \
 545       SymX(isEmptyMVarzh_fast)                  \
 546       SymX(isFloatDenormalized)                 \
 547       SymX(isFloatInfinite)                     \
 548       SymX(isFloatNaN)                          \
 549       SymX(isFloatNegativeZero)                 \
 550       SymX(killThreadzh_fast)                   \
 551       SymX(loadObj)                             \
 552       SymX(insertStableSymbol)                  \
 553       SymX(insertSymbol)                        \
 554       SymX(lookupSymbol)                        \
 555       SymX(makeStablePtrzh_fast)                \
 556       SymX(minusIntegerzh_fast)                 \
 557       SymX(mkApUpd0zh_fast)                     \
 558       SymX(myThreadIdzh_fast)                   \
 559       SymX(labelThreadzh_fast)                  \
 560       SymX(newArrayzh_fast)                     \
 561       SymX(newBCOzh_fast)                       \
 562       SymX(newByteArrayzh_fast)                 \
 563       SymX_redirect(newCAF, newDynCAF)          \
 564       SymX(newMVarzh_fast)                      \
 565       SymX(newMutVarzh_fast)                    \
 566       SymX(newTVarzh_fast)                      \
 567       SymX(noDuplicatezh_fast)                  \
 568       SymX(atomicModifyMutVarzh_fast)           \
 569       SymX(newPinnedByteArrayzh_fast)           \
 570       SymX(newSpark)                            \
 571       SymX(orIntegerzh_fast)                    \
 572       SymX(performGC)                           \
 573       SymX(performMajorGC)                      \
 574       SymX(plusIntegerzh_fast)                  \
 575       SymX(prog_argc)                           \
 576       SymX(prog_argv)                           \
 577       SymX(putMVarzh_fast)                      \
 578       SymX(quotIntegerzh_fast)                  \
 579       SymX(quotRemIntegerzh_fast)               \
 580       SymX(raisezh_fast)                        \
 581       SymX(raiseIOzh_fast)                      \
 582       SymX(readTVarzh_fast)                     \
 583       SymX(remIntegerzh_fast)                   \
 584       SymX(resetNonBlockingFd)                  \
 585       SymX(resumeThread)                        \
 586       SymX(resolveObjs)                         \
 587       SymX(retryzh_fast)                        \
 588       SymX(rts_apply)                           \
 589       SymX(rts_checkSchedStatus)                \
 590       SymX(rts_eval)                            \
 591       SymX(rts_evalIO)                          \
 592       SymX(rts_evalLazyIO)                      \
 593       SymX(rts_evalStableIO)                    \
 594       SymX(rts_eval_)                           \
 595       SymX(rts_getBool)                         \
 596       SymX(rts_getChar)                         \
 597       SymX(rts_getDouble)                       \
 598       SymX(rts_getFloat)                        \
 599       SymX(rts_getInt)                          \
 600       SymX(rts_getInt32)                        \
 601       SymX(rts_getPtr)                          \
 602       SymX(rts_getFunPtr)                       \
 603       SymX(rts_getStablePtr)                    \
 604       SymX(rts_getThreadId)                     \
 605       SymX(rts_getWord)                         \
 606       SymX(rts_getWord32)                       \
 607       SymX(rts_lock)                            \
 608       SymX(rts_mkBool)                          \
 609       SymX(rts_mkChar)                          \
 610       SymX(rts_mkDouble)                        \
 611       SymX(rts_mkFloat)                         \
 612       SymX(rts_mkInt)                           \
 613       SymX(rts_mkInt16)                         \
 614       SymX(rts_mkInt32)                         \
 615       SymX(rts_mkInt64)                         \
 616       SymX(rts_mkInt8)                          \
 617       SymX(rts_mkPtr)                           \
 618       SymX(rts_mkFunPtr)                        \
 619       SymX(rts_mkStablePtr)                     \
 620       SymX(rts_mkString)                        \
 621       SymX(rts_mkWord)                          \
 622       SymX(rts_mkWord16)                        \
 623       SymX(rts_mkWord32)                        \
 624       SymX(rts_mkWord64)                        \
 625       SymX(rts_mkWord8)                         \
 626       SymX(rts_unlock)                          \
 627       SymX(rtsSupportsBoundThreads)             \
 628       SymX(__hscore_get_saved_termios)          \
 629       SymX(__hscore_set_saved_termios)          \
 630       SymX(setProgArgv)                         \
 631       SymX(startupHaskell)                      \
 632       SymX(shutdownHaskell)                     \
 633       SymX(shutdownHaskellAndExit)              \
 634       SymX(stable_ptr_table)                    \
 635       SymX(stackOverflow)                       \
 636       SymX(stg_CAF_BLACKHOLE_info)              \
 637       SymX(awakenBlockedQueue)                  \
 638       SymX(stg_CHARLIKE_closure)                \
 639       SymX(stg_EMPTY_MVAR_info)                 \
 640       SymX(stg_IND_STATIC_info)                 \
 641       SymX(stg_INTLIKE_closure)                 \
 642       SymX(stg_MUT_ARR_PTRS_DIRTY_info)         \
 643       SymX(stg_MUT_ARR_PTRS_FROZEN_info)        \
 644       SymX(stg_MUT_ARR_PTRS_FROZEN0_info)       \
 645       SymX(stg_WEAK_info)                       \
 646       SymX(stg_ap_v_info)                       \
 647       SymX(stg_ap_f_info)                       \
 648       SymX(stg_ap_d_info)                       \
 649       SymX(stg_ap_l_info)                       \
 650       SymX(stg_ap_n_info)                       \
 651       SymX(stg_ap_p_info)                       \
 652       SymX(stg_ap_pv_info)                      \
 653       SymX(stg_ap_pp_info)                      \
 654       SymX(stg_ap_ppv_info)                     \
 655       SymX(stg_ap_ppp_info)                     \
 656       SymX(stg_ap_pppv_info)                    \
 657       SymX(stg_ap_pppp_info)                    \
 658       SymX(stg_ap_ppppp_info)                   \
 659       SymX(stg_ap_pppppp_info)                  \
 660       SymX(stg_ap_0_fast)                       \
 661       SymX(stg_ap_v_fast)                       \
 662       SymX(stg_ap_f_fast)                       \
 663       SymX(stg_ap_d_fast)                       \
 664       SymX(stg_ap_l_fast)                       \
 665       SymX(stg_ap_n_fast)                       \
 666       SymX(stg_ap_p_fast)                       \
 667       SymX(stg_ap_pv_fast)                      \
 668       SymX(stg_ap_pp_fast)                      \
 669       SymX(stg_ap_ppv_fast)                     \
 670       SymX(stg_ap_ppp_fast)                     \
 671       SymX(stg_ap_pppv_fast)                    \
 672       SymX(stg_ap_pppp_fast)                    \
 673       SymX(stg_ap_ppppp_fast)                   \
 674       SymX(stg_ap_pppppp_fast)                  \
 675       SymX(stg_ap_1_upd_info)                   \
 676       SymX(stg_ap_2_upd_info)                   \
 677       SymX(stg_ap_3_upd_info)                   \
 678       SymX(stg_ap_4_upd_info)                   \
 679       SymX(stg_ap_5_upd_info)                   \
 680       SymX(stg_ap_6_upd_info)                   \
 681       SymX(stg_ap_7_upd_info)                   \
 682       SymX(stg_exit)                            \
 683       SymX(stg_sel_0_upd_info)                  \
 684       SymX(stg_sel_10_upd_info)                 \
 685       SymX(stg_sel_11_upd_info)                 \
 686       SymX(stg_sel_12_upd_info)                 \
 687       SymX(stg_sel_13_upd_info)                 \
 688       SymX(stg_sel_14_upd_info)                 \
 689       SymX(stg_sel_15_upd_info)                 \
 690       SymX(stg_sel_1_upd_info)                  \
 691       SymX(stg_sel_2_upd_info)                  \
 692       SymX(stg_sel_3_upd_info)                  \
 693       SymX(stg_sel_4_upd_info)                  \
 694       SymX(stg_sel_5_upd_info)                  \
 695       SymX(stg_sel_6_upd_info)                  \
 696       SymX(stg_sel_7_upd_info)                  \
 697       SymX(stg_sel_8_upd_info)                  \
 698       SymX(stg_sel_9_upd_info)                  \
 699       SymX(stg_upd_frame_info)                  \
 700       SymX(suspendThread)                       \
 701       SymX(takeMVarzh_fast)                     \
 702       SymX(timesIntegerzh_fast)                 \
 703       SymX(tryPutMVarzh_fast)                   \
 704       SymX(tryTakeMVarzh_fast)                  \
 705       SymX(unblockAsyncExceptionszh_fast)       \
 706       SymX(unloadObj)                           \
 707       SymX(unsafeThawArrayzh_fast)              \
 708       SymX(waitReadzh_fast)                     \
 709       SymX(waitWritezh_fast)                    \
 710       SymX(word2Integerzh_fast)                 \
 711       SymX(writeTVarzh_fast)                    \
 712       SymX(xorIntegerzh_fast)                   \
 713       SymX(yieldzh_fast)                        \
 714       SymX(stg_interp_constr_entry)             \
 715       SymX(allocateExec)                        \
 716       SymX(freeExec)                            \
 717       SymX(getAllocations)                      \
 718       SymX(revertCAFs)                          \
 719       SymX(RtsFlags)                            \
 720       SymX(rts_breakpoint_io_action)            \
 721       SymX(rts_stop_next_breakpoint)            \
 722       SymX(rts_stop_on_exception)               \
 723       RTS_USER_SIGNALS_SYMBOLS
 724
 725 #ifdef SUPPORT_LONG_LONGS
 726 #define RTS_LONG_LONG_SYMS                      \
 727       SymX(int64ToIntegerzh_fast)               \
 728       SymX(word64ToIntegerzh_fast)
 729 #else
 730 #define RTS_LONG_LONG_SYMS /* nothing */
 731 #endif
 732
 733 // 64-bit support functions in libgcc.a
 734 #if defined(__GNUC__) && SIZEOF_VOID_P <= 4
 735 #define RTS_LIBGCC_SYMBOLS                      \
 736       Sym(__divdi3)                             \
 737       Sym(__udivdi3)                            \
 738       Sym(__moddi3)                             \
 739       Sym(__umoddi3)                            \
 740       Sym(__muldi3)                             \
 741       Sym(__ashldi3)                            \
 742       Sym(__ashrdi3)                            \
 743       Sym(__lshrdi3)                            \
 744       Sym(__eprintf)
 745 #elif defined(ia64_HOST_ARCH)
 746 #define RTS_LIBGCC_SYMBOLS                      \
 747       Sym(__divdi3)                             \
 748       Sym(__udivdi3)                            \
 749       Sym(__moddi3)                             \
 750       Sym(__umoddi3)                            \
 751       Sym(__divsf3)                             \
 752       Sym(__divdf3)
 753 #else
 754 #define RTS_LIBGCC_SYMBOLS
 755 #endif
 756
 757 #if defined(darwin_HOST_OS) && defined(powerpc_HOST_ARCH)
 758       // Symbols that don't have a leading underscore
 759       // on Mac OS X. They have to receive special treatment,
 760       // see machoInitSymbolsWithoutUnderscore()
 761 #define RTS_MACHO_NOUNDERLINE_SYMBOLS           \
 762       Sym(saveFP)                               \
 763       Sym(restFP)
 764 #endif
 765
 766 /* entirely bogus claims about types of these symbols */
 767 #define Sym(vvv)  extern void vvv(void);
 768 #define SymX(vvv) /**/
 769 #define SymX_redirect(vvv,xxx) /**/
 770 RTS_SYMBOLS
 771 RTS_RET_SYMBOLS
 772 RTS_LONG_LONG_SYMS
 773 RTS_POSIX_ONLY_SYMBOLS
 774 RTS_MINGW_ONLY_SYMBOLS
 775 RTS_CYGWIN_ONLY_SYMBOLS
 776 RTS_DARWIN_ONLY_SYMBOLS
 777 RTS_LIBGCC_SYMBOLS
 778 #undef Sym
 779 #undef SymX
 780 #undef SymX_redirect
 781
 782 #ifdef LEADING_UNDERSCORE
 783 #define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
 784 #else
 785 #define MAYBE_LEADING_UNDERSCORE_STR(s) (s)
 786 #endif
 787
 788 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 789                     (void*)(&(vvv)) },
 790 #define SymX(vvv) Sym(vvv)
 791
 792 // SymX_redirect allows us to redirect references to one symbol to
 793 // another symbol.  See newCAF/newDynCAF for an example.
 794 #define SymX_redirect(vvv,xxx) \
 795     { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 796       (void*)(&(xxx)) },
 797
 798 static RtsSymbolVal rtsSyms[] = {
 799       RTS_SYMBOLS
 800       RTS_RET_SYMBOLS
 801       RTS_LONG_LONG_SYMS
 802       RTS_POSIX_ONLY_SYMBOLS
 803       RTS_MINGW_ONLY_SYMBOLS
 804       RTS_CYGWIN_ONLY_SYMBOLS
 805       RTS_DARWIN_ONLY_SYMBOLS
 806       RTS_LIBGCC_SYMBOLS
 807 #if defined(darwin_HOST_OS) && defined(i386_HOST_ARCH)
 808       // dyld stub code contains references to this,
 809       // but it should never be called because we treat
 810       // lazy pointers as nonlazy.
 811       { "dyld_stub_binding_helper", (void*)0xDEADBEEF },
 812 #endif
 813       { 0, 0 } /* sentinel */
 814 };
 815
 816
 817
 818 /* -----------------------------------------------------------------------------
 819  * Insert symbols into hash tables, checking for duplicates.
 820  */
 821
 822 static void ghciInsertStrHashTable ( char* obj_name,
 823                                      HashTable *table,
 824                                      char* key,
 825                                      void *data
 826                                    )
 827 {
 828    if (lookupHashTable(table, (StgWord)key) == NULL)
 829    {
 830       insertStrHashTable(table, (StgWord)key, data);
 831       return;
 832    }
 833    debugBelch(
 834       "\n\n"
 835       "GHCi runtime linker: fatal error: I found a duplicate definition for symbol\n"
 836       "   %s\n"
 837       "whilst processing object file\n"
 838       "   %s\n"
 839       "This could be caused by:\n"
 840       "   * Loading two different object files which export the same symbol\n"
 841       "   * Specifying the same object file twice on the GHCi command line\n"
 842       "   * An incorrect `package.conf' entry, causing some object to be\n"
 843       "     loaded twice.\n"
 844       "GHCi cannot safely continue in this situation.  Exiting now.  Sorry.\n"
 845       "\n",
 846       (char*)key,
 847       obj_name
 848    );
 849    exit(1);
 850 }
 851 /* -----------------------------------------------------------------------------
 852  * initialize the object linker
 853  */
 854
 855
 856 static int linker_init_done = 0 ;
 857
 858 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 859 static void *dl_prog_handle;
 860 #endif
 861
 862 void
 863 initLinker( void )
 864 {
 865     RtsSymbolVal *sym;
 866
 867     /* Make initLinker idempotent, so we can call it
 868        before evey relevant operation; that means we
 869        don't need to initialise the linker separately */
 870     if (linker_init_done == 1) { return; } else {
 871       linker_init_done = 1;
 872     }
 873
 874     stablehash = allocStrHashTable();
 875     symhash = allocStrHashTable();
 876
 877     /* populate the symbol table with stuff from the RTS */
 878     for (sym = rtsSyms; sym->lbl != NULL; sym++) {
 879         ghciInsertStrHashTable("(GHCi built-in symbols)",
 880                                symhash, sym->lbl, sym->addr);
 881     }
 882 #   if defined(OBJFORMAT_MACHO) && defined(powerpc_HOST_ARCH)
 883     machoInitSymbolsWithoutUnderscore();
 884 #   endif
 885
 886 #   if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 887 #   if defined(RTLD_DEFAULT)
 888     dl_prog_handle = RTLD_DEFAULT;
 889 #   else
 890     dl_prog_handle = dlopen(NULL, RTLD_LAZY);
 891 #   endif /* RTLD_DEFAULT */
 892 #   endif
 893 }
 894
 895 /* -----------------------------------------------------------------------------
 896  *                  Loading DLL or .so dynamic libraries
 897  * -----------------------------------------------------------------------------
 898  *
 899  * Add a DLL from which symbols may be found.  In the ELF case, just
 900  * do RTLD_GLOBAL-style add, so no further messing around needs to
 901  * happen in order that symbols in the loaded .so are findable --
 902  * lookupSymbol() will subsequently see them by dlsym on the program's
 903  * dl-handle.  Returns NULL if success, otherwise ptr to an err msg.
 904  *
 905  * In the PEi386 case, open the DLLs and put handles to them in a
 906  * linked list.  When looking for a symbol, try all handles in the
 907  * list.  This means that we need to load even DLLs that are guaranteed
 908  * to be in the ghc.exe image already, just so we can get a handle
 909  * to give to loadSymbol, so that we can find the symbols.  For such
 910  * libraries, the LoadLibrary call should be a no-op except for returning
 911  * the handle.
 912  *
 913  */
 914
 915 #if defined(OBJFORMAT_PEi386)
 916 /* A record for storing handles into DLLs. */
 917
 918 typedef
 919    struct _OpenedDLL {
 920       char*              name;
 921       struct _OpenedDLL* next;
 922       HINSTANCE instance;
 923    }
 924    OpenedDLL;
 925
 926 /* A list thereof. */
 927 static OpenedDLL* opened_dlls = NULL;
 928 #endif
 929
 930 char *
 931 addDLL( char *dll_name )
 932 {
 933 #  if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 934    /* ------------------- ELF DLL loader ------------------- */
 935    void *hdl;
 936    char *errmsg;
 937
 938    initLinker();
 939
 940    hdl= dlopen(dll_name, RTLD_NOW | RTLD_GLOBAL);
 941
 942    if (hdl == NULL) {
 943       /* dlopen failed; return a ptr to the error msg. */
 944       errmsg = dlerror();
 945       if (errmsg == NULL) errmsg = "addDLL: unknown error";
 946       return errmsg;
 947    } else {
 948       return NULL;
 949    }
 950    /*NOTREACHED*/
 951
 952 #  elif defined(OBJFORMAT_PEi386)
 953    /* ------------------- Win32 DLL loader ------------------- */
 954
 955    char*      buf;
 956    OpenedDLL* o_dll;
 957    HINSTANCE  instance;
 958
 959    initLinker();
 960
 961    /* debugBelch("\naddDLL; dll_name = `%s'\n", dll_name); */
 962
 963    /* See if we've already got it, and ignore if so. */
 964    for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
 965       if (0 == strcmp(o_dll->name, dll_name))
 966          return NULL;
 967    }
 968
 969    /* The file name has no suffix (yet) so that we can try
 970       both foo.dll and foo.drv
 971
 972       The documentation for LoadLibrary says:
 973         If no file name extension is specified in the lpFileName
 974         parameter, the default library extension .dll is
 975         appended. However, the file name string can include a trailing
 976         point character (.) to indicate that the module name has no
 977         extension. */
 978
 979    buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
 980    sprintf(buf, "%s.DLL", dll_name);
 981    instance = LoadLibrary(buf);
 982    if (instance == NULL) {
 983          sprintf(buf, "%s.DRV", dll_name);      // KAA: allow loading of drivers (like winspool.drv)
 984          instance = LoadLibrary(buf);
 985          if (instance == NULL) {
 986                 stgFree(buf);
 987
 988             /* LoadLibrary failed; return a ptr to the error msg. */
 989             return "addDLL: unknown error";
 990          }
 991    }
 992    stgFree(buf);
 993
 994    /* Add this DLL to the list of DLLs in which to search for symbols. */
 995    o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
 996    o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
 997    strcpy(o_dll->name, dll_name);
 998    o_dll->instance = instance;
 999    o_dll->next     = opened_dlls;
1000    opened_dlls     = o_dll;
1001
1002    return NULL;
1003 #  else
1004    barf("addDLL: not implemented on this platform");
1005 #  endif
1006 }
1007
1008 /* -----------------------------------------------------------------------------
1009  * insert a stable symbol in the hash table
1010  */
1011
1012 void
1013 insertStableSymbol(char* obj_name, char* key, StgPtr p)
1014 {
1015   ghciInsertStrHashTable(obj_name, stablehash, key, getStablePtr(p));
1016 }
1017
1018
1019 /* -----------------------------------------------------------------------------
1020  * insert a symbol in the hash table
1021  */
1022 void
1023 insertSymbol(char* obj_name, char* key, void* data)
1024 {
1025   ghciInsertStrHashTable(obj_name, symhash, key, data);
1026 }
1027
1028 /* -----------------------------------------------------------------------------
1029  * lookup a symbol in the hash table
1030  */
1031 void *
1032 lookupSymbol( char *lbl )
1033 {
1034     void *val;
1035     initLinker() ;
1036     ASSERT(symhash != NULL);
1037     val = lookupStrHashTable(symhash, lbl);
1038
1039     if (val == NULL) {
1040 #       if defined(OBJFORMAT_ELF)
1041 #       if defined(x86_64_HOST_ARCH)
1042         val = dlsym(dl_prog_handle, lbl);
1043         if (val >= (void *)0x80000000) {
1044             void *new_val;
1045             new_val = x86_64_high_symbol(lbl, val);
1046             IF_DEBUG(linker,debugBelch("lookupSymbol: relocating out of range symbol: %s = %p, now %p\n", lbl, val, new_val));
1047             return new_val;
1048         } else {
1049             return val;
1050         }
1051 #       else
1052         return dlsym(dl_prog_handle, lbl);
1053 #       endif
1054 #       elif defined(OBJFORMAT_MACHO)
1055         if(NSIsSymbolNameDefined(lbl)) {
1056             NSSymbol symbol = NSLookupAndBindSymbol(lbl);
1057             return NSAddressOfSymbol(symbol);
1058         } else {
1059             return NULL;
1060         }
1061 #       elif defined(OBJFORMAT_PEi386)
1062         OpenedDLL* o_dll;
1063         void* sym;
1064         for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
1065           /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
1066            if (lbl[0] == '_') {
1067               /* HACK: if the name has an initial underscore, try stripping
1068                  it off & look that up first. I've yet to verify whether there's
1069                  a Rule that governs whether an initial '_' *should always* be
1070                  stripped off when mapping from import lib name to the DLL name.
1071               */
1072               sym = GetProcAddress(o_dll->instance, (lbl+1));
1073               if (sym != NULL) {
1074                 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
1075                 return sym;
1076               }
1077            }
1078            sym = GetProcAddress(o_dll->instance, lbl);
1079            if (sym != NULL) {
1080              /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
1081              return sym;
1082            }
1083         }
1084         return NULL;
1085 #       else
1086         ASSERT(2+2 == 5);
1087         return NULL;
1088 #       endif
1089     } else {
1090         return val;
1091     }
1092 }
1093
1094 static
1095 __attribute((unused))
1096 void *
1097 lookupLocalSymbol( ObjectCode* oc, char *lbl )
1098 {
1099     void *val;
1100     initLinker() ;
1101     val = lookupStrHashTable(oc->lochash, lbl);
1102
1103     if (val == NULL) {
1104         return NULL;
1105     } else {
1106         return val;
1107     }
1108 }
1109
1110
1111 /* -----------------------------------------------------------------------------
1112  * Debugging aid: look in GHCi's object symbol tables for symbols
1113  * within DELTA bytes of the specified address, and show their names.
1114  */
1115 #ifdef DEBUG
1116 void ghci_enquire ( char* addr );
1117
1118 void ghci_enquire ( char* addr )
1119 {
1120    int   i;
1121    char* sym;
1122    char* a;
1123    const int DELTA = 64;
1124    ObjectCode* oc;
1125
1126    initLinker();
1127
1128    for (oc = objects; oc; oc = oc->next) {
1129       for (i = 0; i < oc->n_symbols; i++) {
1130          sym = oc->symbols[i];
1131          if (sym == NULL) continue;
1132          // debugBelch("enquire %p %p\n", sym, oc->lochash);
1133          a = NULL;
1134          if (oc->lochash != NULL) {
1135             a = lookupStrHashTable(oc->lochash, sym);
1136          }
1137          if (a == NULL) {
1138             a = lookupStrHashTable(symhash, sym);
1139          }
1140          if (a == NULL) {
1141              // debugBelch("ghci_enquire: can't find %s\n", sym);
1142          }
1143          else if (addr-DELTA <= a && a <= addr+DELTA) {
1144             debugBelch("%p + %3d  ==  `%s'\n", addr, (int)(a - addr), sym);
1145          }
1146       }
1147    }
1148 }
1149 #endif
1150
1151 #ifdef ia64_HOST_ARCH
1152 static unsigned int PLTSize(void);
1153 #endif
1154
1155 /* -----------------------------------------------------------------------------
1156  * Load an obj (populate the global symbol table, but don't resolve yet)
1157  *
1158  * Returns: 1 if ok, 0 on error.
1159  */
1160 HsInt
1161 loadObj( char *path )
1162 {
1163    ObjectCode* oc;
1164    struct stat st;
1165    int r, n;
1166 #ifdef USE_MMAP
1167    int fd, pagesize;
1168    void *map_addr = NULL;
1169 #else
1170    FILE *f;
1171 #endif
1172    initLinker();
1173
1174    /* debugBelch("loadObj %s\n", path ); */
1175
1176    /* Check that we haven't already loaded this object.
1177       Ignore requests to load multiple times */
1178    {
1179        ObjectCode *o;
1180        int is_dup = 0;
1181        for (o = objects; o; o = o->next) {
1182           if (0 == strcmp(o->fileName, path)) {
1183              is_dup = 1;
1184              break; /* don't need to search further */
1185           }
1186        }
1187        if (is_dup) {
1188           IF_DEBUG(linker, debugBelch(
1189             "GHCi runtime linker: warning: looks like you're trying to load the\n"
1190             "same object file twice:\n"
1191             "   %s\n"
1192             "GHCi will ignore this, but be warned.\n"
1193             , path));
1194           return 1; /* success */
1195        }
1196    }
1197
1198    oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");
1199
1200 #  if defined(OBJFORMAT_ELF)
1201    oc->formatName = "ELF";
1202 #  elif defined(OBJFORMAT_PEi386)
1203    oc->formatName = "PEi386";
1204 #  elif defined(OBJFORMAT_MACHO)
1205    oc->formatName = "Mach-O";
1206 #  else
1207    stgFree(oc);
1208    barf("loadObj: not implemented on this platform");
1209 #  endif
1210
1211    r = stat(path, &st);
1212    if (r == -1) { return 0; }
1213
1214    /* sigh, strdup() isn't a POSIX function, so do it the long way */
1215    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
1216    strcpy(oc->fileName, path);
1217
1218    oc->fileSize          = st.st_size;
1219    oc->symbols           = NULL;
1220    oc->sections          = NULL;
1221    oc->lochash           = allocStrHashTable();
1222    oc->proddables        = NULL;
1223
1224    /* chain it onto the list of objects */
1225    oc->next              = objects;
1226    objects               = oc;
1227
1228 #ifdef USE_MMAP
1229 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
1230
1231    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
1232
1233 #if defined(openbsd_HOST_OS)
1234    fd = open(path, O_RDONLY, S_IRUSR);
1235 #else
1236    fd = open(path, O_RDONLY);
1237 #endif
1238    if (fd == -1)
1239       barf("loadObj: can't open `%s'", path);
1240
1241    pagesize = getpagesize();
1242
1243 #ifdef ia64_HOST_ARCH
1244    /* The PLT needs to be right before the object */
1245    n = ROUND_UP(PLTSize(), pagesize);
1246    oc->plt = mmap(NULL, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
1247    if (oc->plt == MAP_FAILED)
1248       barf("loadObj: can't allocate PLT");
1249
1250    oc->pltIndex = 0;
1251    map_addr = oc->plt + n;
1252 #endif
1253
1254    n = ROUND_UP(oc->fileSize, pagesize);
1255
1256    /* Link objects into the lower 2Gb on x86_64.  GHC assumes the
1257     * small memory model on this architecture (see gcc docs,
1258     * -mcmodel=small).
1259     */
1260 #ifdef x86_64_HOST_ARCH
1261 #define EXTRA_MAP_FLAGS MAP_32BIT
1262 #else
1263 #define EXTRA_MAP_FLAGS 0
1264 #endif
1265
1266    oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE,
1267                     MAP_PRIVATE|EXTRA_MAP_FLAGS, fd, 0);
1268    if (oc->image == MAP_FAILED)
1269       barf("loadObj: can't map `%s'", path);
1270
1271    close(fd);
1272
1273 #else /* !USE_MMAP */
1274
1275    /* load the image into memory */
1276    f = fopen(path, "rb");
1277    if (!f)
1278        barf("loadObj: can't read `%s'", path);
1279
1280 #   if defined(mingw32_HOST_OS)
1281         // TODO: We would like to use allocateExec here, but allocateExec
1282         //       cannot currently allocate blocks large enough.
1283     oc->image = VirtualAlloc(NULL, oc->fileSize, MEM_RESERVE | MEM_COMMIT,
1284                              PAGE_EXECUTE_READWRITE);
1285 #   elif defined(darwin_HOST_OS)
1286     // In a Mach-O .o file, all sections can and will be misaligned
1287     // if the total size of the headers is not a multiple of the
1288     // desired alignment. This is fine for .o files that only serve
1289     // as input for the static linker, but it's not fine for us,
1290     // as SSE (used by gcc for floating point) and Altivec require
1291     // 16-byte alignment.
1292     // We calculate the correct alignment from the header before
1293     // reading the file, and then we misalign oc->image on purpose so
1294     // that the actual sections end up aligned again.
1295    oc->misalignment = machoGetMisalignment(f);
1296    oc->image = stgMallocBytes(oc->fileSize + oc->misalignment, "loadObj(image)");
1297    oc->image += oc->misalignment;
1298 #  else
1299    oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");
1300 #  endif
1301
1302    n = fread ( oc->image, 1, oc->fileSize, f );
1303    if (n != oc->fileSize)
1304       barf("loadObj: error whilst reading `%s'", path);
1305
1306    fclose(f);
1307 #endif /* USE_MMAP */
1308
1309 #  if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
1310    r = ocAllocateSymbolExtras_MachO ( oc );
1311    if (!r) { return r; }
1312 #  elif defined(OBJFORMAT_ELF) && defined(powerpc_HOST_ARCH)
1313    r = ocAllocateSymbolExtras_ELF ( oc );
1314    if (!r) { return r; }
1315 #endif
1316
1317    /* verify the in-memory image */
1318 #  if defined(OBJFORMAT_ELF)
1319    r = ocVerifyImage_ELF ( oc );
1320 #  elif defined(OBJFORMAT_PEi386)
1321    r = ocVerifyImage_PEi386 ( oc );
1322 #  elif defined(OBJFORMAT_MACHO)
1323    r = ocVerifyImage_MachO ( oc );
1324 #  else
1325    barf("loadObj: no verify method");
1326 #  endif
1327    if (!r) { return r; }
1328
1329    /* build the symbol list for this image */
1330 #  if defined(OBJFORMAT_ELF)
1331    r = ocGetNames_ELF ( oc );
1332 #  elif defined(OBJFORMAT_PEi386)
1333    r = ocGetNames_PEi386 ( oc );
1334 #  elif defined(OBJFORMAT_MACHO)
1335    r = ocGetNames_MachO ( oc );
1336 #  else
1337    barf("loadObj: no getNames method");
1338 #  endif
1339    if (!r) { return r; }
1340
1341    /* loaded, but not resolved yet */
1342    oc->status = OBJECT_LOADED;
1343
1344    return 1;
1345 }
1346
1347 /* -----------------------------------------------------------------------------
1348  * resolve all the currently unlinked objects in memory
1349  *
1350  * Returns: 1 if ok, 0 on error.
1351  */
1352 HsInt
1353 resolveObjs( void )
1354 {
1355     ObjectCode *oc;
1356     int r;
1357
1358     initLinker();
1359
1360     for (oc = objects; oc; oc = oc->next) {
1361         if (oc->status != OBJECT_RESOLVED) {
1362 #           if defined(OBJFORMAT_ELF)
1363             r = ocResolve_ELF ( oc );
1364 #           elif defined(OBJFORMAT_PEi386)
1365             r = ocResolve_PEi386 ( oc );
1366 #           elif defined(OBJFORMAT_MACHO)
1367             r = ocResolve_MachO ( oc );
1368 #           else
1369             barf("resolveObjs: not implemented on this platform");
1370 #           endif
1371             if (!r) { return r; }
1372             oc->status = OBJECT_RESOLVED;
1373         }
1374     }
1375     return 1;
1376 }
1377
1378 /* -----------------------------------------------------------------------------
1379  * delete an object from the pool
1380  */
1381 HsInt
1382 unloadObj( char *path )
1383 {
1384     ObjectCode *oc, *prev;
1385
1386     ASSERT(symhash != NULL);
1387     ASSERT(objects != NULL);
1388
1389     initLinker();
1390
1391     prev = NULL;
1392     for (oc = objects; oc; prev = oc, oc = oc->next) {
1393         if (!strcmp(oc->fileName,path)) {
1394
1395             /* Remove all the mappings for the symbols within this
1396              * object..
1397              */
1398             {
1399                 int i;
1400                 for (i = 0; i < oc->n_symbols; i++) {
1401                    if (oc->symbols[i] != NULL) {
1402                        removeStrHashTable(symhash, oc->symbols[i], NULL);
1403                    }
1404                 }
1405             }
1406
1407             if (prev == NULL) {
1408                 objects = oc->next;
1409             } else {
1410                 prev->next = oc->next;
1411             }
1412
1413             // We're going to leave this in place, in case there are
1414             // any pointers from the heap into it:
1415                 // #ifdef mingw32_HOST_OS
1416                 //  VirtualFree(oc->image);
1417                 // #else
1418             //  stgFree(oc->image);
1419             // #endif
1420             stgFree(oc->fileName);
1421             stgFree(oc->symbols);
1422             stgFree(oc->sections);
1423             /* The local hash table should have been freed at the end
1424                of the ocResolve_ call on it. */
1425             ASSERT(oc->lochash == NULL);
1426             stgFree(oc);
1427             return 1;
1428         }
1429     }
1430
1431     errorBelch("unloadObj: can't find `%s' to unload", path);
1432     return 0;
1433 }
1434
1435 /* -----------------------------------------------------------------------------
1436  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
1437  * which may be prodded during relocation, and abort if we try and write
1438  * outside any of these.
1439  */
1440 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
1441 {
1442    ProddableBlock* pb
1443       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1444    /* debugBelch("aPB %p %p %d\n", oc, start, size); */
1445    ASSERT(size > 0);
1446    pb->start      = start;
1447    pb->size       = size;
1448    pb->next       = oc->proddables;
1449    oc->proddables = pb;
1450 }
1451
1452 static void checkProddableBlock ( ObjectCode* oc, void* addr )
1453 {
1454    ProddableBlock* pb;
1455    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1456       char* s = (char*)(pb->start);
1457       char* e = s + pb->size - 1;
1458       char* a = (char*)addr;
1459       /* Assumes that the biggest fixup involves a 4-byte write.  This
1460          probably needs to be changed to 8 (ie, +7) on 64-bit
1461          plats. */
1462       if (a >= s && (a+3) <= e) return;
1463    }
1464    barf("checkProddableBlock: invalid fixup in runtime linker");
1465 }
1466
1467 /* -----------------------------------------------------------------------------
1468  * Section management.
1469  */
1470 static void addSection ( ObjectCode* oc, SectionKind kind,
1471                          void* start, void* end )
1472 {
1473    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
1474    s->start     = start;
1475    s->end       = end;
1476    s->kind      = kind;
1477    s->next      = oc->sections;
1478    oc->sections = s;
1479    /*
1480    debugBelch("addSection: %p-%p (size %d), kind %d\n",
1481                    start, ((char*)end)-1, end - start + 1, kind );
1482    */
1483 }
1484
1485
1486 /* --------------------------------------------------------------------------
1487  * Symbol Extras.
1488  * This is about allocating a small chunk of memory for every symbol in the
1489  * object file. We make sure that the SymboLExtras are always "in range" of
1490  * limited-range PC-relative instructions on various platforms by allocating
1491  * them right next to the object code itself.
1492  */
1493
1494 #if defined(powerpc_HOST_ARCH) || (defined(x86_64_HOST_ARCH) \
1495                                     && defined(darwin_TARGET_OS))
1496
1497 /*
1498   ocAllocateSymbolExtras
1499
1500   Allocate additional space at the end of the object file image to make room
1501   for jump islands (powerpc, x86_64) and GOT entries (x86_64).
1502
1503   PowerPC relative branch instructions have a 24 bit displacement field.
1504   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
1505   If a particular imported symbol is outside this range, we have to redirect
1506   the jump to a short piece of new code that just loads the 32bit absolute
1507   address and jumps there.
1508   On x86_64, PC-relative jumps and PC-relative accesses to the GOT are limited
1509   to 32 bits (+-2GB).
1510
1511   This function just allocates space for one SymbolExtra for every
1512   undefined symbol in the object file. The code for the jump islands is
1513   filled in by makeSymbolExtra below.
1514 */
1515
1516 static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
1517 {
1518 #ifdef USE_MMAP
1519   int pagesize, n, m;
1520 #endif
1521   int aligned;
1522   int misalignment = 0;
1523 #if darwin_HOST_OS
1524   misalignment = oc->misalignment;
1525 #endif
1526
1527   if( count > 0 )
1528   {
1529     // round up to the nearest 4
1530     aligned = (oc->fileSize + 3) & ~3;
1531
1532 #ifdef USE_MMAP
1533     #ifndef linux_HOST_OS /* mremap is a linux extension */
1534         #error ocAllocateSymbolExtras doesnt want USE_MMAP to be defined
1535     #endif
1536
1537     pagesize = getpagesize();
1538     n = ROUND_UP( oc->fileSize, pagesize );
1539     m = ROUND_UP( aligned + sizeof (SymbolExtra) * count, pagesize );
1540
1541     /* If we have a half-page-size file and map one page of it then
1542      * the part of the page after the size of the file remains accessible.
1543      * If, however, we map in 2 pages, the 2nd page is not accessible
1544      * and will give a "Bus Error" on access.  To get around this, we check
1545      * if we need any extra pages for the jump islands and map them in
1546      * anonymously.  We must check that we actually require extra pages
1547      * otherwise the attempt to mmap 0 pages of anonymous memory will
1548      * fail -EINVAL.
1549      */
1550
1551     if( m > n )
1552     {
1553       /* The effect of this mremap() call is only the ensure that we have
1554        * a sufficient number of virtually contiguous pages.  As returned from
1555        * mremap, the pages past the end of the file are not backed.  We give
1556        * them a backing by using MAP_FIXED to map in anonymous pages.
1557        */
1558       oc->image = mremap( oc->image, n, m, MREMAP_MAYMOVE );
1559
1560       if( oc->image == MAP_FAILED )
1561       {
1562         errorBelch( "Unable to mremap for Jump Islands\n" );
1563         return 0;
1564       }
1565
1566       if( mmap( oc->image + n, m - n, PROT_READ | PROT_WRITE | PROT_EXEC,
1567                 MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED, 0, 0 ) == MAP_FAILED )
1568       {
1569         errorBelch( "Unable to mmap( MAP_FIXED ) for Jump Islands\n" );
1570         return 0;
1571       }
1572     }
1573
1574 #else
1575     oc->image -= misalignment;
1576     oc->image = stgReallocBytes( oc->image,
1577                                  misalignment +
1578                                  aligned + sizeof (SymbolExtra) * count,
1579                                  "ocAllocateSymbolExtras" );
1580     oc->image += misalignment;
1581 #endif /* USE_MMAP */
1582
1583     oc->symbol_extras = (SymbolExtra *) (oc->image + aligned);
1584     memset( oc->symbol_extras, 0, sizeof (SymbolExtra) * count );
1585   }
1586   else
1587     oc->symbol_extras = NULL;
1588
1589   oc->first_symbol_extra = first;
1590   oc->n_symbol_extras = count;
1591
1592   return 1;
1593 }
1594
1595 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
1596                                      unsigned long symbolNumber,
1597                                      unsigned long target )
1598 {
1599   SymbolExtra *extra;
1600
1601   ASSERT( symbolNumber >= oc->first_symbol_extra
1602         && symbolNumber - oc->first_symbol_extra < oc->n_symbol_extras);
1603
1604   extra = &oc->symbol_extras[symbolNumber - oc->first_symbol_extra];
1605
1606 #ifdef powerpc_HOST_ARCH
1607   // lis r12, hi16(target)
1608   extra->jumpIsland.lis_r12     = 0x3d80;
1609   extra->jumpIsland.hi_addr     = target >> 16;
1610
1611   // ori r12, r12, lo16(target)
1612   extra->jumpIsland.ori_r12_r12 = 0x618c;
1613   extra->jumpIsland.lo_addr     = target & 0xffff;
1614
1615   // mtctr r12
1616   extra->jumpIsland.mtctr_r12   = 0x7d8903a6;
1617
1618   // bctr
1619   extra->jumpIsland.bctr        = 0x4e800420;
1620 #endif
1621 #ifdef x86_64_HOST_ARCH
1622         // jmp *-14(%rip)
1623   static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
1624   extra->addr = target;
1625   memcpy(extra->jumpIsland, jmp, 6);
1626 #endif
1627
1628   return extra;
1629 }
1630
1631 #endif
1632
1633 /* --------------------------------------------------------------------------
1634  * PowerPC specifics (instruction cache flushing)
1635  * ------------------------------------------------------------------------*/
1636
1637 #ifdef powerpc_TARGET_ARCH
1638 /*
1639    ocFlushInstructionCache
1640
1641    Flush the data & instruction caches.
1642    Because the PPC has split data/instruction caches, we have to
1643    do that whenever we modify code at runtime.
1644  */
1645
1646 static void ocFlushInstructionCache( ObjectCode *oc )
1647 {
1648     int n = (oc->fileSize + sizeof( SymbolExtra ) * oc->n_symbol_extras + 3) / 4;
1649     unsigned long *p = (unsigned long *) oc->image;
1650
1651     while( n-- )
1652     {
1653         __asm__ volatile ( "dcbf 0,%0\n\t"
1654                            "sync\n\t"
1655                            "icbi 0,%0"
1656                            :
1657                            : "r" (p)
1658                          );
1659         p++;
1660     }
1661     __asm__ volatile ( "sync\n\t"
1662                        "isync"
1663                      );
1664 }
1665 #endif
1666
1667 /* --------------------------------------------------------------------------
1668  * PEi386 specifics (Win32 targets)
1669  * ------------------------------------------------------------------------*/
1670
1671 /* The information for this linker comes from
1672       Microsoft Portable Executable
1673       and Common Object File Format Specification
1674       revision 5.1 January 1998
1675    which SimonM says comes from the MS Developer Network CDs.
1676
1677    It can be found there (on older CDs), but can also be found
1678    online at:
1679
1680       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
1681
1682    (this is Rev 6.0 from February 1999).
1683
1684    Things move, so if that fails, try searching for it via
1685
1686       http://www.google.com/search?q=PE+COFF+specification
1687
1688    The ultimate reference for the PE format is the Winnt.h
1689    header file that comes with the Platform SDKs; as always,
1690    implementations will drift wrt their documentation.
1691
1692    A good background article on the PE format is Matt Pietrek's
1693    March 1994 article in Microsoft System Journal (MSJ)
1694    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
1695    Win32 Portable Executable File Format." The info in there
1696    has recently been updated in a two part article in
1697    MSDN magazine, issues Feb and March 2002,
1698    "Inside Windows: An In-Depth Look into the Win32 Portable
1699    Executable File Format"
1700
1701    John Levine's book "Linkers and Loaders" contains useful
1702    info on PE too.
1703 */
1704
1705
1706 #if defined(OBJFORMAT_PEi386)
1707
1708
1709
1710 typedef unsigned char  UChar;
1711 typedef unsigned short UInt16;
1712 typedef unsigned int   UInt32;
1713 typedef          int   Int32;
1714
1715
1716 typedef
1717    struct {
1718       UInt16 Machine;
1719       UInt16 NumberOfSections;
1720       UInt32 TimeDateStamp;
1721       UInt32 PointerToSymbolTable;
1722       UInt32 NumberOfSymbols;
1723       UInt16 SizeOfOptionalHeader;
1724       UInt16 Characteristics;
1725    }
1726    COFF_header;
1727
1728 #define sizeof_COFF_header 20
1729
1730
1731 typedef
1732    struct {
1733       UChar  Name[8];
1734       UInt32 VirtualSize;
1735       UInt32 VirtualAddress;
1736       UInt32 SizeOfRawData;
1737       UInt32 PointerToRawData;
1738       UInt32 PointerToRelocations;
1739       UInt32 PointerToLinenumbers;
1740       UInt16 NumberOfRelocations;
1741       UInt16 NumberOfLineNumbers;
1742       UInt32 Characteristics;
1743    }
1744    COFF_section;
1745
1746 #define sizeof_COFF_section 40
1747
1748
1749 typedef
1750    struct {
1751       UChar  Name[8];
1752       UInt32 Value;
1753       UInt16 SectionNumber;
1754       UInt16 Type;
1755       UChar  StorageClass;
1756       UChar  NumberOfAuxSymbols;
1757    }
1758    COFF_symbol;
1759
1760 #define sizeof_COFF_symbol 18
1761
1762
1763 typedef
1764    struct {
1765       UInt32 VirtualAddress;
1766       UInt32 SymbolTableIndex;
1767       UInt16 Type;
1768    }
1769    COFF_reloc;
1770
1771 #define sizeof_COFF_reloc 10
1772
1773
1774 /* From PE spec doc, section 3.3.2 */
1775 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
1776    windows.h -- for the same purpose, but I want to know what I'm
1777    getting, here. */
1778 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
1779 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
1780 #define MYIMAGE_FILE_DLL                 0x2000
1781 #define MYIMAGE_FILE_SYSTEM              0x1000
1782 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
1783 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
1784 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
1785
1786 /* From PE spec doc, section 5.4.2 and 5.4.4 */
1787 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
1788 #define MYIMAGE_SYM_CLASS_STATIC         3
1789 #define MYIMAGE_SYM_UNDEFINED            0
1790
1791 /* From PE spec doc, section 4.1 */
1792 #define MYIMAGE_SCN_CNT_CODE             0x00000020
1793 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
1794 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
1795
1796 /* From PE spec doc, section 5.2.1 */
1797 #define MYIMAGE_REL_I386_DIR32           0x0006
1798 #define MYIMAGE_REL_I386_REL32           0x0014
1799
1800
1801 /* We use myindex to calculate array addresses, rather than
1802    simply doing the normal subscript thing.  That's because
1803    some of the above structs have sizes which are not
1804    a whole number of words.  GCC rounds their sizes up to a
1805    whole number of words, which means that the address calcs
1806    arising from using normal C indexing or pointer arithmetic
1807    are just plain wrong.  Sigh.
1808 */
1809 static UChar *
1810 myindex ( int scale, void* base, int index )
1811 {
1812    return
1813       ((UChar*)base) + scale * index;
1814 }
1815
1816
1817 static void
1818 printName ( UChar* name, UChar* strtab )
1819 {
1820    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1821       UInt32 strtab_offset = * (UInt32*)(name+4);
1822       debugBelch("%s", strtab + strtab_offset );
1823    } else {
1824       int i;
1825       for (i = 0; i < 8; i++) {
1826          if (name[i] == 0) break;
1827          debugBelch("%c", name[i] );
1828       }
1829    }
1830 }
1831
1832
1833 static void
1834 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1835 {
1836    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1837       UInt32 strtab_offset = * (UInt32*)(name+4);
1838       strncpy ( dst, strtab+strtab_offset, dstSize );
1839       dst[dstSize-1] = 0;
1840    } else {
1841       int i = 0;
1842       while (1) {
1843          if (i >= 8) break;
1844          if (name[i] == 0) break;
1845          dst[i] = name[i];
1846          i++;
1847       }
1848       dst[i] = 0;
1849    }
1850 }
1851
1852
1853 static UChar *
1854 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
1855 {
1856    UChar* newstr;
1857    /* If the string is longer than 8 bytes, look in the
1858       string table for it -- this will be correctly zero terminated.
1859    */
1860    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1861       UInt32 strtab_offset = * (UInt32*)(name+4);
1862       return ((UChar*)strtab) + strtab_offset;
1863    }
1864    /* Otherwise, if shorter than 8 bytes, return the original,
1865       which by defn is correctly terminated.
1866    */
1867    if (name[7]==0) return name;
1868    /* The annoying case: 8 bytes.  Copy into a temporary
1869       (which is never freed ...)
1870    */
1871    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
1872    ASSERT(newstr);
1873    strncpy(newstr,name,8);
1874    newstr[8] = 0;
1875    return newstr;
1876 }
1877
1878
1879 /* Just compares the short names (first 8 chars) */
1880 static COFF_section *
1881 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
1882 {
1883    int i;
1884    COFF_header* hdr
1885       = (COFF_header*)(oc->image);
1886    COFF_section* sectab
1887       = (COFF_section*) (
1888            ((UChar*)(oc->image))
1889            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1890         );
1891    for (i = 0; i < hdr->NumberOfSections; i++) {
1892       UChar* n1;
1893       UChar* n2;
1894       COFF_section* section_i
1895          = (COFF_section*)
1896            myindex ( sizeof_COFF_section, sectab, i );
1897       n1 = (UChar*) &(section_i->Name);
1898       n2 = name;
1899       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
1900           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
1901           n1[6]==n2[6] && n1[7]==n2[7])
1902          return section_i;
1903    }
1904
1905    return NULL;
1906 }
1907
1908
1909 static void
1910 zapTrailingAtSign ( UChar* sym )
1911 {
1912 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
1913    int i, j;
1914    if (sym[0] == 0) return;
1915    i = 0;
1916    while (sym[i] != 0) i++;
1917    i--;
1918    j = i;
1919    while (j > 0 && my_isdigit(sym[j])) j--;
1920    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
1921 #  undef my_isdigit
1922 }
1923
1924
1925 static int
1926 ocVerifyImage_PEi386 ( ObjectCode* oc )
1927 {
1928    int i;
1929    UInt32 j, noRelocs;
1930    COFF_header*  hdr;
1931    COFF_section* sectab;
1932    COFF_symbol*  symtab;
1933    UChar*        strtab;
1934    /* debugBelch("\nLOADING %s\n", oc->fileName); */
1935    hdr = (COFF_header*)(oc->image);
1936    sectab = (COFF_section*) (
1937                ((UChar*)(oc->image))
1938                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1939             );
1940    symtab = (COFF_symbol*) (
1941                ((UChar*)(oc->image))
1942                + hdr->PointerToSymbolTable
1943             );
1944    strtab = ((UChar*)symtab)
1945             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1946
1947    if (hdr->Machine != 0x14c) {
1948       errorBelch("%s: Not x86 PEi386", oc->fileName);
1949       return 0;
1950    }
1951    if (hdr->SizeOfOptionalHeader != 0) {
1952       errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
1953       return 0;
1954    }
1955    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
1956         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
1957         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
1958         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
1959       errorBelch("%s: Not a PEi386 object file", oc->fileName);
1960       return 0;
1961    }
1962    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
1963         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
1964       errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
1965                  oc->fileName,
1966                  (int)(hdr->Characteristics));
1967       return 0;
1968    }
1969    /* If the string table size is way crazy, this might indicate that
1970       there are more than 64k relocations, despite claims to the
1971       contrary.  Hence this test. */
1972    /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
1973 #if 0
1974    if ( (*(UInt32*)strtab) > 600000 ) {
1975       /* Note that 600k has no special significance other than being
1976          big enough to handle the almost-2MB-sized lumps that
1977          constitute HSwin32*.o. */
1978       debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
1979       return 0;
1980    }
1981 #endif
1982
1983    /* No further verification after this point; only debug printing. */
1984    i = 0;
1985    IF_DEBUG(linker, i=1);
1986    if (i == 0) return 1;
1987
1988    debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
1989    debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
1990    debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
1991
1992    debugBelch("\n" );
1993    debugBelch( "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
1994    debugBelch( "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
1995    debugBelch( "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
1996    debugBelch( "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
1997    debugBelch( "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
1998    debugBelch( "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
1999    debugBelch( "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
2000
2001    /* Print the section table. */
2002    debugBelch("\n" );
2003    for (i = 0; i < hdr->NumberOfSections; i++) {
2004       COFF_reloc* reltab;
2005       COFF_section* sectab_i
2006          = (COFF_section*)
2007            myindex ( sizeof_COFF_section, sectab, i );
2008       debugBelch(
2009                 "\n"
2010                 "section %d\n"
2011                 "     name `",
2012                 i
2013               );
2014       printName ( sectab_i->Name, strtab );
2015       debugBelch(
2016                 "'\n"
2017                 "    vsize %d\n"
2018                 "    vaddr %d\n"
2019                 "  data sz %d\n"
2020                 " data off %d\n"
2021                 "  num rel %d\n"
2022                 "  off rel %d\n"
2023                 "  ptr raw 0x%x\n",
2024                 sectab_i->VirtualSize,
2025                 sectab_i->VirtualAddress,
2026                 sectab_i->SizeOfRawData,
2027                 sectab_i->PointerToRawData,
2028                 sectab_i->NumberOfRelocations,
2029                 sectab_i->PointerToRelocations,
2030                 sectab_i->PointerToRawData
2031               );
2032       reltab = (COFF_reloc*) (
2033                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2034                );
2035
2036       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2037         /* If the relocation field (a short) has overflowed, the
2038          * real count can be found in the first reloc entry.
2039          *
2040          * See Section 4.1 (last para) of the PE spec (rev6.0).
2041          */
2042         COFF_reloc* rel = (COFF_reloc*)
2043                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2044         noRelocs = rel->VirtualAddress;
2045         j = 1;
2046       } else {
2047         noRelocs = sectab_i->NumberOfRelocations;
2048         j = 0;
2049       }
2050
2051       for (; j < noRelocs; j++) {
2052          COFF_symbol* sym;
2053          COFF_reloc* rel = (COFF_reloc*)
2054                            myindex ( sizeof_COFF_reloc, reltab, j );
2055          debugBelch(
2056                    "        type 0x%-4x   vaddr 0x%-8x   name `",
2057                    (UInt32)rel->Type,
2058                    rel->VirtualAddress );
2059          sym = (COFF_symbol*)
2060                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
2061          /* Hmm..mysterious looking offset - what's it for? SOF */
2062          printName ( sym->Name, strtab -10 );
2063          debugBelch("'\n" );
2064       }
2065
2066       debugBelch("\n" );
2067    }
2068    debugBelch("\n" );
2069    debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
2070    debugBelch("---START of string table---\n");
2071    for (i = 4; i < *(Int32*)strtab; i++) {
2072       if (strtab[i] == 0)
2073          debugBelch("\n"); else
2074          debugBelch("%c", strtab[i] );
2075    }
2076    debugBelch("--- END  of string table---\n");
2077
2078    debugBelch("\n" );
2079    i = 0;
2080    while (1) {
2081       COFF_symbol* symtab_i;
2082       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2083       symtab_i = (COFF_symbol*)
2084                  myindex ( sizeof_COFF_symbol, symtab, i );
2085       debugBelch(
2086                 "symbol %d\n"
2087                 "     name `",
2088                 i
2089               );
2090       printName ( symtab_i->Name, strtab );
2091       debugBelch(
2092                 "'\n"
2093                 "    value 0x%x\n"
2094                 "   1+sec# %d\n"
2095                 "     type 0x%x\n"
2096                 "   sclass 0x%x\n"
2097                 "     nAux %d\n",
2098                 symtab_i->Value,
2099                 (Int32)(symtab_i->SectionNumber),
2100                 (UInt32)symtab_i->Type,
2101                 (UInt32)symtab_i->StorageClass,
2102                 (UInt32)symtab_i->NumberOfAuxSymbols
2103               );
2104       i += symtab_i->NumberOfAuxSymbols;
2105       i++;
2106    }
2107
2108    debugBelch("\n" );
2109    return 1;
2110 }
2111
2112
2113 static int
2114 ocGetNames_PEi386 ( ObjectCode* oc )
2115 {
2116    COFF_header*  hdr;
2117    COFF_section* sectab;
2118    COFF_symbol*  symtab;
2119    UChar*        strtab;
2120
2121    UChar* sname;
2122    void*  addr;
2123    int    i;
2124
2125    hdr = (COFF_header*)(oc->image);
2126    sectab = (COFF_section*) (
2127                ((UChar*)(oc->image))
2128                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2129             );
2130    symtab = (COFF_symbol*) (
2131                ((UChar*)(oc->image))
2132                + hdr->PointerToSymbolTable
2133             );
2134    strtab = ((UChar*)(oc->image))
2135             + hdr->PointerToSymbolTable
2136             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2137
2138    /* Allocate space for any (local, anonymous) .bss sections. */
2139
2140    for (i = 0; i < hdr->NumberOfSections; i++) {
2141       UInt32 bss_sz;
2142       UChar* zspace;
2143       COFF_section* sectab_i
2144          = (COFF_section*)
2145            myindex ( sizeof_COFF_section, sectab, i );
2146       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
2147       /* sof 10/05: the PE spec text isn't too clear regarding what
2148        * the SizeOfRawData field is supposed to hold for object
2149        * file sections containing just uninitialized data -- for executables,
2150        * it is supposed to be zero; unclear what it's supposed to be
2151        * for object files. However, VirtualSize is guaranteed to be
2152        * zero for object files, which definitely suggests that SizeOfRawData
2153        * will be non-zero (where else would the size of this .bss section be
2154        * stored?) Looking at the COFF_section info for incoming object files,
2155        * this certainly appears to be the case.
2156        *
2157        * => I suspect we've been incorrectly handling .bss sections in (relocatable)
2158        * object files up until now. This turned out to bite us with ghc-6.4.1's use
2159        * of gcc-3.4.x, which has started to emit initially-zeroed-out local 'static'
2160        * variable decls into to the .bss section. (The specific function in Q which
2161        * triggered this is libraries/base/cbits/dirUtils.c:__hscore_getFolderPath())
2162        */
2163       if (sectab_i->VirtualSize == 0 && sectab_i->SizeOfRawData == 0) continue;
2164       /* This is a non-empty .bss section.  Allocate zeroed space for
2165          it, and set its PointerToRawData field such that oc->image +
2166          PointerToRawData == addr_of_zeroed_space.  */
2167       bss_sz = sectab_i->VirtualSize;
2168       if ( bss_sz < sectab_i->SizeOfRawData) { bss_sz = sectab_i->SizeOfRawData; }
2169       zspace = stgCallocBytes(1, bss_sz, "ocGetNames_PEi386(anonymous bss)");
2170       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
2171       addProddableBlock(oc, zspace, bss_sz);
2172       /* debugBelch("BSS anon section at 0x%x\n", zspace); */
2173    }
2174
2175    /* Copy section information into the ObjectCode. */
2176
2177    for (i = 0; i < hdr->NumberOfSections; i++) {
2178       UChar* start;
2179       UChar* end;
2180       UInt32 sz;
2181
2182       SectionKind kind
2183          = SECTIONKIND_OTHER;
2184       COFF_section* sectab_i
2185          = (COFF_section*)
2186            myindex ( sizeof_COFF_section, sectab, i );
2187       IF_DEBUG(linker, debugBelch("section name = %s\n", sectab_i->Name ));
2188
2189 #     if 0
2190       /* I'm sure this is the Right Way to do it.  However, the
2191          alternative of testing the sectab_i->Name field seems to
2192          work ok with Cygwin.
2193       */
2194       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
2195           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
2196          kind = SECTIONKIND_CODE_OR_RODATA;
2197 #     endif
2198
2199       if (0==strcmp(".text",sectab_i->Name) ||
2200           0==strcmp(".rdata",sectab_i->Name)||
2201           0==strcmp(".rodata",sectab_i->Name))
2202          kind = SECTIONKIND_CODE_OR_RODATA;
2203       if (0==strcmp(".data",sectab_i->Name) ||
2204           0==strcmp(".bss",sectab_i->Name))
2205          kind = SECTIONKIND_RWDATA;
2206
2207       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
2208       sz = sectab_i->SizeOfRawData;
2209       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
2210
2211       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
2212       end   = start + sz - 1;
2213
2214       if (kind == SECTIONKIND_OTHER
2215           /* Ignore sections called which contain stabs debugging
2216              information. */
2217           && 0 != strcmp(".stab", sectab_i->Name)
2218           && 0 != strcmp(".stabstr", sectab_i->Name)
2219           /* ignore constructor section for now */
2220           && 0 != strcmp(".ctors", sectab_i->Name)
2221           /* ignore section generated from .ident */
2222           && 0!= strcmp("/4", sectab_i->Name)
2223          ) {
2224          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", sectab_i->Name, oc->fileName);
2225          return 0;
2226       }
2227
2228       if (kind != SECTIONKIND_OTHER && end >= start) {
2229          addSection(oc, kind, start, end);
2230          addProddableBlock(oc, start, end - start + 1);
2231       }
2232    }
2233
2234    /* Copy exported symbols into the ObjectCode. */
2235
2236    oc->n_symbols = hdr->NumberOfSymbols;
2237    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
2238                                   "ocGetNames_PEi386(oc->symbols)");
2239    /* Call me paranoid; I don't care. */
2240    for (i = 0; i < oc->n_symbols; i++)
2241       oc->symbols[i] = NULL;
2242
2243    i = 0;
2244    while (1) {
2245       COFF_symbol* symtab_i;
2246       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2247       symtab_i = (COFF_symbol*)
2248                  myindex ( sizeof_COFF_symbol, symtab, i );
2249
2250       addr  = NULL;
2251
2252       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
2253           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
2254          /* This symbol is global and defined, viz, exported */
2255          /* for MYIMAGE_SYMCLASS_EXTERNAL
2256                 && !MYIMAGE_SYM_UNDEFINED,
2257             the address of the symbol is:
2258                 address of relevant section + offset in section
2259          */
2260          COFF_section* sectabent
2261             = (COFF_section*) myindex ( sizeof_COFF_section,
2262                                         sectab,
2263                                         symtab_i->SectionNumber-1 );
2264          addr = ((UChar*)(oc->image))
2265                 + (sectabent->PointerToRawData
2266                    + symtab_i->Value);
2267       }
2268       else
2269       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
2270           && symtab_i->Value > 0) {
2271          /* This symbol isn't in any section at all, ie, global bss.
2272             Allocate zeroed space for it. */
2273          addr = stgCallocBytes(1, symtab_i->Value,
2274                                "ocGetNames_PEi386(non-anonymous bss)");
2275          addSection(oc, SECTIONKIND_RWDATA, addr,
2276                         ((UChar*)addr) + symtab_i->Value - 1);
2277          addProddableBlock(oc, addr, symtab_i->Value);
2278          /* debugBelch("BSS      section at 0x%x\n", addr); */
2279       }
2280
2281       if (addr != NULL ) {
2282          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
2283          /* debugBelch("addSymbol %p `%s \n", addr,sname);  */
2284          IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
2285          ASSERT(i >= 0 && i < oc->n_symbols);
2286          /* cstring_from_COFF_symbol_name always succeeds. */
2287          oc->symbols[i] = sname;
2288          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
2289       } else {
2290 #        if 0
2291          debugBelch(
2292                    "IGNORING symbol %d\n"
2293                    "     name `",
2294                    i
2295                  );
2296          printName ( symtab_i->Name, strtab );
2297          debugBelch(
2298                    "'\n"
2299                    "    value 0x%x\n"
2300                    "   1+sec# %d\n"
2301                    "     type 0x%x\n"
2302                    "   sclass 0x%x\n"
2303                    "     nAux %d\n",
2304                    symtab_i->Value,
2305                    (Int32)(symtab_i->SectionNumber),
2306                    (UInt32)symtab_i->Type,
2307                    (UInt32)symtab_i->StorageClass,
2308                    (UInt32)symtab_i->NumberOfAuxSymbols
2309                  );
2310 #        endif
2311       }
2312
2313       i += symtab_i->NumberOfAuxSymbols;
2314       i++;
2315    }
2316
2317    return 1;
2318 }
2319
2320
2321 static int
2322 ocResolve_PEi386 ( ObjectCode* oc )
2323 {
2324    COFF_header*  hdr;
2325    COFF_section* sectab;
2326    COFF_symbol*  symtab;
2327    UChar*        strtab;
2328
2329    UInt32        A;
2330    UInt32        S;
2331    UInt32*       pP;
2332
2333    int i;
2334    UInt32 j, noRelocs;
2335
2336    /* ToDo: should be variable-sized?  But is at least safe in the
2337       sense of buffer-overrun-proof. */
2338    char symbol[1000];
2339    /* debugBelch("resolving for %s\n", oc->fileName); */
2340
2341    hdr = (COFF_header*)(oc->image);
2342    sectab = (COFF_section*) (
2343                ((UChar*)(oc->image))
2344                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2345             );
2346    symtab = (COFF_symbol*) (
2347                ((UChar*)(oc->image))
2348                + hdr->PointerToSymbolTable
2349             );
2350    strtab = ((UChar*)(oc->image))
2351             + hdr->PointerToSymbolTable
2352             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2353
2354    for (i = 0; i < hdr->NumberOfSections; i++) {
2355       COFF_section* sectab_i
2356          = (COFF_section*)
2357            myindex ( sizeof_COFF_section, sectab, i );
2358       COFF_reloc* reltab
2359          = (COFF_reloc*) (
2360               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2361            );
2362
2363       /* Ignore sections called which contain stabs debugging
2364          information. */
2365       if (0 == strcmp(".stab", sectab_i->Name)
2366           || 0 == strcmp(".stabstr", sectab_i->Name)
2367           || 0 == strcmp(".ctors", sectab_i->Name))
2368          continue;
2369
2370       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2371         /* If the relocation field (a short) has overflowed, the
2372          * real count can be found in the first reloc entry.
2373          *
2374          * See Section 4.1 (last para) of the PE spec (rev6.0).
2375          *
2376          * Nov2003 update: the GNU linker still doesn't correctly
2377          * handle the generation of relocatable object files with
2378          * overflown relocations. Hence the output to warn of potential
2379          * troubles.
2380          */
2381         COFF_reloc* rel = (COFF_reloc*)
2382                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2383         noRelocs = rel->VirtualAddress;
2384
2385         /* 10/05: we now assume (and check for) a GNU ld that is capable
2386          * of handling object files with (>2^16) of relocs.
2387          */
2388 #if 0
2389         debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
2390                    noRelocs);
2391 #endif
2392         j = 1;
2393       } else {
2394         noRelocs = sectab_i->NumberOfRelocations;
2395         j = 0;
2396       }
2397
2398
2399       for (; j < noRelocs; j++) {
2400          COFF_symbol* sym;
2401          COFF_reloc* reltab_j
2402             = (COFF_reloc*)
2403               myindex ( sizeof_COFF_reloc, reltab, j );
2404
2405          /* the location to patch */
2406          pP = (UInt32*)(
2407                  ((UChar*)(oc->image))
2408                  + (sectab_i->PointerToRawData
2409                     + reltab_j->VirtualAddress
2410                     - sectab_i->VirtualAddress )
2411               );
2412          /* the existing contents of pP */
2413          A = *pP;
2414          /* the symbol to connect to */
2415          sym = (COFF_symbol*)
2416                myindex ( sizeof_COFF_symbol,
2417                          symtab, reltab_j->SymbolTableIndex );
2418          IF_DEBUG(linker,
2419                   debugBelch(
2420                             "reloc sec %2d num %3d:  type 0x%-4x   "
2421                             "vaddr 0x%-8x   name `",
2422                             i, j,
2423                             (UInt32)reltab_j->Type,
2424                             reltab_j->VirtualAddress );
2425                             printName ( sym->Name, strtab );
2426                             debugBelch("'\n" ));
2427
2428          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
2429             COFF_section* section_sym
2430                = findPEi386SectionCalled ( oc, sym->Name );
2431             if (!section_sym) {
2432                errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
2433                return 0;
2434             }
2435             S = ((UInt32)(oc->image))
2436                 + (section_sym->PointerToRawData
2437                    + sym->Value);
2438          } else {
2439             copyName ( sym->Name, strtab, symbol, 1000-1 );
2440             S = (UInt32) lookupLocalSymbol( oc, symbol );
2441             if ((void*)S != NULL) goto foundit;
2442             S = (UInt32) lookupSymbol( symbol );
2443             if ((void*)S != NULL) goto foundit;
2444             zapTrailingAtSign ( symbol );
2445             S = (UInt32) lookupLocalSymbol( oc, symbol );
2446             if ((void*)S != NULL) goto foundit;
2447             S = (UInt32) lookupSymbol( symbol );
2448             if ((void*)S != NULL) goto foundit;
2449             /* Newline first because the interactive linker has printed "linking..." */
2450             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
2451             return 0;
2452            foundit:;
2453          }
2454          checkProddableBlock(oc, pP);
2455          switch (reltab_j->Type) {
2456             case MYIMAGE_REL_I386_DIR32:
2457                *pP = A + S;
2458                break;
2459             case MYIMAGE_REL_I386_REL32:
2460                /* Tricky.  We have to insert a displacement at
2461                   pP which, when added to the PC for the _next_
2462                   insn, gives the address of the target (S).
2463                   Problem is to know the address of the next insn
2464                   when we only know pP.  We assume that this
2465                   literal field is always the last in the insn,
2466                   so that the address of the next insn is pP+4
2467                   -- hence the constant 4.
2468                   Also I don't know if A should be added, but so
2469                   far it has always been zero.
2470
2471                   SOF 05/2005: 'A' (old contents of *pP) have been observed
2472                   to contain values other than zero (the 'wx' object file
2473                   that came with wxhaskell-0.9.4; dunno how it was compiled..).
2474                   So, add displacement to old value instead of asserting
2475                   A to be zero. Fixes wxhaskell-related crashes, and no other
2476                   ill effects have been observed.
2477
2478                   Update: the reason why we're seeing these more elaborate
2479                   relocations is due to a switch in how the NCG compiles SRTs
2480                   and offsets to them from info tables. SRTs live in .(ro)data,
2481                   while info tables live in .text, causing GAS to emit REL32/DISP32
2482                   relocations with non-zero values. Adding the displacement is
2483                   the right thing to do.
2484                */
2485                *pP = S - ((UInt32)pP) - 4 + A;
2486                break;
2487             default:
2488                debugBelch("%s: unhandled PEi386 relocation type %d",
2489                      oc->fileName, reltab_j->Type);
2490                return 0;
2491          }
2492
2493       }
2494    }
2495
2496    IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
2497    return 1;
2498 }
2499
2500 #endif /* defined(OBJFORMAT_PEi386) */
2501
2502
2503 /* --------------------------------------------------------------------------
2504  * ELF specifics
2505  * ------------------------------------------------------------------------*/
2506
2507 #if defined(OBJFORMAT_ELF)
2508
2509 #define FALSE 0
2510 #define TRUE  1
2511
2512 #if defined(sparc_HOST_ARCH)
2513 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
2514 #elif defined(i386_HOST_ARCH)
2515 #  define ELF_TARGET_386    /* Used inside <elf.h> */
2516 #elif defined(x86_64_HOST_ARCH)
2517 #  define ELF_TARGET_X64_64
2518 #  define ELF_64BIT
2519 #elif defined (ia64_HOST_ARCH)
2520 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
2521 #  define ELF_64BIT
2522 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
2523 #  define ELF_NEED_GOT      /* needs Global Offset Table */
2524 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
2525 #endif
2526
2527 #if !defined(openbsd_HOST_OS)
2528 #include <elf.h>
2529 #else
2530 /* openbsd elf has things in different places, with diff names */
2531 #include <elf_abi.h>
2532 #include <machine/reloc.h>
2533 #define R_386_32    RELOC_32
2534 #define R_386_PC32  RELOC_PC32
2535 #endif
2536
2537 /*
2538  * Define a set of types which can be used for both ELF32 and ELF64
2539  */
2540
2541 #ifdef ELF_64BIT
2542 #define ELFCLASS    ELFCLASS64
2543 #define Elf_Addr    Elf64_Addr
2544 #define Elf_Word    Elf64_Word
2545 #define Elf_Sword   Elf64_Sword
2546 #define Elf_Ehdr    Elf64_Ehdr
2547 #define Elf_Phdr    Elf64_Phdr
2548 #define Elf_Shdr    Elf64_Shdr
2549 #define Elf_Sym     Elf64_Sym
2550 #define Elf_Rel     Elf64_Rel
2551 #define Elf_Rela    Elf64_Rela
2552 #define ELF_ST_TYPE ELF64_ST_TYPE
2553 #define ELF_ST_BIND ELF64_ST_BIND
2554 #define ELF_R_TYPE  ELF64_R_TYPE
2555 #define ELF_R_SYM   ELF64_R_SYM
2556 #else
2557 #define ELFCLASS    ELFCLASS32
2558 #define Elf_Addr    Elf32_Addr
2559 #define Elf_Word    Elf32_Word
2560 #define Elf_Sword   Elf32_Sword
2561 #define Elf_Ehdr    Elf32_Ehdr
2562 #define Elf_Phdr    Elf32_Phdr
2563 #define Elf_Shdr    Elf32_Shdr
2564 #define Elf_Sym     Elf32_Sym
2565 #define Elf_Rel     Elf32_Rel
2566 #define Elf_Rela    Elf32_Rela
2567 #ifndef ELF_ST_TYPE
2568 #define ELF_ST_TYPE ELF32_ST_TYPE
2569 #endif
2570 #ifndef ELF_ST_BIND
2571 #define ELF_ST_BIND ELF32_ST_BIND
2572 #endif
2573 #ifndef ELF_R_TYPE
2574 #define ELF_R_TYPE  ELF32_R_TYPE
2575 #endif
2576 #ifndef ELF_R_SYM
2577 #define ELF_R_SYM   ELF32_R_SYM
2578 #endif
2579 #endif
2580
2581
2582 /*
2583  * Functions to allocate entries in dynamic sections.  Currently we simply
2584  * preallocate a large number, and we don't check if a entry for the given
2585  * target already exists (a linear search is too slow).  Ideally these
2586  * entries would be associated with symbols.
2587  */
2588
2589 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
2590 #define GOT_SIZE            0x20000
2591 #define FUNCTION_TABLE_SIZE 0x10000
2592 #define PLT_SIZE            0x08000
2593
2594 #ifdef ELF_NEED_GOT
2595 static Elf_Addr got[GOT_SIZE];
2596 static unsigned int gotIndex;
2597 static Elf_Addr gp_val = (Elf_Addr)got;
2598
2599 static Elf_Addr
2600 allocateGOTEntry(Elf_Addr target)
2601 {
2602    Elf_Addr *entry;
2603
2604    if (gotIndex >= GOT_SIZE)
2605       barf("Global offset table overflow");
2606
2607    entry = &got[gotIndex++];
2608    *entry = target;
2609    return (Elf_Addr)entry;
2610 }
2611 #endif
2612
2613 #ifdef ELF_FUNCTION_DESC
2614 typedef struct {
2615    Elf_Addr ip;
2616    Elf_Addr gp;
2617 } FunctionDesc;
2618
2619 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2620 static unsigned int functionTableIndex;
2621
2622 static Elf_Addr
2623 allocateFunctionDesc(Elf_Addr target)
2624 {
2625    FunctionDesc *entry;
2626
2627    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2628       barf("Function table overflow");
2629
2630    entry = &functionTable[functionTableIndex++];
2631    entry->ip = target;
2632    entry->gp = (Elf_Addr)gp_val;
2633    return (Elf_Addr)entry;
2634 }
2635
2636 static Elf_Addr
2637 copyFunctionDesc(Elf_Addr target)
2638 {
2639    FunctionDesc *olddesc = (FunctionDesc *)target;
2640    FunctionDesc *newdesc;
2641
2642    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2643    newdesc->gp = olddesc->gp;
2644    return (Elf_Addr)newdesc;
2645 }
2646 #endif
2647
2648 #ifdef ELF_NEED_PLT
2649 #ifdef ia64_HOST_ARCH
2650 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2651 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2652
2653 static unsigned char plt_code[] =
2654 {
2655    /* taken from binutils bfd/elfxx-ia64.c */
2656    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2657    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2658    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2659    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2660    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2661    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2662 };
2663
2664 /* If we can't get to the function descriptor via gp, take a local copy of it */
2665 #define PLT_RELOC(code, target) { \
2666    Elf64_Sxword rel_value = target - gp_val; \
2667    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2668       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2669    else \
2670       ia64_reloc_gprel22((Elf_Addr)code, target); \
2671    }
2672 #endif
2673
2674 typedef struct {
2675    unsigned char code[sizeof(plt_code)];
2676 } PLTEntry;
2677
2678 static Elf_Addr
2679 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2680 {
2681    PLTEntry *plt = (PLTEntry *)oc->plt;
2682    PLTEntry *entry;
2683
2684    if (oc->pltIndex >= PLT_SIZE)
2685       barf("Procedure table overflow");
2686
2687    entry = &plt[oc->pltIndex++];
2688    memcpy(entry->code, plt_code, sizeof(entry->code));
2689    PLT_RELOC(entry->code, target);
2690    return (Elf_Addr)entry;
2691 }
2692
2693 static unsigned int
2694 PLTSize(void)
2695 {
2696    return (PLT_SIZE * sizeof(PLTEntry));
2697 }
2698 #endif
2699
2700
2701 #if x86_64_HOST_ARCH
2702 // On x86_64, 32-bit relocations are often used, which requires that
2703 // we can resolve a symbol to a 32-bit offset.  However, shared
2704 // libraries are placed outside the 2Gb area, which leaves us with a
2705 // problem when we need to give a 32-bit offset to a symbol in a
2706 // shared library.
2707 //
2708 // For a function symbol, we can allocate a bounce sequence inside the
2709 // 2Gb area and resolve the symbol to this.  The bounce sequence is
2710 // simply a long jump instruction to the real location of the symbol.
2711 //
2712 // For data references, we're screwed.
2713 //
2714 typedef struct {
2715     unsigned char jmp[8];  /* 6 byte instruction: jmpq *0x00000002(%rip) */
2716     void *addr;
2717 } x86_64_bounce;
2718
2719 #define X86_64_BB_SIZE 1024
2720
2721 static x86_64_bounce *x86_64_bounce_buffer = NULL;
2722 static nat x86_64_bb_next_off;
2723
2724 static void*
2725 x86_64_high_symbol( char *lbl, void *addr )
2726 {
2727     x86_64_bounce *bounce;
2728
2729     if ( x86_64_bounce_buffer == NULL ||
2730          x86_64_bb_next_off >= X86_64_BB_SIZE ) {
2731         x86_64_bounce_buffer =
2732             mmap(NULL, X86_64_BB_SIZE * sizeof(x86_64_bounce),
2733                  PROT_EXEC|PROT_READ|PROT_WRITE,
2734                  MAP_PRIVATE|MAP_32BIT|MAP_ANONYMOUS, -1, 0);
2735         if (x86_64_bounce_buffer == MAP_FAILED) {
2736             barf("x86_64_high_symbol: mmap failed");
2737         }
2738         x86_64_bb_next_off = 0;
2739     }
2740     bounce = &x86_64_bounce_buffer[x86_64_bb_next_off];
2741     bounce->jmp[0] = 0xff;
2742     bounce->jmp[1] = 0x25;
2743     bounce->jmp[2] = 0x02;
2744     bounce->jmp[3] = 0x00;
2745     bounce->jmp[4] = 0x00;
2746     bounce->jmp[5] = 0x00;
2747     bounce->addr = addr;
2748     x86_64_bb_next_off++;
2749
2750     IF_DEBUG(linker, debugBelch("x86_64: allocated bounce entry for %s->%p at %p\n",
2751                                 lbl, addr, bounce));
2752
2753     insertStrHashTable(symhash, lbl, bounce);
2754     return bounce;
2755 }
2756 #endif
2757
2758
2759 /*
2760  * Generic ELF functions
2761  */
2762
2763 static char *
2764 findElfSection ( void* objImage, Elf_Word sh_type )
2765 {
2766    char* ehdrC = (char*)objImage;
2767    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2768    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2769    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2770    char* ptr = NULL;
2771    int i;
2772
2773    for (i = 0; i < ehdr->e_shnum; i++) {
2774       if (shdr[i].sh_type == sh_type
2775           /* Ignore the section header's string table. */
2776           && i != ehdr->e_shstrndx
2777           /* Ignore string tables named .stabstr, as they contain
2778              debugging info. */
2779           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2780          ) {
2781          ptr = ehdrC + shdr[i].sh_offset;
2782          break;
2783       }
2784    }
2785    return ptr;
2786 }
2787
2788 #if defined(ia64_HOST_ARCH)
2789 static Elf_Addr
2790 findElfSegment ( void* objImage, Elf_Addr vaddr )
2791 {
2792    char* ehdrC = (char*)objImage;
2793    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2794    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2795    Elf_Addr segaddr = 0;
2796    int i;
2797
2798    for (i = 0; i < ehdr->e_phnum; i++) {
2799       segaddr = phdr[i].p_vaddr;
2800       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2801               break;
2802    }
2803    return segaddr;
2804 }
2805 #endif
2806
2807 static int
2808 ocVerifyImage_ELF ( ObjectCode* oc )
2809 {
2810    Elf_Shdr* shdr;
2811    Elf_Sym*  stab;
2812    int i, j, nent, nstrtab, nsymtabs;
2813    char* sh_strtab;
2814    char* strtab;
2815
2816    char*     ehdrC = (char*)(oc->image);
2817    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2818
2819    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2820        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2821        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2822        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2823       errorBelch("%s: not an ELF object", oc->fileName);
2824       return 0;
2825    }
2826
2827    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2828       errorBelch("%s: unsupported ELF format", oc->fileName);
2829       return 0;
2830    }
2831
2832    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2833        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
2834    } else
2835    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2836        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
2837    } else {
2838        errorBelch("%s: unknown endiannness", oc->fileName);
2839        return 0;
2840    }
2841
2842    if (ehdr->e_type != ET_REL) {
2843       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
2844       return 0;
2845    }
2846    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
2847
2848    IF_DEBUG(linker,debugBelch( "Architecture is " ));
2849    switch (ehdr->e_machine) {
2850       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
2851 #ifdef EM_SPARC32PLUS
2852       case EM_SPARC32PLUS:
2853 #endif
2854       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
2855 #ifdef EM_IA_64
2856       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
2857 #endif
2858       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
2859 #ifdef EM_X86_64
2860       case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
2861 #endif
2862       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
2863                      errorBelch("%s: unknown architecture", oc->fileName);
2864                      return 0;
2865    }
2866
2867    IF_DEBUG(linker,debugBelch(
2868              "\nSection header table: start %ld, n_entries %d, ent_size %d\n",
2869              (long)ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2870
2871    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2872
2873    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2874
2875    if (ehdr->e_shstrndx == SHN_UNDEF) {
2876       errorBelch("%s: no section header string table", oc->fileName);
2877       return 0;
2878    } else {
2879       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
2880                           ehdr->e_shstrndx));
2881       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2882    }
2883
2884    for (i = 0; i < ehdr->e_shnum; i++) {
2885       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
2886       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
2887       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
2888       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
2889       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
2890                ehdrC + shdr[i].sh_offset,
2891                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
2892
2893       if (shdr[i].sh_type == SHT_REL) {
2894           IF_DEBUG(linker,debugBelch("Rel  " ));
2895       } else if (shdr[i].sh_type == SHT_RELA) {
2896           IF_DEBUG(linker,debugBelch("RelA " ));
2897       } else {
2898           IF_DEBUG(linker,debugBelch("     "));
2899       }
2900       if (sh_strtab) {
2901           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
2902       }
2903    }
2904
2905    IF_DEBUG(linker,debugBelch( "\nString tables" ));
2906    strtab = NULL;
2907    nstrtab = 0;
2908    for (i = 0; i < ehdr->e_shnum; i++) {
2909       if (shdr[i].sh_type == SHT_STRTAB
2910           /* Ignore the section header's string table. */
2911           && i != ehdr->e_shstrndx
2912           /* Ignore string tables named .stabstr, as they contain
2913              debugging info. */
2914           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2915          ) {
2916          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
2917          strtab = ehdrC + shdr[i].sh_offset;
2918          nstrtab++;
2919       }
2920    }
2921    if (nstrtab != 1) {
2922       errorBelch("%s: no string tables, or too many", oc->fileName);
2923       return 0;
2924    }
2925
2926    nsymtabs = 0;
2927    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
2928    for (i = 0; i < ehdr->e_shnum; i++) {
2929       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2930       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
2931       nsymtabs++;
2932       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2933       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2934       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%ld rem)\n",
2935                nent,
2936                (long)shdr[i].sh_size % sizeof(Elf_Sym)
2937              ));
2938       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
2939          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
2940          return 0;
2941       }
2942       for (j = 0; j < nent; j++) {
2943          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
2944          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
2945                              (int)stab[j].st_shndx,
2946                              (int)stab[j].st_size,
2947                              (char*)stab[j].st_value ));
2948
2949          IF_DEBUG(linker,debugBelch("type=" ));
2950          switch (ELF_ST_TYPE(stab[j].st_info)) {
2951             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
2952             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
2953             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
2954             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
2955             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
2956             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
2957          }
2958          IF_DEBUG(linker,debugBelch("  " ));
2959
2960          IF_DEBUG(linker,debugBelch("bind=" ));
2961          switch (ELF_ST_BIND(stab[j].st_info)) {
2962             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
2963             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
2964             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
2965             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
2966          }
2967          IF_DEBUG(linker,debugBelch("  " ));
2968
2969          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
2970       }
2971    }
2972
2973    if (nsymtabs == 0) {
2974       errorBelch("%s: didn't find any symbol tables", oc->fileName);
2975       return 0;
2976    }
2977
2978    return 1;
2979 }
2980
2981 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
2982 {
2983     *is_bss = FALSE;
2984
2985     if (hdr->sh_type == SHT_PROGBITS
2986         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
2987         /* .text-style section */
2988         return SECTIONKIND_CODE_OR_RODATA;
2989     }
2990
2991     if (hdr->sh_type == SHT_PROGBITS
2992             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
2993             /* .data-style section */
2994             return SECTIONKIND_RWDATA;
2995     }
2996
2997     if (hdr->sh_type == SHT_PROGBITS
2998         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
2999         /* .rodata-style section */
3000         return SECTIONKIND_CODE_OR_RODATA;
3001     }
3002
3003     if (hdr->sh_type == SHT_NOBITS
3004         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
3005         /* .bss-style section */
3006         *is_bss = TRUE;
3007         return SECTIONKIND_RWDATA;
3008     }
3009
3010     return SECTIONKIND_OTHER;
3011 }
3012
3013
3014 static int
3015 ocGetNames_ELF ( ObjectCode* oc )
3016 {
3017    int i, j, k, nent;
3018    Elf_Sym* stab;
3019
3020    char*     ehdrC    = (char*)(oc->image);
3021    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
3022    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
3023    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3024
3025    ASSERT(symhash != NULL);
3026
3027    if (!strtab) {
3028       errorBelch("%s: no strtab", oc->fileName);
3029       return 0;
3030    }
3031
3032    k = 0;
3033    for (i = 0; i < ehdr->e_shnum; i++) {
3034       /* Figure out what kind of section it is.  Logic derived from
3035          Figure 1.14 ("Special Sections") of the ELF document
3036          ("Portable Formats Specification, Version 1.1"). */
3037       int         is_bss = FALSE;
3038       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
3039
3040       if (is_bss && shdr[i].sh_size > 0) {
3041          /* This is a non-empty .bss section.  Allocate zeroed space for
3042             it, and set its .sh_offset field such that
3043             ehdrC + .sh_offset == addr_of_zeroed_space.  */
3044          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
3045                                        "ocGetNames_ELF(BSS)");
3046          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
3047          /*
3048          debugBelch("BSS section at 0x%x, size %d\n",
3049                          zspace, shdr[i].sh_size);
3050          */
3051       }
3052
3053       /* fill in the section info */
3054       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
3055          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
3056          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
3057                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
3058       }
3059
3060       if (shdr[i].sh_type != SHT_SYMTAB) continue;
3061
3062       /* copy stuff into this module's object symbol table */
3063       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
3064       nent = shdr[i].sh_size / sizeof(Elf_Sym);
3065
3066       oc->n_symbols = nent;
3067       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3068                                    "ocGetNames_ELF(oc->symbols)");
3069
3070       for (j = 0; j < nent; j++) {
3071
3072          char  isLocal = FALSE; /* avoids uninit-var warning */
3073          char* ad      = NULL;
3074          char* nm      = strtab + stab[j].st_name;
3075          int   secno   = stab[j].st_shndx;
3076
3077          /* Figure out if we want to add it; if so, set ad to its
3078             address.  Otherwise leave ad == NULL. */
3079
3080          if (secno == SHN_COMMON) {
3081             isLocal = FALSE;
3082             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
3083             /*
3084             debugBelch("COMMON symbol, size %d name %s\n",
3085                             stab[j].st_size, nm);
3086             */
3087             /* Pointless to do addProddableBlock() for this area,
3088                since the linker should never poke around in it. */
3089          }
3090          else
3091          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
3092                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
3093               )
3094               /* and not an undefined symbol */
3095               && stab[j].st_shndx != SHN_UNDEF
3096               /* and not in a "special section" */
3097               && stab[j].st_shndx < SHN_LORESERVE
3098               &&
3099               /* and it's a not a section or string table or anything silly */
3100               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
3101                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
3102                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
3103               )
3104             ) {
3105             /* Section 0 is the undefined section, hence > and not >=. */
3106             ASSERT(secno > 0 && secno < ehdr->e_shnum);
3107             /*
3108             if (shdr[secno].sh_type == SHT_NOBITS) {
3109                debugBelch("   BSS symbol, size %d off %d name %s\n",
3110                                stab[j].st_size, stab[j].st_value, nm);
3111             }
3112             */
3113             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
3114             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
3115                isLocal = TRUE;
3116             } else {
3117 #ifdef ELF_FUNCTION_DESC
3118                /* dlsym() and the initialisation table both give us function
3119                 * descriptors, so to be consistent we store function descriptors
3120                 * in the symbol table */
3121                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
3122                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
3123 #endif
3124                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s",
3125                                       ad, oc->fileName, nm ));
3126                isLocal = FALSE;
3127             }
3128          }
3129
3130          /* And the decision is ... */
3131
3132          if (ad != NULL) {
3133             ASSERT(nm != NULL);
3134             oc->symbols[j] = nm;
3135             /* Acquire! */
3136             if (isLocal) {
3137                /* Ignore entirely. */
3138             } else {
3139                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
3140             }
3141          } else {
3142             /* Skip. */
3143             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
3144                                    strtab + stab[j].st_name ));
3145             /*
3146             debugBelch(
3147                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
3148                     (int)ELF_ST_BIND(stab[j].st_info),
3149                     (int)ELF_ST_TYPE(stab[j].st_info),
3150                     (int)stab[j].st_shndx,
3151                     strtab + stab[j].st_name
3152                    );
3153             */
3154             oc->symbols[j] = NULL;
3155          }
3156
3157       }
3158    }
3159
3160    return 1;
3161 }
3162
3163 /* Do ELF relocations which lack an explicit addend.  All x86-linux
3164    relocations appear to be of this form. */
3165 static int
3166 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
3167                          Elf_Shdr* shdr, int shnum,
3168                          Elf_Sym*  stab, char* strtab )
3169 {
3170    int j;
3171    char *symbol;
3172    Elf_Word* targ;
3173    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
3174    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
3175    int target_shndx = shdr[shnum].sh_info;
3176    int symtab_shndx = shdr[shnum].sh_link;
3177
3178    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3179    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
3180    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3181                           target_shndx, symtab_shndx ));
3182
3183    /* Skip sections that we're not interested in. */
3184    {
3185        int is_bss;
3186        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
3187        if (kind == SECTIONKIND_OTHER) {
3188            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
3189            return 1;
3190        }
3191    }
3192
3193    for (j = 0; j < nent; j++) {
3194       Elf_Addr offset = rtab[j].r_offset;
3195       Elf_Addr info   = rtab[j].r_info;
3196
3197       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
3198       Elf_Word* pP = (Elf_Word*)P;
3199       Elf_Addr  A  = *pP;
3200       Elf_Addr  S;
3201       void*     S_tmp;
3202       Elf_Addr  value;
3203       StgStablePtr stablePtr;
3204       StgPtr stableVal;
3205
3206       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
3207                              j, (void*)offset, (void*)info ));
3208       if (!info) {
3209          IF_DEBUG(linker,debugBelch( " ZERO" ));
3210          S = 0;
3211       } else {
3212          Elf_Sym sym = stab[ELF_R_SYM(info)];
3213          /* First see if it is a local symbol. */
3214          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3215             /* Yes, so we can get the address directly from the ELF symbol
3216                table. */
3217             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3218             S = (Elf_Addr)
3219                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3220                        + stab[ELF_R_SYM(info)].st_value);
3221
3222          } else {
3223             symbol = strtab + sym.st_name;
3224             stablePtr = (StgStablePtr)lookupHashTable(stablehash, (StgWord)symbol);
3225             if (NULL == stablePtr) {
3226               /* No, so look up the name in our global table. */
3227               S_tmp = lookupSymbol( symbol );
3228               S = (Elf_Addr)S_tmp;
3229             } else {
3230               stableVal = deRefStablePtr( stablePtr );
3231               S_tmp = stableVal;
3232               S = (Elf_Addr)S_tmp;
3233             }
3234          }
3235          if (!S) {
3236             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3237             return 0;
3238          }
3239          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
3240       }
3241
3242       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
3243                              (void*)P, (void*)S, (void*)A ));
3244       checkProddableBlock ( oc, pP );
3245
3246       value = S + A;
3247
3248       switch (ELF_R_TYPE(info)) {
3249 #        ifdef i386_HOST_ARCH
3250          case R_386_32:   *pP = value;     break;
3251          case R_386_PC32: *pP = value - P; break;
3252 #        endif
3253          default:
3254             errorBelch("%s: unhandled ELF relocation(Rel) type %lu\n",
3255                   oc->fileName, (lnat)ELF_R_TYPE(info));
3256             return 0;
3257       }
3258
3259    }
3260    return 1;
3261 }
3262
3263 /* Do ELF relocations for which explicit addends are supplied.
3264    sparc-solaris relocations appear to be of this form. */
3265 static int
3266 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
3267                           Elf_Shdr* shdr, int shnum,
3268                           Elf_Sym*  stab, char* strtab )
3269 {
3270    int j;
3271    char *symbol = NULL;
3272    Elf_Addr targ;
3273    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
3274    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
3275    int target_shndx = shdr[shnum].sh_info;
3276    int symtab_shndx = shdr[shnum].sh_link;
3277
3278    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
3279    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
3280    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
3281                           target_shndx, symtab_shndx ));
3282
3283    for (j = 0; j < nent; j++) {
3284 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3285       /* This #ifdef only serves to avoid unused-var warnings. */
3286       Elf_Addr  offset = rtab[j].r_offset;
3287       Elf_Addr  P      = targ + offset;
3288 #endif
3289       Elf_Addr  info   = rtab[j].r_info;
3290       Elf_Addr  A      = rtab[j].r_addend;
3291       Elf_Addr  S;
3292       void*     S_tmp;
3293       Elf_Addr  value;
3294 #     if defined(sparc_HOST_ARCH)
3295       Elf_Word* pP = (Elf_Word*)P;
3296       Elf_Word  w1, w2;
3297 #     elif defined(ia64_HOST_ARCH)
3298       Elf64_Xword *pP = (Elf64_Xword *)P;
3299       Elf_Addr addr;
3300 #     elif defined(powerpc_HOST_ARCH)
3301       Elf_Sword delta;
3302 #     endif
3303
3304       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3305                              j, (void*)offset, (void*)info,
3306                                 (void*)A ));
3307       if (!info) {
3308          IF_DEBUG(linker,debugBelch( " ZERO" ));
3309          S = 0;
3310       } else {
3311          Elf_Sym sym = stab[ELF_R_SYM(info)];
3312          /* First see if it is a local symbol. */
3313          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3314             /* Yes, so we can get the address directly from the ELF symbol
3315                table. */
3316             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3317             S = (Elf_Addr)
3318                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3319                        + stab[ELF_R_SYM(info)].st_value);
3320 #ifdef ELF_FUNCTION_DESC
3321             /* Make a function descriptor for this function */
3322             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3323                S = allocateFunctionDesc(S + A);
3324                A = 0;
3325             }
3326 #endif
3327          } else {
3328             /* No, so look up the name in our global table. */
3329             symbol = strtab + sym.st_name;
3330             S_tmp = lookupSymbol( symbol );
3331             S = (Elf_Addr)S_tmp;
3332
3333 #ifdef ELF_FUNCTION_DESC
3334             /* If a function, already a function descriptor - we would
3335                have to copy it to add an offset. */
3336             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3337                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3338 #endif
3339          }
3340          if (!S) {
3341            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3342            return 0;
3343          }
3344          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3345       }
3346
3347       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3348                                         (void*)P, (void*)S, (void*)A ));
3349       /* checkProddableBlock ( oc, (void*)P ); */
3350
3351       value = S + A;
3352
3353       switch (ELF_R_TYPE(info)) {
3354 #        if defined(sparc_HOST_ARCH)
3355          case R_SPARC_WDISP30:
3356             w1 = *pP & 0xC0000000;
3357             w2 = (Elf_Word)((value - P) >> 2);
3358             ASSERT((w2 & 0xC0000000) == 0);
3359             w1 |= w2;
3360             *pP = w1;
3361             break;
3362          case R_SPARC_HI22:
3363             w1 = *pP & 0xFFC00000;
3364             w2 = (Elf_Word)(value >> 10);
3365             ASSERT((w2 & 0xFFC00000) == 0);
3366             w1 |= w2;
3367             *pP = w1;
3368             break;
3369          case R_SPARC_LO10:
3370             w1 = *pP & ~0x3FF;
3371             w2 = (Elf_Word)(value & 0x3FF);
3372             ASSERT((w2 & ~0x3FF) == 0);
3373             w1 |= w2;
3374             *pP = w1;
3375             break;
3376          /* According to the Sun documentation:
3377             R_SPARC_UA32
3378             This relocation type resembles R_SPARC_32, except it refers to an
3379             unaligned word. That is, the word to be relocated must be treated
3380             as four separate bytes with arbitrary alignment, not as a word
3381             aligned according to the architecture requirements.
3382
3383             (JRS: which means that freeloading on the R_SPARC_32 case
3384             is probably wrong, but hey ...)
3385          */
3386          case R_SPARC_UA32:
3387          case R_SPARC_32:
3388             w2 = (Elf_Word)value;
3389             *pP = w2;
3390             break;
3391 #        elif defined(ia64_HOST_ARCH)
3392          case R_IA64_DIR64LSB:
3393          case R_IA64_FPTR64LSB:
3394             *pP = value;
3395             break;
3396          case R_IA64_PCREL64LSB:
3397             *pP = value - P;
3398             break;
3399          case R_IA64_SEGREL64LSB:
3400             addr = findElfSegment(ehdrC, value);
3401             *pP = value - addr;
3402             break;
3403          case R_IA64_GPREL22:
3404             ia64_reloc_gprel22(P, value);
3405             break;
3406          case R_IA64_LTOFF22:
3407          case R_IA64_LTOFF22X:
3408          case R_IA64_LTOFF_FPTR22:
3409             addr = allocateGOTEntry(value);
3410             ia64_reloc_gprel22(P, addr);
3411             break;
3412          case R_IA64_PCREL21B:
3413             ia64_reloc_pcrel21(P, S, oc);
3414             break;
3415          case R_IA64_LDXMOV:
3416             /* This goes with R_IA64_LTOFF22X and points to the load to
3417              * convert into a move.  We don't implement relaxation. */
3418             break;
3419 #        elif defined(powerpc_HOST_ARCH)
3420          case R_PPC_ADDR16_LO:
3421             *(Elf32_Half*) P = value;
3422             break;
3423
3424          case R_PPC_ADDR16_HI:
3425             *(Elf32_Half*) P = value >> 16;
3426             break;
3427
3428          case R_PPC_ADDR16_HA:
3429             *(Elf32_Half*) P = (value + 0x8000) >> 16;
3430             break;
3431
3432          case R_PPC_ADDR32:
3433             *(Elf32_Word *) P = value;
3434             break;
3435
3436          case R_PPC_REL32:
3437             *(Elf32_Word *) P = value - P;
3438             break;
3439
3440          case R_PPC_REL24:
3441             delta = value - P;
3442
3443             if( delta << 6 >> 6 != delta )
3444             {
3445                value = (Elf_Addr) (&makeSymbolExtra( oc, ELF_R_SYM(info), value )
3446                                         ->jumpIsland);
3447                delta = value - P;
3448
3449                if( value == 0 || delta << 6 >> 6 != delta )
3450                {
3451                   barf( "Unable to make SymbolExtra for #%d",
3452                         ELF_R_SYM(info) );
3453                   return 0;
3454                }
3455             }
3456
3457             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
3458                                           | (delta & 0x3fffffc);
3459             break;
3460 #        endif
3461
3462 #if x86_64_HOST_ARCH
3463       case R_X86_64_64:
3464           *(Elf64_Xword *)P = value;
3465           break;
3466
3467       case R_X86_64_PC32:
3468       {
3469           StgInt64 off = value - P;
3470           if (off >= 0x7fffffffL || off < -0x80000000L) {
3471               barf("R_X86_64_PC32 relocation out of range: %s = %p",
3472                    symbol, off);
3473           }
3474           *(Elf64_Word *)P = (Elf64_Word)off;
3475           break;
3476       }
3477
3478       case R_X86_64_32:
3479           if (value >= 0x7fffffffL) {
3480               barf("R_X86_64_32 relocation out of range: %s = %p\n",
3481                    symbol, value);
3482           }
3483           *(Elf64_Word *)P = (Elf64_Word)value;
3484           break;
3485
3486       case R_X86_64_32S:
3487           if ((StgInt64)value > 0x7fffffffL || (StgInt64)value < -0x80000000L) {
3488               barf("R_X86_64_32S relocation out of range: %s = %p\n",
3489                    symbol, value);
3490           }
3491           *(Elf64_Sword *)P = (Elf64_Sword)value;
3492           break;
3493 #endif
3494
3495          default:
3496             errorBelch("%s: unhandled ELF relocation(RelA) type %lu\n",
3497                   oc->fileName, (lnat)ELF_R_TYPE(info));
3498             return 0;
3499       }
3500
3501    }
3502    return 1;
3503 }
3504
3505 static int
3506 ocResolve_ELF ( ObjectCode* oc )
3507 {
3508    char *strtab;
3509    int   shnum, ok;
3510    Elf_Sym*  stab  = NULL;
3511    char*     ehdrC = (char*)(oc->image);
3512    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
3513    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3514
3515    /* first find "the" symbol table */
3516    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
3517
3518    /* also go find the string table */
3519    strtab = findElfSection ( ehdrC, SHT_STRTAB );
3520
3521    if (stab == NULL || strtab == NULL) {
3522       errorBelch("%s: can't find string or symbol table", oc->fileName);
3523       return 0;
3524    }
3525
3526    /* Process the relocation sections. */
3527    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
3528       if (shdr[shnum].sh_type == SHT_REL) {
3529          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
3530                                        shnum, stab, strtab );
3531          if (!ok) return ok;
3532       }
3533       else
3534       if (shdr[shnum].sh_type == SHT_RELA) {
3535          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
3536                                         shnum, stab, strtab );
3537          if (!ok) return ok;
3538       }
3539    }
3540
3541    /* Free the local symbol table; we won't need it again. */
3542    freeHashTable(oc->lochash, NULL);
3543    oc->lochash = NULL;
3544
3545 #if defined(powerpc_HOST_ARCH)
3546    ocFlushInstructionCache( oc );
3547 #endif
3548
3549    return 1;
3550 }
3551
3552 /*
3553  * IA64 specifics
3554  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
3555  * at the front.  The following utility functions pack and unpack instructions, and
3556  * take care of the most common relocations.
3557  */
3558
3559 #ifdef ia64_HOST_ARCH
3560
3561 static Elf64_Xword
3562 ia64_extract_instruction(Elf64_Xword *target)
3563 {
3564    Elf64_Xword w1, w2;
3565    int slot = (Elf_Addr)target & 3;
3566    target = (Elf_Addr)target & ~3;
3567
3568    w1 = *target;
3569    w2 = *(target+1);
3570
3571    switch (slot)
3572    {
3573       case 0:
3574          return ((w1 >> 5) & 0x1ffffffffff);
3575       case 1:
3576          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
3577       case 2:
3578          return (w2 >> 23);
3579       default:
3580          barf("ia64_extract_instruction: invalid slot %p", target);
3581    }
3582 }
3583
3584 static void
3585 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
3586 {
3587    int slot = (Elf_Addr)target & 3;
3588    target = (Elf_Addr)target & ~3;
3589
3590    switch (slot)
3591    {
3592       case 0:
3593          *target |= value << 5;
3594          break;
3595       case 1:
3596          *target |= value << 46;
3597          *(target+1) |= value >> 18;
3598          break;
3599       case 2:
3600          *(target+1) |= value << 23;
3601          break;
3602    }
3603 }
3604
3605 static void
3606 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
3607 {
3608    Elf64_Xword instruction;
3609    Elf64_Sxword rel_value;
3610
3611    rel_value = value - gp_val;
3612    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
3613       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
3614
3615    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3616    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
3617                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
3618                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
3619                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3620    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3621 }
3622
3623 static void
3624 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
3625 {
3626    Elf64_Xword instruction;
3627    Elf64_Sxword rel_value;
3628    Elf_Addr entry;
3629
3630    entry = allocatePLTEntry(value, oc);
3631
3632    rel_value = (entry >> 4) - (target >> 4);
3633    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
3634       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
3635
3636    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3637    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
3638                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3639    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3640 }
3641
3642 #endif /* ia64 */
3643
3644 /*
3645  * PowerPC ELF specifics
3646  */
3647
3648 #ifdef powerpc_HOST_ARCH
3649
3650 static int ocAllocateSymbolExtras_ELF( ObjectCode *oc )
3651 {
3652   Elf_Ehdr *ehdr;
3653   Elf_Shdr* shdr;
3654   int i;
3655
3656   ehdr = (Elf_Ehdr *) oc->image;
3657   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
3658
3659   for( i = 0; i < ehdr->e_shnum; i++ )
3660     if( shdr[i].sh_type == SHT_SYMTAB )
3661       break;
3662
3663   if( i == ehdr->e_shnum )
3664   {
3665     errorBelch( "This ELF file contains no symtab" );
3666     return 0;
3667   }
3668
3669   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
3670   {
3671     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
3672       shdr[i].sh_entsize, sizeof( Elf_Sym ) );
3673
3674     return 0;
3675   }
3676
3677   return ocAllocateSymbolExtras( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
3678 }
3679
3680 #endif /* powerpc */
3681
3682 #endif /* ELF */
3683
3684 /* --------------------------------------------------------------------------
3685  * Mach-O specifics
3686  * ------------------------------------------------------------------------*/
3687
3688 #if defined(OBJFORMAT_MACHO)
3689
3690 /*
3691   Support for MachO linking on Darwin/MacOS X
3692   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3693
3694   I hereby formally apologize for the hackish nature of this code.
3695   Things that need to be done:
3696   *) implement ocVerifyImage_MachO
3697   *) add still more sanity checks.
3698 */
3699
3700 #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
3701 #define mach_header mach_header_64
3702 #define segment_command segment_command_64
3703 #define section section_64
3704 #define nlist nlist_64
3705 #endif
3706
3707 #ifdef powerpc_HOST_ARCH
3708 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
3709 {
3710     struct mach_header *header = (struct mach_header *) oc->image;
3711     struct load_command *lc = (struct load_command *) (header + 1);
3712     unsigned i;
3713
3714     for( i = 0; i < header->ncmds; i++ )
3715     {
3716         if( lc->cmd == LC_SYMTAB )
3717         {
3718                 // Find out the first and last undefined external
3719                 // symbol, so we don't have to allocate too many
3720                 // jump islands.
3721             struct symtab_command *symLC = (struct symtab_command *) lc;
3722             unsigned min = symLC->nsyms, max = 0;
3723             struct nlist *nlist =
3724                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
3725                       : NULL;
3726             for(i=0;i<symLC->nsyms;i++)
3727             {
3728                 if(nlist[i].n_type & N_STAB)
3729                     ;
3730                 else if(nlist[i].n_type & N_EXT)
3731                 {
3732                     if((nlist[i].n_type & N_TYPE) == N_UNDF
3733                         && (nlist[i].n_value == 0))
3734                     {
3735                         if(i < min)
3736                             min = i;
3737                         if(i > max)
3738                             max = i;
3739                     }
3740                 }
3741             }
3742             if(max >= min)
3743                 return ocAllocateSymbolExtras(oc, max - min + 1, min);
3744
3745             break;
3746         }
3747
3748         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3749     }
3750     return ocAllocateSymbolExtras(oc,0,0);
3751 }
3752 #endif
3753 #ifdef x86_64_HOST_ARCH
3754 static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
3755 {
3756     struct mach_header *header = (struct mach_header *) oc->image;
3757     struct load_command *lc = (struct load_command *) (header + 1);
3758     unsigned i;
3759
3760     for( i = 0; i < header->ncmds; i++ )
3761     {
3762         if( lc->cmd == LC_SYMTAB )
3763         {
3764                 // Just allocate one entry for every symbol
3765             struct symtab_command *symLC = (struct symtab_command *) lc;
3766
3767             return ocAllocateSymbolExtras(oc, symLC->nsyms, 0);
3768         }
3769
3770         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3771     }
3772     return ocAllocateSymbolExtras(oc,0,0);
3773 }
3774 #endif
3775
3776 static int ocVerifyImage_MachO(ObjectCode* oc)
3777 {
3778     char *image = (char*) oc->image;
3779     struct mach_header *header = (struct mach_header*) image;
3780
3781 #if x86_64_TARGET_ARCH || powerpc64_TARGET_ARCH
3782     if(header->magic != MH_MAGIC_64)
3783         return 0;
3784 #else
3785     if(header->magic != MH_MAGIC)
3786         return 0;
3787 #endif
3788     // FIXME: do some more verifying here
3789     return 1;
3790 }
3791
3792 static int resolveImports(
3793     ObjectCode* oc,
3794     char *image,
3795     struct symtab_command *symLC,
3796     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3797     unsigned long *indirectSyms,
3798     struct nlist *nlist)
3799 {
3800     unsigned i;
3801     size_t itemSize = 4;
3802
3803 #if i386_HOST_ARCH
3804     int isJumpTable = 0;
3805     if(!strcmp(sect->sectname,"__jump_table"))
3806     {
3807         isJumpTable = 1;
3808         itemSize = 5;
3809         ASSERT(sect->reserved2 == itemSize);
3810     }
3811 #endif
3812
3813     for(i=0; i*itemSize < sect->size;i++)
3814     {
3815         // according to otool, reserved1 contains the first index into the indirect symbol table
3816         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
3817         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3818         void *addr = NULL;
3819
3820         if((symbol->n_type & N_TYPE) == N_UNDF
3821             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
3822             addr = (void*) (symbol->n_value);
3823         else if((addr = lookupLocalSymbol(oc,nm)) != NULL)
3824             ;
3825         else
3826             addr = lookupSymbol(nm);
3827         if(!addr)
3828         {
3829             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
3830             return 0;
3831         }
3832         ASSERT(addr);
3833
3834 #if i386_HOST_ARCH
3835         if(isJumpTable)
3836         {
3837             checkProddableBlock(oc,image + sect->offset + i*itemSize);
3838             *(image + sect->offset + i*itemSize) = 0xe9; // jmp
3839             *(unsigned*)(image + sect->offset + i*itemSize + 1)
3840                 = (char*)addr - (image + sect->offset + i*itemSize + 5);
3841         }
3842         else
3843 #endif
3844         {
3845             checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
3846             ((void**)(image + sect->offset))[i] = addr;
3847         }
3848     }
3849
3850     return 1;
3851 }
3852
3853 static unsigned long relocateAddress(
3854     ObjectCode* oc,
3855     int nSections,
3856     struct section* sections,
3857     unsigned long address)
3858 {
3859     int i;
3860     for(i = 0; i < nSections; i++)
3861     {
3862         if(sections[i].addr <= address
3863             && address < sections[i].addr + sections[i].size)
3864         {
3865             return (unsigned long)oc->image
3866                     + sections[i].offset + address - sections[i].addr;
3867         }
3868     }
3869     barf("Invalid Mach-O file:"
3870          "Address out of bounds while relocating object file");
3871     return 0;
3872 }
3873
3874 static int relocateSection(
3875     ObjectCode* oc,
3876     char *image,
3877     struct symtab_command *symLC, struct nlist *nlist,
3878     int nSections, struct section* sections, struct section *sect)
3879 {
3880     struct relocation_info *relocs;
3881     int i,n;
3882
3883     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
3884         return 1;
3885     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
3886         return 1;
3887     else if(!strcmp(sect->sectname,"__la_sym_ptr2"))
3888         return 1;
3889     else if(!strcmp(sect->sectname,"__la_sym_ptr3"))
3890         return 1;
3891
3892     n = sect->nreloc;
3893     relocs = (struct relocation_info*) (image + sect->reloff);
3894
3895     for(i=0;i<n;i++)
3896     {
3897 #ifdef x86_64_HOST_ARCH
3898         struct relocation_info *reloc = &relocs[i];
3899
3900         char    *thingPtr = image + sect->offset + reloc->r_address;
3901         uint64_t thing;
3902         uint64_t value;
3903         uint64_t baseValue;
3904         int type = reloc->r_type;
3905
3906         checkProddableBlock(oc,thingPtr);
3907         switch(reloc->r_length)
3908         {
3909             case 0:
3910                 thing = *(uint8_t*)thingPtr;
3911                 baseValue = (uint64_t)thingPtr + 1;
3912                 break;
3913             case 1:
3914                 thing = *(uint16_t*)thingPtr;
3915                 baseValue = (uint64_t)thingPtr + 2;
3916                 break;
3917             case 2:
3918                 thing = *(uint32_t*)thingPtr;
3919                 baseValue = (uint64_t)thingPtr + 4;
3920                 break;
3921             case 3:
3922                 thing = *(uint64_t*)thingPtr;
3923                 baseValue = (uint64_t)thingPtr + 8;
3924                 break;
3925             default:
3926                 barf("Unknown size.");
3927         }
3928
3929         if(type == X86_64_RELOC_GOT
3930            || type == X86_64_RELOC_GOT_LOAD)
3931         {
3932             ASSERT(reloc->r_extern);
3933             value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)->addr;
3934
3935             type = X86_64_RELOC_SIGNED;
3936         }
3937         else if(reloc->r_extern)
3938         {
3939             struct nlist *symbol = &nlist[reloc->r_symbolnum];
3940             char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3941             if(symbol->n_value == 0)
3942                 value = (uint64_t) lookupSymbol(nm);
3943             else
3944                 value = relocateAddress(oc, nSections, sections,
3945                                         symbol->n_value);
3946         }
3947         else
3948         {
3949             value = sections[reloc->r_symbolnum-1].offset
3950                   - sections[reloc->r_symbolnum-1].addr
3951                   + (uint64_t) image;
3952         }
3953
3954         if(type == X86_64_RELOC_BRANCH)
3955         {
3956             if((int32_t)(value - baseValue) != (int64_t)(value - baseValue))
3957             {
3958                 ASSERT(reloc->r_extern);
3959                 value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, value)
3960                                         -> jumpIsland;
3961             }
3962             ASSERT((int32_t)(value - baseValue) == (int64_t)(value - baseValue));
3963             type = X86_64_RELOC_SIGNED;
3964         }
3965
3966         switch(type)
3967         {
3968             case X86_64_RELOC_UNSIGNED:
3969                 ASSERT(!reloc->r_pcrel);
3970                 thing += value;
3971                 break;
3972             case X86_64_RELOC_SIGNED:
3973                 ASSERT(reloc->r_pcrel);
3974                 thing += value - baseValue;
3975                 break;
3976             case X86_64_RELOC_SUBTRACTOR:
3977                 ASSERT(!reloc->r_pcrel);
3978                 thing -= value;
3979                 break;
3980             default:
3981                 barf("unkown relocation");
3982         }
3983
3984         switch(reloc->r_length)
3985         {
3986             case 0:
3987                 *(uint8_t*)thingPtr = thing;
3988                 break;
3989             case 1:
3990                 *(uint16_t*)thingPtr = thing;
3991                 break;
3992             case 2:
3993                 *(uint32_t*)thingPtr = thing;
3994                 break;
3995             case 3:
3996                 *(uint64_t*)thingPtr = thing;
3997                 break;
3998         }
3999 #else
4000         if(relocs[i].r_address & R_SCATTERED)
4001         {
4002             struct scattered_relocation_info *scat =
4003                 (struct scattered_relocation_info*) &relocs[i];
4004
4005             if(!scat->r_pcrel)
4006             {
4007                 if(scat->r_length == 2)
4008                 {
4009                     unsigned long word = 0;
4010                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
4011                     checkProddableBlock(oc,wordPtr);
4012
4013                     // Note on relocation types:
4014                     // i386 uses the GENERIC_RELOC_* types,
4015                     // while ppc uses special PPC_RELOC_* types.
4016                     // *_RELOC_VANILLA and *_RELOC_PAIR have the same value
4017                     // in both cases, all others are different.
4018                     // Therefore, we use GENERIC_RELOC_VANILLA
4019                     // and GENERIC_RELOC_PAIR instead of the PPC variants,
4020                     // and use #ifdefs for the other types.
4021
4022                     // Step 1: Figure out what the relocated value should be
4023                     if(scat->r_type == GENERIC_RELOC_VANILLA)
4024                     {
4025                         word = *wordPtr + (unsigned long) relocateAddress(
4026                                                                 oc,
4027                                                                 nSections,
4028                                                                 sections,
4029                                                                 scat->r_value)
4030                                         - scat->r_value;
4031                     }
4032 #ifdef powerpc_HOST_ARCH
4033                     else if(scat->r_type == PPC_RELOC_SECTDIFF
4034                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
4035                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
4036                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
4037 #else
4038                     else if(scat->r_type == GENERIC_RELOC_SECTDIFF)
4039 #endif
4040                     {
4041                         struct scattered_relocation_info *pair =
4042                                 (struct scattered_relocation_info*) &relocs[i+1];
4043
4044                         if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR)
4045                             barf("Invalid Mach-O file: "
4046                                  "RELOC_*_SECTDIFF not followed by RELOC_PAIR");
4047
4048                         word = (unsigned long)
4049                                (relocateAddress(oc, nSections, sections, scat->r_value)
4050                               - relocateAddress(oc, nSections, sections, pair->r_value));
4051                         i++;
4052                     }
4053 #ifdef powerpc_HOST_ARCH
4054                     else if(scat->r_type == PPC_RELOC_HI16
4055                          || scat->r_type == PPC_RELOC_LO16
4056                          || scat->r_type == PPC_RELOC_HA16
4057                          || scat->r_type == PPC_RELOC_LO14)
4058                     {   // these are generated by label+offset things
4059                         struct relocation_info *pair = &relocs[i+1];
4060                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
4061                             barf("Invalid Mach-O file: "
4062                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
4063
4064                         if(scat->r_type == PPC_RELOC_LO16)
4065                         {
4066                             word = ((unsigned short*) wordPtr)[1];
4067                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4068                         }
4069                         else if(scat->r_type == PPC_RELOC_LO14)
4070                         {
4071                             barf("Unsupported Relocation: PPC_RELOC_LO14");
4072                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
4073                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4074                         }
4075                         else if(scat->r_type == PPC_RELOC_HI16)
4076                         {
4077                             word = ((unsigned short*) wordPtr)[1] << 16;
4078                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4079                         }
4080                         else if(scat->r_type == PPC_RELOC_HA16)
4081                         {
4082                             word = ((unsigned short*) wordPtr)[1] << 16;
4083                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4084                         }
4085
4086
4087                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
4088                                                 - scat->r_value;
4089
4090                         i++;
4091                     }
4092  #endif
4093                     else
4094                         continue;  // ignore the others
4095
4096 #ifdef powerpc_HOST_ARCH
4097                     if(scat->r_type == GENERIC_RELOC_VANILLA
4098                         || scat->r_type == PPC_RELOC_SECTDIFF)
4099 #else
4100                     if(scat->r_type == GENERIC_RELOC_VANILLA
4101                         || scat->r_type == GENERIC_RELOC_SECTDIFF)
4102 #endif
4103                     {
4104                         *wordPtr = word;
4105                     }
4106 #ifdef powerpc_HOST_ARCH
4107                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
4108                     {
4109                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4110                     }
4111                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
4112                     {
4113                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4114                     }
4115                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
4116                     {
4117                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4118                             + ((word & (1<<15)) ? 1 : 0);
4119                     }
4120 #endif
4121                 }
4122             }
4123
4124             continue; // FIXME: I hope it's OK to ignore all the others.
4125         }
4126         else
4127         {
4128             struct relocation_info *reloc = &relocs[i];
4129             if(reloc->r_pcrel && !reloc->r_extern)
4130                 continue;
4131
4132             if(reloc->r_length == 2)
4133             {
4134                 unsigned long word = 0;
4135 #ifdef powerpc_HOST_ARCH
4136                 unsigned long jumpIsland = 0;
4137                 long offsetToJumpIsland = 0xBADBAD42; // initialise to bad value
4138                                                       // to avoid warning and to catch
4139                                                       // bugs.
4140 #endif
4141
4142                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
4143                 checkProddableBlock(oc,wordPtr);
4144
4145                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4146                 {
4147                     word = *wordPtr;
4148                 }
4149 #ifdef powerpc_HOST_ARCH
4150                 else if(reloc->r_type == PPC_RELOC_LO16)
4151                 {
4152                     word = ((unsigned short*) wordPtr)[1];
4153                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
4154                 }
4155                 else if(reloc->r_type == PPC_RELOC_HI16)
4156                 {
4157                     word = ((unsigned short*) wordPtr)[1] << 16;
4158                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
4159                 }
4160                 else if(reloc->r_type == PPC_RELOC_HA16)
4161                 {
4162                     word = ((unsigned short*) wordPtr)[1] << 16;
4163                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
4164                 }
4165                 else if(reloc->r_type == PPC_RELOC_BR24)
4166                 {
4167                     word = *wordPtr;
4168                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
4169                 }
4170 #endif
4171
4172                 if(!reloc->r_extern)
4173                 {
4174                     long delta =
4175                         sections[reloc->r_symbolnum-1].offset
4176                         - sections[reloc->r_symbolnum-1].addr
4177                         + ((long) image);
4178
4179                     word += delta;
4180                 }
4181                 else
4182                 {
4183                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
4184                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
4185                     void *symbolAddress = lookupSymbol(nm);
4186                     if(!symbolAddress)
4187                     {
4188                         errorBelch("\nunknown symbol `%s'", nm);
4189                         return 0;
4190                     }
4191
4192                     if(reloc->r_pcrel)
4193                     {
4194 #ifdef powerpc_HOST_ARCH
4195                             // In the .o file, this should be a relative jump to NULL
4196                             // and we'll change it to a relative jump to the symbol
4197                         ASSERT(-word == reloc->r_address);
4198                         jumpIsland = (unsigned long)
4199                                         &makeSymbolExtra(oc,
4200                                                          reloc->r_symbolnum,
4201                                                          (unsigned long) symbolAddress)
4202                                          -> jumpIsland;
4203                         if(jumpIsland != 0)
4204                         {
4205                             offsetToJumpIsland = word + jumpIsland
4206                                 - (((long)image) + sect->offset - sect->addr);
4207                         }
4208 #endif
4209                         word += (unsigned long) symbolAddress
4210                                 - (((long)image) + sect->offset - sect->addr);
4211                     }
4212                     else
4213                     {
4214                         word += (unsigned long) symbolAddress;
4215                     }
4216                 }
4217
4218                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
4219                 {
4220                     *wordPtr = word;
4221                     continue;
4222                 }
4223 #ifdef powerpc_HOST_ARCH
4224                 else if(reloc->r_type == PPC_RELOC_LO16)
4225                 {
4226                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
4227                     i++; continue;
4228                 }
4229                 else if(reloc->r_type == PPC_RELOC_HI16)
4230                 {
4231                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
4232                     i++; continue;
4233                 }
4234                 else if(reloc->r_type == PPC_RELOC_HA16)
4235                 {
4236                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
4237                         + ((word & (1<<15)) ? 1 : 0);
4238                     i++; continue;
4239                 }
4240                 else if(reloc->r_type == PPC_RELOC_BR24)
4241                 {
4242                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4243                     {
4244                         // The branch offset is too large.
4245                         // Therefore, we try to use a jump island.
4246                         if(jumpIsland == 0)
4247                         {
4248                             barf("unconditional relative branch out of range: "
4249                                  "no jump island available");
4250                         }
4251
4252                         word = offsetToJumpIsland;
4253                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
4254                             barf("unconditional relative branch out of range: "
4255                                  "jump island out of range");
4256                     }
4257                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
4258                     continue;
4259                 }
4260 #endif
4261             }
4262             barf("\nunknown relocation %d",reloc->r_type);
4263             return 0;
4264         }
4265 #endif
4266     }
4267     return 1;
4268 }
4269
4270 static int ocGetNames_MachO(ObjectCode* oc)
4271 {
4272     char *image = (char*) oc->image;
4273     struct mach_header *header = (struct mach_header*) image;
4274     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4275     unsigned i,curSymbol = 0;
4276     struct segment_command *segLC = NULL;
4277     struct section *sections;
4278     struct symtab_command *symLC = NULL;
4279     struct nlist *nlist;
4280     unsigned long commonSize = 0;
4281     char    *commonStorage = NULL;
4282     unsigned long commonCounter;
4283
4284     for(i=0;i<header->ncmds;i++)
4285     {
4286         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4287             segLC = (struct segment_command*) lc;
4288         else if(lc->cmd == LC_SYMTAB)
4289             symLC = (struct symtab_command*) lc;
4290         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4291     }
4292
4293     sections = (struct section*) (segLC+1);
4294     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4295                   : NULL;
4296
4297     if(!segLC)
4298         barf("ocGetNames_MachO: no segment load command");
4299
4300     for(i=0;i<segLC->nsects;i++)
4301     {
4302         if(sections[i].size == 0)
4303             continue;
4304
4305         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
4306         {
4307             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
4308                                       "ocGetNames_MachO(common symbols)");
4309             sections[i].offset = zeroFillArea - image;
4310         }
4311
4312         if(!strcmp(sections[i].sectname,"__text"))
4313             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
4314                 (void*) (image + sections[i].offset),
4315                 (void*) (image + sections[i].offset + sections[i].size));
4316         else if(!strcmp(sections[i].sectname,"__const"))
4317             addSection(oc, SECTIONKIND_RWDATA,
4318                 (void*) (image + sections[i].offset),
4319                 (void*) (image + sections[i].offset + sections[i].size));
4320         else if(!strcmp(sections[i].sectname,"__data"))
4321             addSection(oc, SECTIONKIND_RWDATA,
4322                 (void*) (image + sections[i].offset),
4323                 (void*) (image + sections[i].offset + sections[i].size));
4324         else if(!strcmp(sections[i].sectname,"__bss")
4325                 || !strcmp(sections[i].sectname,"__common"))
4326             addSection(oc, SECTIONKIND_RWDATA,
4327                 (void*) (image + sections[i].offset),
4328                 (void*) (image + sections[i].offset + sections[i].size));
4329
4330         addProddableBlock(oc, (void*) (image + sections[i].offset),
4331                                         sections[i].size);
4332     }
4333
4334         // count external symbols defined here
4335     oc->n_symbols = 0;
4336     if(symLC)
4337     {
4338         for(i=0;i<symLC->nsyms;i++)
4339         {
4340             if(nlist[i].n_type & N_STAB)
4341                 ;
4342             else if(nlist[i].n_type & N_EXT)
4343             {
4344                 if((nlist[i].n_type & N_TYPE) == N_UNDF
4345                     && (nlist[i].n_value != 0))
4346                 {
4347                     commonSize += nlist[i].n_value;
4348                     oc->n_symbols++;
4349                 }
4350                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
4351                     oc->n_symbols++;
4352             }
4353         }
4354     }
4355     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
4356                                    "ocGetNames_MachO(oc->symbols)");
4357
4358     if(symLC)
4359     {
4360         for(i=0;i<symLC->nsyms;i++)
4361         {
4362             if(nlist[i].n_type & N_STAB)
4363                 ;
4364             else if((nlist[i].n_type & N_TYPE) == N_SECT)
4365             {
4366                 if(nlist[i].n_type & N_EXT)
4367                 {
4368                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4369                     if((nlist[i].n_desc & N_WEAK_DEF) && lookupSymbol(nm))
4370                         ; // weak definition, and we already have a definition
4371                     else
4372                     {
4373                             ghciInsertStrHashTable(oc->fileName, symhash, nm,
4374                                                     image
4375                                                     + sections[nlist[i].n_sect-1].offset
4376                                                     - sections[nlist[i].n_sect-1].addr
4377                                                     + nlist[i].n_value);
4378                             oc->symbols[curSymbol++] = nm;
4379                     }
4380                 }
4381             }
4382         }
4383     }
4384
4385     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
4386     commonCounter = (unsigned long)commonStorage;
4387     if(symLC)
4388     {
4389         for(i=0;i<symLC->nsyms;i++)
4390         {
4391             if((nlist[i].n_type & N_TYPE) == N_UNDF
4392                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
4393             {
4394                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
4395                 unsigned long sz = nlist[i].n_value;
4396
4397                 nlist[i].n_value = commonCounter;
4398
4399                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
4400                                        (void*)commonCounter);
4401                 oc->symbols[curSymbol++] = nm;
4402
4403                 commonCounter += sz;
4404             }
4405         }
4406     }
4407     return 1;
4408 }
4409
4410 static int ocResolve_MachO(ObjectCode* oc)
4411 {
4412     char *image = (char*) oc->image;
4413     struct mach_header *header = (struct mach_header*) image;
4414     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
4415     unsigned i;
4416     struct segment_command *segLC = NULL;
4417     struct section *sections;
4418     struct symtab_command *symLC = NULL;
4419     struct dysymtab_command *dsymLC = NULL;
4420     struct nlist *nlist;
4421
4422     for(i=0;i<header->ncmds;i++)
4423     {
4424         if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64)
4425             segLC = (struct segment_command*) lc;
4426         else if(lc->cmd == LC_SYMTAB)
4427             symLC = (struct symtab_command*) lc;
4428         else if(lc->cmd == LC_DYSYMTAB)
4429             dsymLC = (struct dysymtab_command*) lc;
4430         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
4431     }
4432
4433     sections = (struct section*) (segLC+1);
4434     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
4435                   : NULL;
4436
4437     if(dsymLC)
4438     {
4439         unsigned long *indirectSyms
4440             = (unsigned long*) (image + dsymLC->indirectsymoff);
4441
4442         for(i=0;i<segLC->nsects;i++)
4443         {
4444             if(    !strcmp(sections[i].sectname,"__la_symbol_ptr")
4445                 || !strcmp(sections[i].sectname,"__la_sym_ptr2")
4446                 || !strcmp(sections[i].sectname,"__la_sym_ptr3"))
4447             {
4448                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4449                     return 0;
4450             }
4451             else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr")
4452                 ||  !strcmp(sections[i].sectname,"__pointers"))
4453             {
4454                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4455                     return 0;
4456             }
4457             else if(!strcmp(sections[i].sectname,"__jump_table"))
4458             {
4459                 if(!resolveImports(oc,image,symLC,&sections[i],indirectSyms,nlist))
4460                     return 0;
4461             }
4462         }
4463     }
4464
4465     for(i=0;i<segLC->nsects;i++)
4466     {
4467         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
4468             return 0;
4469     }
4470
4471     /* Free the local symbol table; we won't need it again. */
4472     freeHashTable(oc->lochash, NULL);
4473     oc->lochash = NULL;
4474
4475 #if defined (powerpc_HOST_ARCH)
4476     ocFlushInstructionCache( oc );
4477 #endif
4478
4479     return 1;
4480 }
4481
4482 #ifdef powerpc_HOST_ARCH
4483 /*
4484  * The Mach-O object format uses leading underscores. But not everywhere.
4485  * There is a small number of runtime support functions defined in
4486  * libcc_dynamic.a whose name does not have a leading underscore.
4487  * As a consequence, we can't get their address from C code.
4488  * We have to use inline assembler just to take the address of a function.
4489  * Yuck.
4490  */
4491
4492 static void machoInitSymbolsWithoutUnderscore()
4493 {
4494     extern void* symbolsWithoutUnderscore[];
4495     void **p = symbolsWithoutUnderscore;
4496     __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
4497
4498 #undef Sym
4499 #define Sym(x)  \
4500     __asm__ volatile(".long " # x);
4501
4502     RTS_MACHO_NOUNDERLINE_SYMBOLS
4503
4504     __asm__ volatile(".text");
4505
4506 #undef Sym
4507 #define Sym(x)  \
4508     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
4509
4510     RTS_MACHO_NOUNDERLINE_SYMBOLS
4511
4512 #undef Sym
4513 }
4514 #endif
4515
4516 /*
4517  * Figure out by how much to shift the entire Mach-O file in memory
4518  * when loading so that its single segment ends up 16-byte-aligned
4519  */
4520 static int machoGetMisalignment( FILE * f )
4521 {
4522     struct mach_header header;
4523     int misalignment;
4524
4525     fread(&header, sizeof(header), 1, f);
4526     rewind(f);
4527
4528 #if x86_64_TARGET_ARCH || powerpc64_TARGET_ARCH
4529     if(header.magic != MH_MAGIC_64)
4530         return 0;
4531 #else
4532     if(header.magic != MH_MAGIC)
4533         return 0;
4534 #endif
4535
4536     misalignment = (header.sizeofcmds + sizeof(header))
4537                     & 0xF;
4538
4539     return misalignment ? (16 - misalignment) : 0;
4540 }
4541
4542 #endif
4543