Linker.c

/* -----------------------------------------------------------------------------
 *
 * (c) The GHC Team, 2000-2004
 *
 * RTS Object Linker
 *
 * ---------------------------------------------------------------------------*/

#if 0
#include "PosixSource.h"
#endif

/* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and 
   MREMAP_MAYMOVE from <sys/mman.h>.
 */
#ifdef __linux__
#define _GNU_SOURCE
#endif

#include "Rts.h"
#include "RtsFlags.h"
#include "HsFFI.h"
#include "Hash.h"
#include "Linker.h"
#include "LinkerInternals.h"
#include "RtsUtils.h"
#include "Schedule.h"
#include "Storage.h"

#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif

#include <stdlib.h>
#include <string.h>

#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif

#if defined(HAVE_DLFCN_H)
#include <dlfcn.h>
#endif

#if defined(cygwin32_HOST_OS)
#ifdef HAVE_DIRENT_H
#include <dirent.h>
#endif

#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
#include <regex.h>
#include <sys/fcntl.h>
#include <sys/termios.h>
#include <sys/utime.h>
#include <sys/utsname.h>
#include <sys/wait.h>
#endif

#if defined(ia64_HOST_ARCH) || defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
#define USE_MMAP
#include <fcntl.h>
#include <sys/mman.h>

#if defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#endif

#endif

#if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS)
#  define OBJFORMAT_ELF
#elif defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
#  define OBJFORMAT_PEi386
#  include <windows.h>
#  include <math.h>
#elif defined(darwin_HOST_OS)
#  include <mach-o/ppc/reloc.h>
#  define OBJFORMAT_MACHO
#  include <mach-o/loader.h>
#  include <mach-o/nlist.h>
#  include <mach-o/reloc.h>
#  include <mach-o/dyld.h>
#endif

/* Hash table mapping symbol names to Symbol */
static /*Str*/HashTable *symhash;

/* List of currently loaded objects */
ObjectCode *objects = NULL;	/* initially empty */

#if defined(OBJFORMAT_ELF)
static int ocVerifyImage_ELF    ( ObjectCode* oc );
static int ocGetNames_ELF       ( ObjectCode* oc );
static int ocResolve_ELF        ( ObjectCode* oc );
#if defined(powerpc_HOST_ARCH)
static int ocAllocateJumpIslands_ELF ( ObjectCode* oc );
#endif
#elif defined(OBJFORMAT_PEi386)
static int ocVerifyImage_PEi386 ( ObjectCode* oc );
static int ocGetNames_PEi386    ( ObjectCode* oc );
static int ocResolve_PEi386     ( ObjectCode* oc );
#elif defined(OBJFORMAT_MACHO)
static int ocAllocateJumpIslands_MachO ( ObjectCode* oc );
static int ocVerifyImage_MachO    ( ObjectCode* oc );
static int ocGetNames_MachO       ( ObjectCode* oc );
static int ocResolve_MachO        ( ObjectCode* oc );

static void machoInitSymbolsWithoutUnderscore( void );
#endif

/* -----------------------------------------------------------------------------
 * Built-in symbols from the RTS
 */

typedef struct _RtsSymbolVal {
    char   *lbl;
    void   *addr;
} RtsSymbolVal;


#if !defined(PAR)
#define Maybe_ForeignObj        SymX(mkForeignObjzh_fast)

#define Maybe_Stable_Names      SymX(mkWeakzh_fast)			\
      				SymX(makeStableNamezh_fast)		\
      				SymX(finalizzeWeakzh_fast)
#else
/* These are not available in GUM!!! -- HWL */
#define Maybe_ForeignObj
#define Maybe_Stable_Names
#endif

#if !defined (mingw32_HOST_OS)
#define RTS_POSIX_ONLY_SYMBOLS                  \
      SymX(stg_sig_install)			\
      Sym(nocldstop)
#endif

#if defined (cygwin32_HOST_OS)
#define RTS_MINGW_ONLY_SYMBOLS /**/
/* Don't have the ability to read import libs / archives, so
 * we have to stupidly list a lot of what libcygwin.a
 * exports; sigh.
 */
