<commit_before>/* -----------------------------------------------------------------------------
 * Foreign export adjustor thunks
 *
 * Copyright (c) 1998.
 *
 * ---------------------------------------------------------------------------*/

/* A little bit of background...

An adjustor thunk is a dynamically allocated code snippet that allows
Haskell closures to be viewed as C function pointers. 

Stable pointers provide a way for the outside world to get access to,
and evaluate, Haskell heap objects, with the RTS providing a small
range of ops for doing so. So, assuming we've got a stable pointer in
our hand in C, we can jump into the Haskell world and evaluate a callback
procedure, say. This works OK in some cases where callbacks are used, but
does require the external code to know about stable pointers and how to deal
with them. We'd like to hide the Haskell-nature of a callback and have it
be invoked just like any other C function pointer. 

Enter adjustor thunks. An adjustor thunk is a little piece of code
that's generated on-the-fly (one per Haskell closure being exported)
that, when entered using some 'universal' calling convention (e.g., the
C calling convention on platform X), pushes an implicit stable pointer
(to the Haskell callback) before calling another (static) C function stub
which takes care of entering the Haskell code via its stable pointer.

An adjustor thunk is allocated on the C heap, and is called from within
Haskell just before handing out the function pointer to the Haskell (IO)
action. User code should never have to invoke it explicitly.

An adjustor thunk differs from a C function pointer in one respect: when
the code is through with it, it has to be freed in order to release Haskell
and C resources. Failure to do so result in memory leaks on both the C and
Haskell side.
*/

#include "PosixSource.h"
#include "Rts.h"
#include "RtsExternal.h"
#include "RtsUtils.h"
#include <stdlib.h>

#if defined(_WIN32)
#include <windows.h>
#endif

#if defined(openbsd_TARGET_OS)
#include <unistd.h>
#include <sys/types.h>
#include <sys/mman.h>

/* no C99 header stdint.h on OpenBSD? */
typedef unsigned long my_uintptr_t;
#endif

#if defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS)
#include <string.h>
#endif

/* Heavily arch-specific, I'm afraid.. */

/*
 * Allocate len bytes which are readable, writable, and executable.
 *
 * ToDo: If this turns out to be a performance bottleneck, one could
 * e.g. cache the last VirtualProtect/mprotect-ed region and do
 * nothing in case of a cache hit.
 */
static void*
mallocBytesRWX(int len)
{
  void *addr = stgMallocBytes(len, "mallocBytesRWX");
#if defined(i386_TARGET_ARCH) && defined(_WIN32)
  /* This could be necessary for processors which distinguish between READ and
     EXECUTE memory accesses, e.g. Itaniums. */
  DWORD dwOldProtect = 0;
  if (VirtualProtect (addr, len, PAGE_EXECUTE_READWRITE, &dwOldProtect) == 0) {
    barf("mallocBytesRWX: failed to protect 0x%p; error=%lu; old protection: %lu\n",
         addr, (unsigned long)GetLastError(), (unsigned long)dwOldProtect);
  }
#elif defined(openbsd_TARGET_OS)
  /* malloced memory isn't executable by default on OpenBSD */
  my_uintptr_t pageSize         = sysconf(_SC_PAGESIZE);
  my_uintptr_t mask             = ~(pageSize - 1);
  my_uintptr_t startOfFirstPage = ((my_uintptr_t)addr          ) & mask;
  my_uintptr_t startOfLastPage  = ((my_uintptr_t)addr + len - 1) & mask;
  my_uintptr_t size             = startOfLastPage - startOfFirstPage + pageSize;
  if (mprotect((void*)startOfFirstPage, (size_t)size, PROT_EXEC | PROT_READ | PROT_WRITE) != 0) {
    barf("mallocBytesRWX: failed to protect 0x%p\n", addr);
  }
#endif
  return addr;
}

#if defined(i386_TARGET_ARCH)
static unsigned char *obscure_ccall_ret_code;
#endif

#if defined(alpha_TARGET_ARCH)
/* To get the definition of PAL_imb: */
# if defined(linux_TARGET_OS)
#  include <asm/pal.h>
# else
#  include <machine/pal.h>
# endif
#endif

#if defined(ia64_TARGET_ARCH)
#include "Storage.h"

/* Layout of a function descriptor */
typedef struct _IA64FunDesc {
    StgWord64 ip;
    StgWord64 gp;
} IA64FunDesc;

static void *
stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
{
  StgArrWords* arr;
  nat data_size_in_words, total_size_in_words;
  
  /* round up to a whole number of words */
  data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
  total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
  
  /* allocate and fill it in */
  arr = (StgArrWords *)allocate(total_size_in_words);
  SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 
  /* obtain a stable ptr */
  *stable = getStablePtr((StgPtr)arr);

  /* and return a ptr to the goods inside the array */
  return(BYTE_ARR_CTS(arr));
}
#endif

