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