ghc/rts/Linker.c

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