ghc/rts/Linker.c

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