ghc/rts/Linker.c

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