#if defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS)
__asm__("obscure_ccall_ret_code:\n\t"
        "lwz 1,0(1)\n\t"
        "lwz 0,4(1)\n\t"
        "mtlr 0\n\t"
        "blr");
extern void obscure_ccall_ret_code(void);
#endif

#if defined(powerpc_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
#if !(defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS))

/* !!! !!! WARNING: !!! !!!
 * This structure is accessed from AdjustorAsm.s
 * Any changes here have to be mirrored in the offsets there.
 */

typedef struct AdjustorStub {
#if defined(powerpc_TARGET_ARCH) && defined(darwin_TARGET_OS)
    unsigned        lis;
    unsigned        ori;
    unsigned        lwz;
    unsigned        mtctr;
    unsigned        bctr;
    StgFunPtr       code;
#elif defined(powerpc64_TARGET_ARCH) && defined(darwin_TARGET_OS)
        /* powerpc64-darwin: just guessing that it won't use fundescs. */
    unsigned        lis;
    unsigned        ori;
    unsigned        rldimi;
    unsigned        oris;
    unsigned        ori2;
    unsigned        lwz;
    unsigned        mtctr;
    unsigned        bctr;
    StgFunPtr       code;
#else
        /* fundesc-based ABIs */
#define         FUNDESCS
    StgFunPtr       code;
    struct AdjustorStub
                    *toc;
    void            *env;
#endif
    StgStablePtr    hptr;
    StgFunPtr       wptr;
    StgInt          negative_framesize;
    StgInt          extrawords_plus_one;
} AdjustorStub;

#endif
#endif

