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