ghc/rts/Linker.c

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