#define RTS_CYGWIN_ONLY_SYMBOLS                 \
      SymX(regfree)                             \
      SymX(regexec)                             \
      SymX(regerror)                            \
      SymX(regcomp)                             \
      SymX(__errno)                             \
      SymX(access)                              \
      SymX(chmod)                               \
      SymX(chdir)                               \
      SymX(close)                               \
      SymX(creat)                               \
      SymX(dup)                                 \
      SymX(dup2)                                \
      SymX(fstat)                               \
      SymX(fcntl)                               \
      SymX(getcwd)                              \
      SymX(getenv)                              \
      SymX(lseek)                               \
      SymX(open)                                \
      SymX(fpathconf)                           \
      SymX(pathconf)                            \
      SymX(stat)                                \
      SymX(pow)                                 \
      SymX(tanh)                                \
      SymX(cosh)                                \
      SymX(sinh)                                \
      SymX(atan)                                \
      SymX(acos)                                \
      SymX(asin)                                \
      SymX(tan)                                 \
      SymX(cos)                                 \
      SymX(sin)                                 \
      SymX(exp)                                 \
      SymX(log)                                 \
      SymX(sqrt)                                \
      SymX(localtime_r)                         \
      SymX(gmtime_r)                            \
      SymX(mktime)                              \
      Sym(_imp___tzname)                        \
      SymX(gettimeofday)                        \
      SymX(timezone)                            \
      SymX(tcgetattr)                           \
      SymX(tcsetattr)                           \
      SymX(memcpy)                              \
      SymX(memmove)                             \
      SymX(realloc)                             \
      SymX(malloc)                              \
      SymX(free)                                \
      SymX(fork)                                \
      SymX(lstat)                               \
      SymX(isatty)                              \
      SymX(mkdir)                               \
      SymX(opendir)                             \
      SymX(readdir)                             \
      SymX(rewinddir)                           \
      SymX(closedir)                            \
      SymX(link)                                \
      SymX(mkfifo)                              \
      SymX(pipe)                                \
      SymX(read)                                \
      SymX(rename)                              \
      SymX(rmdir)                               \
      SymX(select)                              \
      SymX(system)                              \
      SymX(write)                               \
      SymX(strcmp)                              \
      SymX(strcpy)                              \
      SymX(strncpy)                             \
      SymX(strerror)                            \
      SymX(sigaddset)                           \
      SymX(sigemptyset)                         \
      SymX(sigprocmask)                         \
      SymX(umask)                               \
      SymX(uname)                               \
      SymX(unlink)                              \
      SymX(utime)                               \
      SymX(waitpid)

#elif !defined(mingw32_HOST_OS)
#define RTS_MINGW_ONLY_SYMBOLS /**/
#define RTS_CYGWIN_ONLY_SYMBOLS /**/
#else /* defined(mingw32_HOST_OS) */
#define RTS_POSIX_ONLY_SYMBOLS  /**/
#define RTS_CYGWIN_ONLY_SYMBOLS /**/

/* Extra syms gen'ed by mingw-2's gcc-3.2: */
#if __GNUC__>=3
#define RTS_MINGW_EXTRA_SYMS                    \
      Sym(_imp____mb_cur_max)                   \
      Sym(_imp___pctype)
#else
#define RTS_MINGW_EXTRA_SYMS
#endif

/* These are statically linked from the mingw libraries into the ghc
   executable, so we have to employ this hack. */
#define RTS_MINGW_ONLY_SYMBOLS                  \
      SymX(asyncReadzh_fast)			\
      SymX(asyncWritezh_fast)			\
      SymX(asyncDoProczh_fast)			\
      SymX(memset)                              \
      SymX(inet_ntoa)                           \
      SymX(inet_addr)                           \
      SymX(htonl)                               \
      SymX(recvfrom)                            \
      SymX(listen)                              \
      SymX(bind)                                \
      SymX(shutdown)                            \
      SymX(connect)                             \
      SymX(htons)                               \
      SymX(ntohs)                               \
      SymX(getservbyname)                       \
      SymX(getservbyport)                       \
      SymX(getprotobynumber)                    \
      SymX(getprotobyname)                      \
      SymX(gethostbyname)                       \
      SymX(gethostbyaddr)                       \
      SymX(gethostname)                         \
      SymX(strcpy)                              \
      SymX(strncpy)                             \
      SymX(abort)                               \
      Sym(_alloca)                              \
      Sym(isxdigit)                             \
      Sym(isupper)                              \
      Sym(ispunct)                              \
      Sym(islower)                              \
      Sym(isspace)                              \
      Sym(isprint)                              \
      Sym(isdigit)                              \
      Sym(iscntrl)                              \
      Sym(isalpha)                              \
      Sym(isalnum)                              \
      SymX(strcmp)                              \
      SymX(memmove)                             \
      SymX(realloc)                             \
      SymX(malloc)                              \
      SymX(pow)                                 \
      SymX(tanh)                                \
      SymX(cosh)                                \
      SymX(sinh)                                \
      SymX(atan)                                \
      SymX(acos)                                \
      SymX(asin)                                \
      SymX(tan)                                 \
      SymX(cos)                                 \
      SymX(sin)                                 \
      SymX(exp)                                 \
      SymX(log)                                 \
      SymX(sqrt)                                \
      SymX(memcpy)                              \
      SymX(stg_InstallConsoleEvent)             \
      Sym(mktime)                               \
      Sym(_imp___timezone)                      \
      Sym(_imp___tzname)                        \
      Sym(_imp___iob)                           \
      Sym(localtime)                            \
      Sym(gmtime)                               \
      Sym(opendir)                              \
      Sym(readdir)                              \
      Sym(rewinddir)                            \
      RTS_MINGW_EXTRA_SYMS                      \
      Sym(closedir)
#endif

#ifndef SMP
# define MAIN_CAP_SYM SymX(MainCapability)
#else
# define MAIN_CAP_SYM
#endif

