ghc/rts/Linker.c

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