ghc/rts/Linker.c

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