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