#ifdef TABLES_NEXT_TO_CODE
#define RTS_RET_SYMBOLS /* nothing */
#else
#define RTS_RET_SYMBOLS 			\
      SymX(stg_enter_ret)			\
      SymX(stg_gc_fun_ret)			\
      SymX(stg_ap_0_ret)			\
      SymX(stg_ap_v_ret)			\
      SymX(stg_ap_f_ret)			\
      SymX(stg_ap_d_ret)			\
      SymX(stg_ap_l_ret)			\
      SymX(stg_ap_n_ret)			\
      SymX(stg_ap_p_ret)			\
      SymX(stg_ap_pv_ret)			\
      SymX(stg_ap_pp_ret)			\
      SymX(stg_ap_ppv_ret)			\
      SymX(stg_ap_ppp_ret)			\
      SymX(stg_ap_pppv_ret)			\
      SymX(stg_ap_pppp_ret)			\
      SymX(stg_ap_ppppp_ret)			\
      SymX(stg_ap_pppppp_ret)
#endif

#define RTS_SYMBOLS				\
      Maybe_ForeignObj				\
      Maybe_Stable_Names			\
      Sym(StgReturn)				\
      SymX(stg_enter_info)			\
      SymX(stg_gc_void_info)			\
      SymX(__stg_gc_enter_1)			\
      SymX(stg_gc_noregs)			\
      SymX(stg_gc_unpt_r1_info)			\
      SymX(stg_gc_unpt_r1)			\
      SymX(stg_gc_unbx_r1_info)			\
      SymX(stg_gc_unbx_r1)			\
      SymX(stg_gc_f1_info)			\
      SymX(stg_gc_f1)				\
      SymX(stg_gc_d1_info)			\
      SymX(stg_gc_d1)				\
      SymX(stg_gc_l1_info)			\
      SymX(stg_gc_l1)				\
      SymX(__stg_gc_fun)			\
      SymX(stg_gc_fun_info)			\
      SymX(stg_gc_gen)				\
      SymX(stg_gc_gen_info)			\
      SymX(stg_gc_gen_hp)			\
      SymX(stg_gc_ut)				\
      SymX(stg_gen_yield)			\
      SymX(stg_yield_noregs)			\
      SymX(stg_yield_to_interpreter)		\
      SymX(stg_gen_block)			\
      SymX(stg_block_noregs)			\
      SymX(stg_block_1)				\
      SymX(stg_block_takemvar)			\
      SymX(stg_block_putmvar)			\
      SymX(stg_seq_frame_info)			\
      MAIN_CAP_SYM                              \
      SymX(MallocFailHook)			\
      SymX(OnExitHook)				\
      SymX(OutOfHeapHook)			\
      SymX(StackOverflowHook)			\
      SymX(__encodeDouble)			\
      SymX(__encodeFloat)			\
      SymX(addDLL)               		\
      SymX(__gmpn_gcd_1)			\
      SymX(__gmpz_cmp)				\
      SymX(__gmpz_cmp_si)			\
      SymX(__gmpz_cmp_ui)			\
      SymX(__gmpz_get_si)			\
      SymX(__gmpz_get_ui)			\
      SymX(__int_encodeDouble)			\
      SymX(__int_encodeFloat)			\
      SymX(andIntegerzh_fast)			\
      SymX(atomicallyzh_fast)			\
      SymX(barf)				\
      SymX(debugBelch)				\
      SymX(errorBelch)				\
      SymX(blockAsyncExceptionszh_fast)		\
      SymX(catchzh_fast)			\
      SymX(catchRetryzh_fast)			\
      SymX(catchSTMzh_fast)			\
      SymX(closure_flags)                       \
      SymX(cmp_thread)				\
      SymX(cmpIntegerzh_fast)	        	\
      SymX(cmpIntegerIntzh_fast)	      	\
      SymX(complementIntegerzh_fast)		\
      SymX(createAdjustor)			\
      SymX(decodeDoublezh_fast)			\
      SymX(decodeFloatzh_fast)			\
      SymX(defaultsHook)			\
      SymX(delayzh_fast)			\
      SymX(deRefWeakzh_fast)			\
      SymX(deRefStablePtrzh_fast)		\
      SymX(divExactIntegerzh_fast)		\
      SymX(divModIntegerzh_fast)		\
      SymX(forkzh_fast)				\
      SymX(forkProcess)				\
      SymX(forkOS_createThread)			\
      SymX(freeHaskellFunctionPtr)		\
      SymX(freeStablePtr)		        \
      SymX(gcdIntegerzh_fast)			\
      SymX(gcdIntegerIntzh_fast)		\
      SymX(gcdIntzh_fast)			\
      SymX(genSymZh)				\
      SymX(genericRaise)			\
      SymX(getProgArgv)				\
      SymX(getStablePtr)			\
      SymX(hs_init)				\
      SymX(hs_exit)				\
      SymX(hs_set_argv)				\
      SymX(hs_add_root)				\
      SymX(hs_perform_gc)			\
      SymX(hs_free_stable_ptr)			\
      SymX(hs_free_fun_ptr)			\
      SymX(initLinker)				\
      SymX(int2Integerzh_fast)			\
      SymX(integer2Intzh_fast)			\
      SymX(integer2Wordzh_fast)			\
      SymX(isCurrentThreadBoundzh_fast)		\
      SymX(isDoubleDenormalized)		\
      SymX(isDoubleInfinite)			\
      SymX(isDoubleNaN)				\
      SymX(isDoubleNegativeZero)		\
      SymX(isEmptyMVarzh_fast)			\
      SymX(isFloatDenormalized)			\
      SymX(isFloatInfinite)			\
      SymX(isFloatNaN)				\
      SymX(isFloatNegativeZero)			\
      SymX(killThreadzh_fast)			\
      SymX(loadObj)          			\
      SymX(lookupSymbol)     			\
      SymX(makeStablePtrzh_fast)		\
      SymX(minusIntegerzh_fast)			\
      SymX(mkApUpd0zh_fast)			\
      SymX(myThreadIdzh_fast)			\
      SymX(labelThreadzh_fast)                  \
      SymX(newArrayzh_fast)			\
      SymX(newBCOzh_fast)			\
      SymX(newByteArrayzh_fast)			\
      SymX_redirect(newCAF, newDynCAF)		\
      SymX(newMVarzh_fast)			\
      SymX(newMutVarzh_fast)			\
      SymX(newTVarzh_fast)			\
      SymX(atomicModifyMutVarzh_fast)		\
      SymX(newPinnedByteArrayzh_fast)		\
      SymX(orIntegerzh_fast)			\
      SymX(performGC)				\
      SymX(performMajorGC)			\
      SymX(plusIntegerzh_fast)			\
      SymX(prog_argc)				\
      SymX(prog_argv)				\
      SymX(putMVarzh_fast)			\
      SymX(quotIntegerzh_fast)			\
      SymX(quotRemIntegerzh_fast)		\
      SymX(raisezh_fast)			\
      SymX(raiseIOzh_fast)			\
      SymX(readTVarzh_fast)			\
      SymX(remIntegerzh_fast)			\
      SymX(resetNonBlockingFd)			\
      SymX(resumeThread)			\
      SymX(resolveObjs)                         \
      SymX(retryzh_fast)                        \
      SymX(rts_apply)				\
      SymX(rts_checkSchedStatus)		\
      SymX(rts_eval)				\
      SymX(rts_evalIO)				\
      SymX(rts_evalLazyIO)			\
      SymX(rts_evalStableIO)			\
      SymX(rts_eval_)				\
      SymX(rts_getBool)				\
      SymX(rts_getChar)				\
      SymX(rts_getDouble)			\
      SymX(rts_getFloat)			\
      SymX(rts_getInt)				\
      SymX(rts_getInt32)			\
      SymX(rts_getPtr)				\
      SymX(rts_getFunPtr)			\
      SymX(rts_getStablePtr)			\
      SymX(rts_getThreadId)			\
      SymX(rts_getWord)				\
      SymX(rts_getWord32)			\
      SymX(rts_lock)				\
      SymX(rts_mkBool)				\
      SymX(rts_mkChar)				\
      SymX(rts_mkDouble)			\
      SymX(rts_mkFloat)				\
      SymX(rts_mkInt)				\
      SymX(rts_mkInt16)				\
      SymX(rts_mkInt32)				\
      SymX(rts_mkInt64)				\
      SymX(rts_mkInt8)				\
      SymX(rts_mkPtr)				\
      SymX(rts_mkFunPtr)			\
      SymX(rts_mkStablePtr)			\
      SymX(rts_mkString)			\
      SymX(rts_mkWord)				\
      SymX(rts_mkWord16)			\
      SymX(rts_mkWord32)			\
      SymX(rts_mkWord64)			\
      SymX(rts_mkWord8)				\
      SymX(rts_unlock)				\
      SymX(rtsSupportsBoundThreads)		\
      SymX(run_queue_hd)			\
      SymX(__hscore_get_saved_termios)		\
      SymX(__hscore_set_saved_termios)		\
      SymX(setProgArgv)				\
      SymX(startupHaskell)			\
      SymX(shutdownHaskell)			\
      SymX(shutdownHaskellAndExit)		\
      SymX(stable_ptr_table)			\
      SymX(stackOverflow)			\
      SymX(stg_CAF_BLACKHOLE_info)		\
      SymX(stg_BLACKHOLE_BQ_info)		\
      SymX(awakenBlockedQueue)			\
      SymX(stg_CHARLIKE_closure)		\
      SymX(stg_EMPTY_MVAR_info)			\
      SymX(stg_IND_STATIC_info)			\
      SymX(stg_INTLIKE_closure)			\
      SymX(stg_MUT_ARR_PTRS_FROZEN_info)	\
      SymX(stg_MUT_ARR_PTRS_FROZEN0_info)	\
      SymX(stg_WEAK_info)                       \
      SymX(stg_ap_0_info)			\
      SymX(stg_ap_v_info)			\
      SymX(stg_ap_f_info)			\
      SymX(stg_ap_d_info)			\
      SymX(stg_ap_l_info)			\
      SymX(stg_ap_n_info)			\
      SymX(stg_ap_p_info)			\
      SymX(stg_ap_pv_info)			\
      SymX(stg_ap_pp_info)			\
      SymX(stg_ap_ppv_info)			\
      SymX(stg_ap_ppp_info)			\
      SymX(stg_ap_pppv_info)			\
      SymX(stg_ap_pppp_info)			\
      SymX(stg_ap_ppppp_info)			\
      SymX(stg_ap_pppppp_info)			\
      SymX(stg_ap_1_upd_info)			\
      SymX(stg_ap_2_upd_info)			\
      SymX(stg_ap_3_upd_info)			\
      SymX(stg_ap_4_upd_info)			\
      SymX(stg_ap_5_upd_info)			\
      SymX(stg_ap_6_upd_info)			\
      SymX(stg_ap_7_upd_info)			\
      SymX(stg_exit)				\
      SymX(stg_sel_0_upd_info)			\
      SymX(stg_sel_10_upd_info)			\
      SymX(stg_sel_11_upd_info)			\
      SymX(stg_sel_12_upd_info)			\
      SymX(stg_sel_13_upd_info)			\
      SymX(stg_sel_14_upd_info)			\
      SymX(stg_sel_15_upd_info)			\
      SymX(stg_sel_1_upd_info)			\
      SymX(stg_sel_2_upd_info)			\
      SymX(stg_sel_3_upd_info)			\
      SymX(stg_sel_4_upd_info)			\
      SymX(stg_sel_5_upd_info)			\
      SymX(stg_sel_6_upd_info)			\
      SymX(stg_sel_7_upd_info)			\
      SymX(stg_sel_8_upd_info)			\
      SymX(stg_sel_9_upd_info)			\
      SymX(stg_upd_frame_info)			\
      SymX(suspendThread)			\
      SymX(takeMVarzh_fast)			\
      SymX(timesIntegerzh_fast)			\
      SymX(tryPutMVarzh_fast)			\
      SymX(tryTakeMVarzh_fast)			\
      SymX(unblockAsyncExceptionszh_fast)	\
      SymX(unloadObj)                           \
      SymX(unsafeThawArrayzh_fast)		\
      SymX(waitReadzh_fast)			\
      SymX(waitWritezh_fast)			\
      SymX(word2Integerzh_fast)			\
      SymX(writeTVarzh_fast)			\
      SymX(xorIntegerzh_fast)			\
      SymX(yieldzh_fast)

