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