rts/Linker.c

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