#ifdef SUPPORT_LONG_LONGS
#define RTS_LONG_LONG_SYMS			\
      SymX(int64ToIntegerzh_fast)		\
      SymX(word64ToIntegerzh_fast)
#else
#define RTS_LONG_LONG_SYMS /* nothing */
#endif

// 64-bit support functions in libgcc.a
#if defined(__GNUC__) && SIZEOF_VOID_P <= 4
#define RTS_LIBGCC_SYMBOLS			\
      Sym(__divdi3)                             \
      Sym(__udivdi3)                            \
      Sym(__moddi3)                             \
      Sym(__umoddi3)				\
      Sym(__muldi3)				\
      Sym(__ashldi3)				\
      Sym(__ashrdi3)				\
      Sym(__lshrdi3)				\
      Sym(__eprintf)
#elif defined(ia64_HOST_ARCH)
#define RTS_LIBGCC_SYMBOLS			\
      Sym(__divdi3)				\
      Sym(__udivdi3)                            \
      Sym(__moddi3)				\
      Sym(__umoddi3)				\
      Sym(__divsf3)				\
      Sym(__divdf3)
#else
#define RTS_LIBGCC_SYMBOLS
#endif

#ifdef darwin_HOST_OS
      // Symbols that don't have a leading underscore
      // on Mac OS X. They have to receive special treatment,
      // see machoInitSymbolsWithoutUnderscore()
