ghc/rts/Linker.c

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