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