#define RTS_MACHO_NOUNDERLINE_SYMBOLS		\
      Sym(saveFP)				\
      Sym(restFP)
#endif

/* entirely bogus claims about types of these symbols */
#define Sym(vvv)  extern void vvv(void);
#define SymX(vvv) /**/
#define SymX_redirect(vvv,xxx) /**/
RTS_SYMBOLS
RTS_RET_SYMBOLS
RTS_LONG_LONG_SYMS
RTS_POSIX_ONLY_SYMBOLS
RTS_MINGW_ONLY_SYMBOLS
RTS_CYGWIN_ONLY_SYMBOLS
RTS_LIBGCC_SYMBOLS
#undef Sym
#undef SymX
#undef SymX_redirect

#ifdef LEADING_UNDERSCORE
#define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
#else
#define MAYBE_LEADING_UNDERSCORE_STR(s) (s)
#endif

#define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
                    (void*)(&(vvv)) },
#define SymX(vvv) Sym(vvv)

// SymX_redirect allows us to redirect references to one symbol to
// another symbol.  See newCAF/newDynCAF for an example.
#define SymX_redirect(vvv,xxx) \
    { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
      (void*)(&(xxx)) },

static RtsSymbolVal rtsSyms[] = {
      RTS_SYMBOLS
      RTS_RET_SYMBOLS
      RTS_LONG_LONG_SYMS
      RTS_POSIX_ONLY_SYMBOLS
      RTS_MINGW_ONLY_SYMBOLS
      RTS_CYGWIN_ONLY_SYMBOLS
      RTS_LIBGCC_SYMBOLS
      { 0, 0 } /* sentinel */
};

