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