* ---------------------------------------------------------------------------*/
/* 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.
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
+and C resources. Failure to do so will 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>
+#include "Stable.h"
+
+#if defined(USE_LIBFFI_FOR_ADJUSTORS)
+#include "ffi.h"
+#include <string.h>
+#endif
+
+#if defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)
+extern void adjustorCode(void);
+#elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
+// from AdjustorAsm.s
+// not declared as a function so that AIX-style
+// fundescs can never get in the way.
+extern void *adjustorCode;
+#endif
+
+#if defined(USE_LIBFFI_FOR_ADJUSTORS)
+void
+freeHaskellFunctionPtr(void* ptr)
+{
+ ffi_closure *cl;
+
+ cl = (ffi_closure*)ptr;
+ freeStablePtr(cl->user_data);
+ stgFree(cl->cif->arg_types);
+ stgFree(cl->cif);
+ freeExec(cl);
+}
+
+static ffi_type * char_to_ffi_type(char c)
+{
+ switch (c) {
+ case 'v': return &ffi_type_void;
+ case 'f': return &ffi_type_float;
+ case 'd': return &ffi_type_double;
+ case 'L': return &ffi_type_sint64;
+ case 'l': return &ffi_type_uint64;
+ case 'W': return &ffi_type_sint32;
+ case 'w': return &ffi_type_uint32;
+ case 'S': return &ffi_type_sint16;
+ case 's': return &ffi_type_uint16;
+ case 'B': return &ffi_type_sint8;
+ case 'b': return &ffi_type_uint8;
+ case 'p': return &ffi_type_pointer;
+ default: barf("char_to_ffi_type: unknown type '%c'", c);
+ }
+}
+
+void*
+createAdjustor (int cconv,
+ StgStablePtr hptr,
+ StgFunPtr wptr,
+ char *typeString)
+{
+ ffi_cif *cif;
+ ffi_type **arg_types;
+ nat n_args, i;
+ ffi_type *result_type;
+ ffi_closure *cl;
+ int r, abi;
+ void *code;
+
+ n_args = strlen(typeString) - 1;
+ cif = stgMallocBytes(sizeof(ffi_cif), "createAdjustor");
+ arg_types = stgMallocBytes(n_args * sizeof(ffi_type*), "createAdjustor");
+
+ result_type = char_to_ffi_type(typeString[0]);
+ for (i=0; i < n_args; i++) {
+ arg_types[i] = char_to_ffi_type(typeString[i+1]);
+ }
+ switch (cconv) {
+#ifdef mingw32_HOST_OS
+ case 0: /* stdcall */
+ abi = FFI_STDCALL;
+ break;
+#endif
+ case 1: /* ccall */
+ abi = FFI_DEFAULT_ABI;
+ break;
+ default:
+ barf("createAdjustor: convention %d not supported on this platform", cconv);
+ }
+
+ r = ffi_prep_cif(cif, abi, n_args, result_type, arg_types);
+ if (r != FFI_OK) barf("ffi_prep_cif failed: %d", r);
+
+ cl = allocateExec(sizeof(ffi_closure), &code);
+ if (cl == NULL) {
+ barf("createAdjustor: failed to allocate memory");
+ }
+
+ r = ffi_prep_closure(cl, cif, (void*)wptr, hptr/*userdata*/);
+ if (r != FFI_OK) barf("ffi_prep_closure failed: %d", r);
+
+ return (void*)code;
+}
+
+#else // To end of file...
#if defined(_WIN32)
#include <windows.h>
}
extern void obscure_ccall_ret_code(void);
-#if defined(openbsd_HOST_OS)
-static unsigned char *obscure_ccall_ret_code_dyn;
-#endif
-
#endif
#if defined(x86_64_HOST_ARCH)
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_);
+ data_size_in_words = ROUNDUP_BYTES_TO_WDS(size_in_bytes);
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);
+ SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, size_in_bytes);
/* obtain a stable ptr */
*stable = getStablePtr((StgPtr)arr);
} AdjustorStub;
#endif
-#if defined(darwin_HOST_OS) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
+#if (defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
static int totalArgumentSize(char *typeString)
{
int sz = 0;
// on 32-bit platforms, Double and Int64 occupy two words.
case 'd':
case 'l':
+ case 'L':
if(sizeof(void*) == 4)
{
sz += 2;
)
{
void *adjustor = NULL;
+ void *code;
switch (cconv)
{
<c>: ff e0 jmp %eax # and jump to it.
# the callee cleans up the stack
*/
- adjustor = allocateExec(14);
+ adjustor = allocateExec(14,&code);
{
unsigned char *const adj_code = (unsigned char *)adjustor;
adj_code[0x00] = (unsigned char)0x58; /* popl %eax */
That's (thankfully) the case here with the restricted set of
return types that we support.
*/
- adjustor = allocateExec(17);
+ adjustor = allocateExec(17,&code);
{
unsigned char *const adj_code = (unsigned char *)adjustor;
adj_code[0x0a] = (unsigned char)0x68; /* pushl obscure_ccall_ret_code */
*((StgFunPtr*)(adj_code + 0x0b)) =
-#if !defined(openbsd_HOST_OS)
(StgFunPtr)obscure_ccall_ret_code;
-#else
- (StgFunPtr)obscure_ccall_ret_code_dyn;
-#endif
adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
adj_code[0x10] = (unsigned char)0xe0;
We offload most of the work to AdjustorAsm.S.
*/
- AdjustorStub *adjustorStub = allocateExec(sizeof(AdjustorStub));
+ AdjustorStub *adjustorStub = allocateExec(sizeof(AdjustorStub),&code);
adjustor = adjustorStub;
- extern void adjustorCode(void);
int sz = totalArgumentSize(typeString);
adjustorStub->call[0] = 0xe8;
38: .quad 0 # aligned on 8-byte boundary
*/
- /* we assume the small code model (gcc -mcmmodel=small) where
- * all symbols are <2^32, so hence wptr should fit into 32 bits.
- */
- ASSERT(((long)wptr >> 32) == 0);
-
{
int i = 0;
char *c;
+ StgWord8 *adj_code;
// determine whether we have 6 or more integer arguments,
// and therefore need to flush one to the stack.
for (c = typeString; *c != '\0'; c++) {
- if (*c == 'i' || *c == 'l') i++;
+ if (*c != 'f' && *c != 'd') i++;
if (i == 6) break;
}
if (i < 6) {
- adjustor = allocateExec(0x30);
-
- *(StgInt32 *)adjustor = 0x49c1894d;
- *(StgInt32 *)(adjustor+0x4) = 0x8948c889;
- *(StgInt32 *)(adjustor+0x8) = 0xf28948d1;
- *(StgInt32 *)(adjustor+0xc) = 0x48fe8948;
- *(StgInt32 *)(adjustor+0x10) = 0x000a3d8b;
- *(StgInt32 *)(adjustor+0x14) = 0x25ff0000;
- *(StgInt32 *)(adjustor+0x18) = 0x0000000c;
- *(StgInt64 *)(adjustor+0x20) = (StgInt64)hptr;
- *(StgInt64 *)(adjustor+0x28) = (StgInt64)wptr;
+ adjustor = allocateExec(0x30,&code);
+ adj_code = (StgWord8*)adjustor;
+
+ *(StgInt32 *)adj_code = 0x49c1894d;
+ *(StgInt32 *)(adj_code+0x4) = 0x8948c889;
+ *(StgInt32 *)(adj_code+0x8) = 0xf28948d1;
+ *(StgInt32 *)(adj_code+0xc) = 0x48fe8948;
+ *(StgInt32 *)(adj_code+0x10) = 0x000a3d8b;
+ *(StgInt32 *)(adj_code+0x14) = 0x25ff0000;
+ *(StgInt32 *)(adj_code+0x18) = 0x0000000c;
+ *(StgInt64 *)(adj_code+0x20) = (StgInt64)hptr;
+ *(StgInt64 *)(adj_code+0x28) = (StgInt64)wptr;
}
else
{
- adjustor = allocateExec(0x40);
-
- *(StgInt32 *)adjustor = 0x35ff5141;
- *(StgInt32 *)(adjustor+0x4) = 0x00000020;
- *(StgInt32 *)(adjustor+0x8) = 0x49c1894d;
- *(StgInt32 *)(adjustor+0xc) = 0x8948c889;
- *(StgInt32 *)(adjustor+0x10) = 0xf28948d1;
- *(StgInt32 *)(adjustor+0x14) = 0x48fe8948;
- *(StgInt32 *)(adjustor+0x18) = 0x00123d8b;
- *(StgInt32 *)(adjustor+0x1c) = 0x25ff0000;
- *(StgInt32 *)(adjustor+0x20) = 0x00000014;
+ adjustor = allocateExec(0x40,&code);
+ adj_code = (StgWord8*)adjustor;
+
+ *(StgInt32 *)adj_code = 0x35ff5141;
+ *(StgInt32 *)(adj_code+0x4) = 0x00000020;
+ *(StgInt32 *)(adj_code+0x8) = 0x49c1894d;
+ *(StgInt32 *)(adj_code+0xc) = 0x8948c889;
+ *(StgInt32 *)(adj_code+0x10) = 0xf28948d1;
+ *(StgInt32 *)(adj_code+0x14) = 0x48fe8948;
+ *(StgInt32 *)(adj_code+0x18) = 0x00123d8b;
+ *(StgInt32 *)(adj_code+0x1c) = 0x25ff0000;
+ *(StgInt32 *)(adj_code+0x20) = 0x00000014;
- *(StgInt64 *)(adjustor+0x28) = (StgInt64)obscure_ccall_ret_code;
- *(StgInt64 *)(adjustor+0x30) = (StgInt64)hptr;
- *(StgInt64 *)(adjustor+0x38) = (StgInt64)wptr;
+ *(StgInt64 *)(adj_code+0x28) = (StgInt64)obscure_ccall_ret_code;
+ *(StgInt64 *)(adj_code+0x30) = (StgInt64)hptr;
+ *(StgInt64 *)(adj_code+0x38) = (StgInt64)wptr;
}
}
#elif defined(sparc_HOST_ARCH)
similarly, and local variables should be accessed via %fp, not %sp. In a
nutshell: This should work! (Famous last words! :-)
*/
- adjustor = allocateExec(4*(11+1));
+ adjustor = allocateExec(4*(11+1),&code);
{
unsigned long *const adj_code = (unsigned long *)adjustor;
4 bytes (getting rid of the nop), hence saving memory. [ccshan]
*/
ASSERT(((StgWord64)wptr & 3) == 0);
- adjustor = allocateExec(48);
+ adjustor = allocateExec(48,&code);
{
StgWord64 *const code = (StgWord64 *)adjustor;
src_locs[i] = dst_locs[i] = -32-(fpr++);
else
{
- if(t == 'l' && src_gpr <= 9)
+ if((t == 'l' || t == 'L') && src_gpr <= 9)
{
if((src_gpr & 1) == 0)
src_gpr++;
src_locs[i] = -src_gpr;
src_gpr += 2;
}
- else if(t == 'i' && src_gpr <= 10)
+ else if((t == 'w' || t == 'W') && src_gpr <= 10)
{
src_locs[i] = -(src_gpr++);
}
else
{
- if(t == 'l' || t == 'd')
+ if(t == 'l' || t == 'L' || t == 'd')
{
if(src_offset % 8)
src_offset += 4;
}
src_locs[i] = src_offset;
- src_offset += (t == 'l' || t == 'd') ? 8 : 4;
+ src_offset += (t == 'l' || t == 'L' || t == 'd') ? 8 : 4;
}
- if(t == 'l' && dst_gpr <= 9)
+ if((t == 'l' || t == 'L') && dst_gpr <= 9)
{
if((dst_gpr & 1) == 0)
dst_gpr++;
dst_locs[i] = -dst_gpr;
dst_gpr += 2;
}
- else if(t == 'i' && dst_gpr <= 10)
+ else if((t == 'w' || t == 'W') && dst_gpr <= 10)
{
dst_locs[i] = -(dst_gpr++);
}
else
{
- if(t == 'l' || t == 'd')
+ if(t == 'l' || t == 'L' || t == 'd')
{
if(dst_offset % 8)
dst_offset += 4;
}
dst_locs[i] = dst_offset;
- dst_offset += (t == 'l' || t == 'd') ? 8 : 4;
+ dst_offset += (t == 'l' || t == 'L' || t == 'd') ? 8 : 4;
}
}
}
*/
// allocate space for at most 4 insns per parameter
// plus 14 more instructions.
- adjustor = allocateExec(4 * (4*n + 14));
+ adjustor = allocateExec(4 * (4*n + 14),&code);
code = (unsigned*)adjustor;
*code++ = 0x48000008; // b *+8
ASSERT(dst_locs[i] > -32);
// dst is in GPR, too.
- if(typeString[i] == 'l')
+ if(typeString[i] == 'l' || typeString[i] == 'L')
{
// mr dst+1, src+1
*code++ = 0x7c000378
}
else
{
- if(typeString[i] == 'l')
+ if(typeString[i] == 'l' || typeString[i] == 'L')
{
// stw src+1, dst_offset+4(r1)
*code++ = 0x90010000
ASSERT(dst_locs[i] >= 0);
ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
- if(typeString[i] == 'l')
+ if(typeString[i] == 'l' || typeString[i] == 'L')
{
// lwz r0, src_offset(r1)
*code++ = 0x80010000
AdjustorStub *adjustorStub;
int sz = 0, extra_sz, total_sz;
- // from AdjustorAsm.s
- // not declared as a function so that AIX-style
- // fundescs can never get in the way.
- extern void *adjustorCode;
-
#ifdef FUNDESCS
adjustorStub = stgMallocBytes(sizeof(AdjustorStub), "createAdjustor");
#else
- adjustorStub = allocateExec(sizeof(AdjustorStub));
+ adjustorStub = allocateExec(sizeof(AdjustorStub),&code);
#endif
adjustor = adjustorStub;
}
/* Have fun! */
- return adjustor;
+ return code;
}
} else {
freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
}
-#elif defined(x86_HOST_ARCH) && defined(darwin_HOST_OS)
+#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)
if ( *(unsigned char*)ptr != 0xe8 ) {
errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
return;
freeStablePtr(((AdjustorStub*)ptr)->hptr);
#elif defined(x86_64_HOST_ARCH)
if ( *(StgWord16 *)ptr == 0x894d ) {
- freeStablePtr(*(StgStablePtr*)(ptr+0x20));
+ freeStablePtr(*(StgStablePtr*)((StgWord8*)ptr+0x20));
} else if ( *(StgWord16 *)ptr == 0x5141 ) {
- freeStablePtr(*(StgStablePtr*)(ptr+0x30));
+ freeStablePtr(*(StgStablePtr*)((StgWord8*)ptr+0x30));
} else {
errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
return;
}
freeStablePtr(((StgStablePtr*)ptr)[1]);
#elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
- extern void* adjustorCode;
if ( ((AdjustorStub*)ptr)->code != (StgFunPtr) &adjustorCode ) {
errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
return;
#else
ASSERT(0);
#endif
- *((unsigned char*)ptr) = '\0';
+ // Can't write to this memory, it is only executable:
+ // *((unsigned char*)ptr) = '\0';
freeExec(ptr);
}
-
-/*
- * Function: initAdjustor()
- *
- * Perform initialisation of adjustor thunk layer (if needed.)
- */
-void
-initAdjustor(void)
-{
-#if defined(i386_HOST_ARCH) && defined(openbsd_HOST_OS)
- obscure_ccall_ret_code_dyn = allocateExec(4);
- obscure_ccall_ret_code_dyn[0] = ((unsigned char *)obscure_ccall_ret_code)[0];
- obscure_ccall_ret_code_dyn[1] = ((unsigned char *)obscure_ccall_ret_code)[1];
- obscure_ccall_ret_code_dyn[2] = ((unsigned char *)obscure_ccall_ret_code)[2];
- obscure_ccall_ret_code_dyn[3] = ((unsigned char *)obscure_ccall_ret_code)[3];
-#endif
-}
+#endif // !USE_LIBFFI_FOR_ADJUSTORS
projects / ghc-hetmet.git / blobdiff