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