ghc/rts/Linker.c

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