ghc/rts/Linker.c

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