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