ghc/rts/Linker.c

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