ghc/rts/Linker.c

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