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