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