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