void*
createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr, char *typeString)
{
  void *adjustor = NULL;

  switch (cconv)
  {
  case 0: /* _stdcall */
#if defined(i386_TARGET_ARCH)
    /* Magic constant computed by inspecting the code length of
       the following assembly language snippet
       (offset and machine code prefixed):

     <0>:	58	          popl   %eax              # temp. remove ret addr..
     <1>:	68 fd fc fe fa    pushl  0xfafefcfd  	   # constant is large enough to<commit_msg>[project @ 2005-01-20 14:30:17 by simonmar] Avoid a warning<commit_after>/* -----------------------------------------------------------------------------
 * Foreign export adjustor thunks
 *
 * Copyright (c) 1998.
 *
 * ---------------------------------------------------------------------------*/

/* A little bit of background...

An adjustor thunk is a dynamically allocated code snippet that allows
Haskell closures to be viewed as C function pointers. 

Stable pointers provide a way for the outside world to get access to,
and evaluate, Haskell heap objects, with the RTS providing a small
range of ops for doing so. So, assuming we've got a stable pointer in
our hand in C, we can jump into the Haskell world and evaluate a callback
procedure, say. This works OK in some cases where callbacks are used, but
does require the external code to know about stable pointers and how to deal
with them. We'd like to hide the Haskell-nature of a callback and have it
be invoked just like any other C function pointer. 

Enter adjustor thunks. An adjustor thunk is a little piece of code
that's generated on-the-fly (one per Haskell closure being exported)
that, when entered using some 'universal' calling convention (e.g., the
C calling convention on platform X), pushes an implicit stable pointer
(to the Haskell callback) before calling another (static) C function stub
which takes care of entering the Haskell code via its stable pointer.

An adjustor thunk is allocated on the C heap, and is called from within
Haskell just before handing out the function pointer to the Haskell (IO)
action. User code should never have to invoke it explicitly.

An adjustor thunk differs from a C function pointer in one respect: when
the code is through with it, it has to be freed in order to release Haskell
and C resources. Failure to do so result in memory leaks on both the C and
Haskell side.
*/

#include "PosixSource.h"
#include "Rts.h"
#include "RtsExternal.h"
#include "RtsUtils.h"
#include <stdlib.h>

#if defined(_WIN32)
#include <windows.h>
#endif

#if defined(openbsd_TARGET_OS)
#include <unistd.h>
#include <sys/types.h>
#include <sys/mman.h>

/* no C99 header stdint.h on OpenBSD? */
typedef unsigned long my_uintptr_t;
#endif

#if defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS)
#include <string.h>
#endif

/* Heavily arch-specific, I'm afraid.. */

/*
 * Allocate len bytes which are readable, writable, and executable.
 *
 * ToDo: If this turns out to be a performance bottleneck, one could
 * e.g. cache the last VirtualProtect/mprotect-ed region and do
 * nothing in case of a cache hit.
 */
static void*
mallocBytesRWX(int len)
{
  void *addr = stgMallocBytes(len, "mallocBytesRWX");
#if defined(i386_TARGET_ARCH) && defined(_WIN32)
  /* This could be necessary for processors which distinguish between READ and
     EXECUTE memory accesses, e.g. Itaniums. */
  DWORD dwOldProtect = 0;
  if (VirtualProtect (addr, len, PAGE_EXECUTE_READWRITE, &dwOldProtect) == 0) {
    barf("mallocBytesRWX: failed to protect 0x%p; error=%lu; old protection: %lu\n",
         addr, (unsigned long)GetLastError(), (unsigned long)dwOldProtect);
  }
#elif defined(openbsd_TARGET_OS)
  /* malloced memory isn't executable by default on OpenBSD */
  my_uintptr_t pageSize         = sysconf(_SC_PAGESIZE);
  my_uintptr_t mask             = ~(pageSize - 1);
  my_uintptr_t startOfFirstPage = ((my_uintptr_t)addr          ) & mask;
  my_uintptr_t startOfLastPage  = ((my_uintptr_t)addr + len - 1) & mask;
  my_uintptr_t size             = startOfLastPage - startOfFirstPage + pageSize;
  if (mprotect((void*)startOfFirstPage, (size_t)size, PROT_EXEC | PROT_READ | PROT_WRITE) != 0) {
    barf("mallocBytesRWX: failed to protect 0x%p\n", addr);
  }
#endif
  return addr;
}

#if defined(i386_TARGET_ARCH)
static unsigned char *obscure_ccall_ret_code;
#endif

#if defined(alpha_TARGET_ARCH)
/* To get the definition of PAL_imb: */
# if defined(linux_TARGET_OS)
#  include <asm/pal.h>
# else
#  include <machine/pal.h>
# endif
#endif

#if defined(ia64_TARGET_ARCH)
#include "Storage.h"

/* Layout of a function descriptor */
typedef struct _IA64FunDesc {
    StgWord64 ip;
    StgWord64 gp;
} IA64FunDesc;

static void *
stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
{
  StgArrWords* arr;
  nat data_size_in_words, total_size_in_words;
  
  /* round up to a whole number of words */
  data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
  total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
  
  /* allocate and fill it in */
  arr = (StgArrWords *)allocate(total_size_in_words);
  SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 
  /* obtain a stable ptr */
  *stable = getStablePtr((StgPtr)arr);

  /* and return a ptr to the goods inside the array */
  return(BYTE_ARR_CTS(arr));
}
#endif

#if defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS)
__asm__("obscure_ccall_ret_code:\n\t"
        "lwz 1,0(1)\n\t"
        "lwz 0,4(1)\n\t"
        "mtlr 0\n\t"
        "blr");
extern void obscure_ccall_ret_code(void);
#endif

#if defined(powerpc_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
#if !(defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS))

/* !!! !!! WARNING: !!! !!!
 * This structure is accessed from AdjustorAsm.s
 * Any changes here have to be mirrored in the offsets there.
 */

typedef struct AdjustorStub {
#if defined(powerpc_TARGET_ARCH) && defined(darwin_TARGET_OS)
    unsigned        lis;
    unsigned        ori;
    unsigned        lwz;
    unsigned        mtctr;
    unsigned        bctr;
    StgFunPtr       code;
#elif defined(powerpc64_TARGET_ARCH) && defined(darwin_TARGET_OS)
        /* powerpc64-darwin: just guessing that it won't use fundescs. */
    unsigned        lis;
    unsigned        ori;
    unsigned        rldimi;
    unsigned        oris;
    unsigned        ori2;
    unsigned        lwz;
    unsigned        mtctr;
    unsigned        bctr;
    StgFunPtr       code;
#else
        /* fundesc-based ABIs */
#define         FUNDESCS
    StgFunPtr       code;
    struct AdjustorStub
                    *toc;
    void            *env;
#endif
    StgStablePtr    hptr;
    StgFunPtr       wptr;
    StgInt          negative_framesize;
    StgInt          extrawords_plus_one;
} AdjustorStub;

#endif
#endif

void*
createAdjustor(int cconv, StgStablePtr hptr,
	       StgFunPtr wptr,
	       char *typeString
#if !defined(powerpc_TARGET_ARCH) && !defined(powerpc64_TARGET_ARCH)
	          STG_UNUSED
#endif
              )
{
  void *adjustor = NULL;

  switch (cconv)
  {
  case 0: /* _stdcall */
#if defined(i386_TARGET_ARCH)
    /* Magic constant computed by inspecting the code length of
       the following assembly language snippet
       (offset and machine code prefixed):

     <0>:	58	          popl   %eax              # temp. remove ret addr..
     <1>:	68 fd fc fe fa    pushl  0xfafefcfd  	   # constant is large enough to
{'fraction_non_alphanumeric': 0.10817710992778466, 'fraction_numerical': 0.009774600627325115, 'mean_word_length': 3.0694568121104187, 'pattern_counts': {'":': 0, '<': 23, '<?xml version=': 0, '>': 23, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1829975', 'n_tokens_mistral': 4605, 'n_tokens_neox': 4332, 'n_words': 1471}