/* -----------------------------------------------------------------------------
 * Insert symbols into hash tables, checking for duplicates.
 */
static void ghciInsertStrHashTable ( char* obj_name,
                                     HashTable *table,
                                     char* key,
                                     void *data
				   )
{
   if (lookupHashTable(table, (StgWord)key) == NULL)
   {
      insertStrHashTable(table, (StgWord)key, data);
      return;
   }
   debugBelch(
      "\n\n"
      "GHCi runtime linker: fatal error: I found a duplicate definition for symbol\n"
      "   %s\n"
      "whilst processing object file\n"
      "   %s\n"
      "This could be caused by:\n"
      "   * Loading two different object files which export the same symbol\n"
      "   * Specifying the same object file twice on the GHCi command line\n"
      "   * An incorrect `package.conf' entry, causing some object to be\n"
      "     loaded twice.\n"
      "GHCi cannot safely continue in this situation.  Exiting now.  Sorry.\n"
      "\n",
      (char*)key,
      obj_name
   );
   exit(1);
}


/* -----------------------------------------------------------------------------
 * initialize the object linker
 */


static int linker_init_done = 0 ;

#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
static void *dl_prog_handle;
#endif

/* dlopen(NULL,..) doesn't work so we grab libc explicitly */
#if defined(openbsd_HOST_OS)
static void *dl_libc_handle;
#endif

void
initLinker( void )
{
    RtsSymbolVal *sym;

    /* Make initLinker idempotent, so we can call it
       before evey relevant operation; that means we
       don't need to initialise the linker separately */
    if (linker_init_done == 1) { return; } else {
      linker_init_done = 1;
    }

    symhash = allocStrHashTable();

    /* populate the symbol table with stuff from the RTS */
    for (sym = rtsSyms; sym->lbl != NULL; sym++) {
	ghciInsertStrHashTable("(GHCi built-in symbols)",
                               symhash, sym->lbl, sym->addr);
    }
#   if defined(OBJFORMAT_MACHO)
    machoInitSymbolsWithoutUnderscore();
#   endif

#   if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
#   if defined(RTLD_DEFAULT)
    dl_prog_handle = RTLD_DEFAULT;
#   else
    dl_prog_handle = dlopen(NULL, RTLD_LAZY);
#   if defined(openbsd_HOST_OS)
    dl_libc_handle = dlopen("libc.so", RTLD_LAZY);
#   endif
#   endif // RTLD_DEFAULT
#   endif
}

/* -----------------------------------------------------------------------------
 *                  Loading DLL or .so dynamic libraries
 * -----------------------------------------------------------------------------
 *
 * Add a DLL from which symbols may be found.  In the ELF case, just
 * do RTLD_GLOBAL-style add, so no further messing around needs to
 * happen in order that symbols in the loaded .so are findable --
 * lookupSymbol() will subsequently see them by dlsym on the program's
 * dl-handle.  Returns NULL if success, otherwise ptr to an err msg.
 *
 * In the PEi386 case, open the DLLs and put handles to them in a
 * linked list.  When looking for a symbol, try all handles in the
 * list.  This means that we need to load even DLLs that are guaranteed
 * to be in the ghc.exe image already, just so we can get a handle
 * to give to loadSymbol, so that we can find the symbols.  For such
 * libraries, the LoadLibrary call should be a no-op except for returning
 * the handle.
 *
 */

#if defined(OBJFORMAT_PEi386)
/* A record for storing handles into DLLs. */

typedef
   struct _OpenedDLL {
      char*              name;
      struct _OpenedDLL* next;
      HINSTANCE instance;
   }
   OpenedDLL;

/* A list thereof. */
static OpenedDLL* opened_dlls = NULL;
#endif

