ghc/rts/Linker.c

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