ghc/rts/Linker.c

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