char *
addDLL( char *dll_name )
{
#  if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
   /* ------------------- ELF DLL loader ------------------- */
   void *hdl;
   char *errmsg;

   // *** HACK
   // If we load libHSbase_cbits_dyn.[so|dylib],
   // then we know that we need to activate another newCAF
   // related hack in Storage.c because we can't redirect
   // newCAF to newDynCAF with the system dynamic linker.
#ifdef OBJFORMAT_MACHO
   const char *hsbase = "/libHSbase_cbits_dyn.dylib";
#else
   const char *hsbase = "/libHSbase_cbits_dyn.so";
#endif
   int namelen = strlen(dll_name);
   int baselen = strlen(hsbase);
   if(namelen > baselen && !strcmp(dll_name + namelen - baselen, hsbase))
   {
      keepCAFs = rtsTrue;
   }
   // *** END HACK.

   initLinker();

   hdl= dlopen(dll_name, RTLD_NOW | RTLD_GLOBAL);

   if (hdl == NULL) {
      /* dlopen failed; return a ptr to the error msg. */
      errmsg = dlerror();
      if (errmsg == NULL) errmsg = "addDLL: unknown error";
      return errmsg;
   } else {
      return NULL;
   }
   /*NOTREACHED*/

#  elif defined(OBJFORMAT_PEi386)
   /* ------------------- Win32 DLL loader ------------------- */

   char*      buf;
   OpenedDLL* o_dll;
   HINSTANCE  instance;

   initLinker();

   /* debugBelch("\naddDLL; dll_name = `%s'\n", dll_name); */

   /* See if we've already got it, and ignore if so. */
   for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
      if (0 == strcmp(o_dll->name, dll_name))
         return NULL;
   }

   /* The file name has no suffix (yet) so that we can try
      both foo.dll and foo.drv

      The documentation for LoadLibrary says:
      	If no file name extension is specified in the lpFileName
      	parameter, the default library extension .dll is
      	appended. However, the file name string can include a trailing
      	point character (.) to indicate that the module name has no
      	extension. */

   buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
   sprintf(buf, "%s.DLL", dll_name);
   instance = LoadLibrary(buf);
   if (instance == NULL) {
	 sprintf(buf, "%s.DRV", dll_name);	// KAA: allow loading of drivers (like winspool.drv)
	 instance = LoadLibrary(buf);
	 if (instance == NULL) {
		stgFree(buf);

	    /* LoadLibrary failed; return a ptr to the error msg. */
	    return "addDLL: unknown error";
   	 }
   }
   stgFree(buf);

   /* Add this DLL to the list of DLLs in which to search for symbols. */
   o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
   o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
   strcpy(o_dll->name, dll_name);
   o_dll->instance = instance;
   o_dll->next     = opened_dlls;
   opened_dlls     = o_dll;

   return NULL;
#  else
   barf("addDLL: not implemented on this platform");
#  endif
}

/* -----------------------------------------------------------------------------
 * lookup a symbol in the hash table
 */
