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