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