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