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