rts/Linker.c

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