ghc/rts/Linker.c

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