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