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