void *
lookupSymbol( char *lbl )
{
    void *val;
    initLinker() ;
    ASSERT(symhash != NULL);
    val = lookupStrHashTable(symhash, lbl);

    if (val == NULL) {
#       if defined(OBJFORMAT_ELF)
#	if defined(openbsd_HOST_OS)
	val = dlsym(dl_prog_handle, lbl);
	return (val != NULL) ? val : dlsym(dl_libc_handle,lbl);
#	else /* not openbsd */
	return dlsym(dl_prog_handle, lbl);
#	endif
#       elif defined(OBJFORMAT_MACHO)
	if(NSIsSymbolNameDefined(lbl)) {
	    NSSymbol symbol = NSLookupAndBindSymbol(lbl);
	    return NSAddressOfSymbol(symbol);
	} else {
	    return NULL;
	}
#       elif defined(OBJFORMAT_PEi386)
        OpenedDLL* o_dll;
        void* sym;
        for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
	  /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
           if (lbl[0] == '_') {
              /* HACK: if the name has an initial underscore, try stripping
                 it off & look that up first. I've yet to verify whether there's
                 a Rule that governs whether an initial '_' *should always* be
                 stripped off when mapping from import lib name to the DLL name.
              */
              sym = GetProcAddress(o_dll->instance, (lbl+1));
              if (sym != NULL) {
		/*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
		return sym;
	      }
           }
           sym = GetProcAddress(o_dll->instance, lbl);
           if (sym != NULL) {
	     /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
	     return sym;
	   }
        }
        return NULL;
#       else
        ASSERT(2+2 == 5);
        return NULL;
#       endif
    } else {
	return val;
    }
}

static
__attribute((unused))
void *
lookupLocalSymbol( ObjectCode* oc, char *lbl )
{
    void *val;
    initLinker() ;
    val = lookupStrHashTable(oc->lochash, lbl);

    if (val == NULL) {
        return NULL;
    } else {
	return val;
    }
}


/* -----------------------------------------------------------------------------
 * Debugging aid: look in GHCi's object symbol tables for symbols
 * within DELTA bytes of the specified address, and show their names.
 */
#ifdef DEBUG
void ghci_enquire ( char* addr );

void ghci_enquire ( char* addr )
{
   int   i;
   char* sym;
   char* a;
   const int DELTA = 64;
   ObjectCode* oc;

   initLinker();

   for (oc = objects; oc; oc = oc->next) {
      for (i = 0; i < oc->n_symbols; i++) {
         sym = oc->symbols[i];
         if (sym == NULL) continue;
         // debugBelch("enquire %p %p\n", sym, oc->lochash);
         a = NULL;
         if (oc->lochash != NULL) {
            a = lookupStrHashTable(oc->lochash, sym);
	 }
         if (a == NULL) {
            a = lookupStrHashTable(symhash, sym);
	 }
         if (a == NULL) {
	     // debugBelch("ghci_enquire: can't find %s\n", sym);
         }
         else if (addr-DELTA <= a && a <= addr+DELTA) {
            debugBelch("%p + %3d  ==  `%s'\n", addr, a - addr, sym);
         }
      }
   }
}
#endif

#ifdef ia64_HOST_ARCH
static unsigned int PLTSize(void);
#endif

/* -----------------------------------------------------------------------------
 * Load an obj (populate the global symbol table, but don't resolve yet)
 *
 * Returns: 1 if ok, 0 on error.
 */
HsInt
loadObj( char *path )
{
   ObjectCode* oc;
   struct stat st;
   int r, n;
#ifdef USE_MMAP
   int fd, pagesize;
   void *map_addr = NULL;
#else
   FILE *f;
#endif

   initLinker();

   /* debugBelch("loadObj %s\n", path ); */

   /* Check that we haven't already loaded this object. 
      Ignore requests to load multiple times */
   {
       ObjectCode *o;
       int is_dup = 0;
       for (o = objects; o; o = o->next) {
          if (0 == strcmp(o->fileName, path)) {
             is_dup = 1;
             break; /* don't need to search further */
          }
       }
       if (is_dup) {
          IF_DEBUG(linker, debugBelch(
            "GHCi runtime linker: warning: looks like you're trying to load the\n"
            "same object file twice:\n"
            "   %s\n"
            "GHCi will ignore this, but be warned.\n"
            , path));
          return 1; /* success */
       }
   }

   oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");

#  if defined(OBJFORMAT_ELF)
   oc->formatName = "ELF";
#  elif defined(OBJFORMAT_PEi386)
   oc->formatName = "PEi386";
#  elif defined(OBJFORMAT_MACHO)
   oc->formatName = "Mach-O";
#  else
   stgFree(oc);
   barf("loadObj: not implemented on this platform");
#  endif

   r = stat(path, &st);
   if (r == -1) { return 0; }

   /* sigh, strdup() isn't a POSIX function, so do it the long way */
   oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
   strcpy(oc->fileName, path);

   oc->fileSize          = st.st_size;
   oc->symbols           = NULL;
   oc->sections          = NULL;
   oc->lochash           = allocStrHashTable();
   oc->proddables        = NULL;

   /* chain it onto the list of objects */
   oc->next              = objects;
   objects               = oc;

#ifdef USE_MMAP
#define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))

   /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */

#if defined(openbsd_HOST_OS)
   fd = open(path, O_RDONLY, S_IRUSR);
#else
   fd = open(path, O_RDONLY);
#endif
   if (fd == -1)
      barf("loadObj: can't open `%s'", path);

   pagesize = getpagesize();

#ifdef ia64_HOST_ARCH
   /* The PLT needs to be right before the object */
   n = ROUND_UP(PLTSize(), pagesize);
   oc->plt = mmap(NULL, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
   if (oc->plt == MAP_FAILED)
      barf("loadObj: can't allocate PLT");

   oc->pltIndex = 0;
   map_addr = oc->plt + n;
#endif

   n = ROUND_UP(oc->fileSize, pagesize);
   oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE, fd, 0);
   if (oc->image == MAP_FAILED)
      barf("loadObj: can't map `%s'", path);

   close(fd);

#else /* !USE_MMAP */

   oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");

   /* load the image into memory */
   f = fopen(path, "rb");
   if (!f)
       barf("loadObj: can't read `%s'", path);

   n = fread ( oc->image, 1, oc->fileSize, f );
   if (n != oc->fileSize)
      barf("loadObj: error whilst reading `%s'", path);

   fclose(f);

#endif /* USE_MMAP */

#  if defined(OBJFORMAT_MACHO)
   r = ocAllocateJumpIslands_MachO ( oc );
   if (!r) { return r; }
#  elif defined(OBJFORMAT_ELF) && defined(powerpc_HOST_ARCH)
   r = ocAllocateJumpIslands_ELF ( oc );
   if (!r) { return r; }
#endif

   /* verify the in-memory image */
#  if defined(OBJFORMAT_ELF)
   r = ocVerifyImage_ELF ( oc );
#  elif defined(OBJFORMAT_PEi386)
   r = ocVerifyImage_PEi386 ( oc );
#  elif defined(OBJFORMAT_MACHO)
   r = ocVerifyImage_MachO ( oc );
#  else
   barf("loadObj: no verify method");
#  endif
   if (!r) { return r; }

   /* build the symbol list for this image */
#  if defined(OBJFORMAT_ELF)
   r = ocGetNames_ELF ( oc );
#  elif defined(OBJFORMAT_PEi386)
   r = ocGetNames_PEi386 ( oc );
#  elif defined(OBJFORMAT_MACHO)
   r = ocGetNames_MachO ( oc );