ghc/rts/Linker.c

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