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