ghc/rts/Linker.c

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