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