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