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