ghc/rts/Linker.c

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