ghc/rts/Linker.c

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