ghc/rts/Linker.c

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