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