X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2FAdjustor.c;h=03fb5d9acd08c5e21352c27d6fb53f5a6da2490d;hp=813fcfed563e74fd41a8f5bcc6f0c5946b1ad8b7;hb=5123ae93cfc5cdfcecc84340a9517580ad900d64;hpb=1cb0eb071f1316d6650f354166506789a2638720 diff --git a/rts/Adjustor.c b/rts/Adjustor.c index 813fcfe..03fb5d9 100644 --- a/rts/Adjustor.c +++ b/rts/Adjustor.c @@ -6,7 +6,7 @@ * ---------------------------------------------------------------------------*/ /* 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. @@ -32,7 +32,7 @@ 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 +and C resources. Failure to do so will result in memory leaks on both the C and Haskell side. */ @@ -42,6 +42,89 @@ Haskell side. #include "RtsUtils.h" #include +#if defined(USE_LIBFFI) + +#include +#include + +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; + 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; + + 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_TARGET_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); + + // ToDo: use ffi_closure_alloc() + cl = allocateExec(sizeof(ffi_closure)); + + r = ffi_prep_closure(cl, cif, (void*)wptr, hptr/*userdata*/); + if (r != FFI_OK) barf("ffi_prep_closure failed: %d", r); + + return (void*)cl; +} + +#else // To end of file... + #if defined(_WIN32) #include #endif @@ -84,10 +167,6 @@ static void GNUC3_ATTRIBUTE(used) obscure_ccall_wrapper(void) } 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) @@ -224,6 +303,7 @@ static int totalArgumentSize(char *typeString) // on 32-bit platforms, Double and Int64 occupy two words. case 'd': case 'l': + case 'L': if(sizeof(void*) == 4) { sz += 2; @@ -322,11 +402,7 @@ createAdjustor(int cconv, StgStablePtr hptr, 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; @@ -425,11 +501,6 @@ createAdjustor(int cconv, StgStablePtr hptr, 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; @@ -437,7 +508,7 @@ createAdjustor(int cconv, StgStablePtr hptr, // 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; } @@ -631,48 +702,48 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for 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; } } } @@ -714,7 +785,7 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for 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 @@ -730,7 +801,7 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for } else { - if(typeString[i] == 'l') + if(typeString[i] == 'l' || typeString[i] == 'L') { // stw src+1, dst_offset+4(r1) *code++ = 0x90010000 @@ -749,7 +820,7 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for 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 @@ -957,8 +1028,12 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for /* These macros distribute a long constant into the two words of an MLX bundle */ #define BITS(val,start,count) (((val) >> (start)) & ((1 << (count))-1)) #define MOVL_LOWORD(val) (BITS(val,22,18) << 46) -#define MOVL_HIWORD(val) (BITS(val,40,23) | (BITS(val,0,7) << 36) | (BITS(val,7,9) << 50) \ - | (BITS(val,16,5) << 55) | (BITS(val,21,1) << 44) | BITS(val,63,1) << 59) +#define MOVL_HIWORD(val) ( (BITS(val,0,7) << 36) \ + | (BITS(val,7,9) << 50) \ + | (BITS(val,16,5) << 45) \ + | (BITS(val,21,1) << 44) \ + | (BITS(val,40,23)) \ + | (BITS(val,63,1) << 59)) { StgStablePtr stable; @@ -967,11 +1042,17 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for IA64FunDesc *fdesc; StgWord64 *code; - /* we allocate on the Haskell heap since malloc'd memory isn't executable - argh */ - adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8, &stable); + /* we allocate on the Haskell heap since malloc'd memory isn't + * executable - argh */ + /* Allocated memory is word-aligned (8 bytes) but functions on ia64 + * must be aligned to 16 bytes. We allocate an extra 8 bytes of + * wiggle room so that we can put the code on a 16 byte boundary. */ + adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8+8, &stable); fdesc = (IA64FunDesc *)adjustor; code = (StgWord64 *)(fdesc + 1); + /* add 8 bytes to code if needed to align to a 16-byte boundary */ + if ((StgWord64)code & 15) code++; fdesc->ip = (StgWord64)code; fdesc->gp = wdesc->gp; @@ -1027,7 +1108,7 @@ freeHaskellFunctionPtr(void* ptr) } 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; @@ -1090,20 +1171,4 @@ if ( *(unsigned char*)ptr != 0xe8 ) { 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