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