ghc/rts/Adjustor.c

   1 /* -----------------------------------------------------------------------------
   2  * Foreign export adjustor thunks
   3  *
   4  * Copyright (c) 1998.
   5  *
   6  * ---------------------------------------------------------------------------*/
   7
   8 /* A little bit of background...
   9
  10 An adjustor thunk is a dynamically allocated code snippet that allows
  11 Haskell closures to be viewed as C function pointers.
  12
  13 Stable pointers provide a way for the outside world to get access to,
  14 and evaluate, Haskell heap objects, with the RTS providing a small
  15 range of ops for doing so. So, assuming we've got a stable pointer in
  16 our hand in C, we can jump into the Haskell world and evaluate a callback
  17 procedure, say. This works OK in some cases where callbacks are used, but
  18 does require the external code to know about stable pointers and how to deal
  19 with them. We'd like to hide the Haskell-nature of a callback and have it
  20 be invoked just like any other C function pointer.
  21
  22 Enter adjustor thunks. An adjustor thunk is a little piece of code
  23 that's generated on-the-fly (one per Haskell closure being exported)
  24 that, when entered using some 'universal' calling convention (e.g., the
  25 C calling convention on platform X), pushes an implicit stable pointer
  26 (to the Haskell callback) before calling another (static) C function stub
  27 which takes care of entering the Haskell code via its stable pointer.
  28
  29 An adjustor thunk is allocated on the C heap, and is called from within
  30 Haskell just before handing out the function pointer to the Haskell (IO)
  31 action. User code should never have to invoke it explicitly.
  32
  33 An adjustor thunk differs from a C function pointer in one respect: when
  34 the code is through with it, it has to be freed in order to release Haskell
  35 and C resources. Failure to do so result in memory leaks on both the C and
  36 Haskell side.
  37 */
  38
  39 #include "PosixSource.h"
  40 #include "Rts.h"
  41 #include "RtsExternal.h"
  42 #include "RtsUtils.h"
  43 #include <stdlib.h>
  44
  45 #if defined(_WIN32)
  46 #include <windows.h>
  47 #endif
  48
  49 #if defined(openbsd_TARGET_OS)
  50 #include <unistd.h>
  51 #include <sys/types.h>
  52 #include <sys/mman.h>
  53
  54 /* no C99 header stdint.h on OpenBSD? */
  55 typedef unsigned long my_uintptr_t;
  56 #endif
  57
  58 /* Heavily arch-specific, I'm afraid.. */
  59
  60 /*
  61  * Allocate len bytes which are readable, writable, and executable.
  62  *
  63  * ToDo: If this turns out to be a performance bottleneck, one could
  64  * e.g. cache the last VirtualProtect/mprotect-ed region and do
  65  * nothing in case of a cache hit.
  66  */
  67 static void*
  68 mallocBytesRWX(int len)
  69 {
  70   void *addr = stgMallocBytes(len, "mallocBytesRWX");
  71 #if defined(i386_TARGET_ARCH) && defined(_WIN32)
  72   /* This could be necessary for processors which distinguish between READ and
  73      EXECUTE memory accesses, e.g. Itaniums. */
  74   DWORD dwOldProtect = 0;
  75   if (VirtualProtect (addr, len, PAGE_EXECUTE_READWRITE, &dwOldProtect) == 0) {
  76     barf("mallocBytesRWX: failed to protect 0x%p; error=%lu; old protection: %lu\n",
  77          addr, (unsigned long)GetLastError(), (unsigned long)dwOldProtect);
  78   }
  79 #elif defined(openbsd_TARGET_OS)
  80   /* malloced memory isn't executable by default on OpenBSD */
  81   my_uintptr_t pageSize         = sysconf(_SC_PAGESIZE);
  82   my_uintptr_t mask             = ~(pageSize - 1);
  83   my_uintptr_t startOfFirstPage = ((my_uintptr_t)addr          ) & mask;
  84   my_uintptr_t startOfLastPage  = ((my_uintptr_t)addr + len - 1) & mask;
  85   my_uintptr_t size             = startOfLastPage - startOfFirstPage + pageSize;
  86   if (mprotect((void*)startOfFirstPage, (size_t)size, PROT_EXEC | PROT_READ | PROT_WRITE) != 0) {
  87     barf("mallocBytesRWX: failed to protect 0x%p\n", addr);
  88   }
  89 #endif
  90   return addr;
  91 }
  92
  93 #if defined(i386_TARGET_ARCH)
  94 static unsigned char *obscure_ccall_ret_code;
  95 #endif
  96
  97 #if defined(alpha_TARGET_ARCH)
  98 /* To get the definition of PAL_imb: */
  99 # if defined(linux_TARGET_OS)
 100 #  include <asm/pal.h>
 101 # else
 102 #  include <machine/pal.h>
 103 # endif
 104 #endif
 105
 106 #if defined(ia64_TARGET_ARCH)
 107 #include "Storage.h"
 108
 109 /* Layout of a function descriptor */
 110 typedef struct _IA64FunDesc {
 111     StgWord64 ip;
 112     StgWord64 gp;
 113 } IA64FunDesc;
 114
 115 static void *
 116 stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
 117 {
 118   StgArrWords* arr;
 119   nat data_size_in_words, total_size_in_words;
 120
 121   /* round up to a whole number of words */
 122   data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
 123   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 124
 125   /* allocate and fill it in */
 126   arr = (StgArrWords *)allocate(total_size_in_words);
 127   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 128
 129   /* obtain a stable ptr */
 130   *stable = getStablePtr((StgPtr)arr);
 131
 132   /* and return a ptr to the goods inside the array */
 133   return(BYTE_ARR_CTS(arr));
 134 }
 135 #endif
 136
 137 #if defined(powerpc64_TARGET_ARCH)
 138 // We don't need to generate dynamic code on powerpc64-[linux|AIX],
 139 // but we do need a piece of (static) inline assembly code:
 140
 141 static void
 142 adjustorCodeWrittenInAsm()
 143 {
 144         __asm__ volatile (
 145                 "adjustorCode:\n\t"
 146                 "mr 10,8\n\t"
 147                 "mr 9,7\n\t"
 148                 "mr 8,6\n\t"
 149                 "mr 7,5\n\t"
 150                 "mr 6,4\n\t"
 151                 "mr 5,3\n\t"
 152                 "mr 3,11\n\t"
 153                 "ld 0,0(2)\n\t"
 154                 "ld 11,16(2)\n\t"
 155                 "mtctr 0\n\t"
 156                 "ld 2,8(2)\n\t"
 157                 "bctr"
 158                 : : );
 159 }
 160 #endif
 161
 162 void*
 163 createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr)
 164 {
 165   void *adjustor = NULL;
 166
 167   switch (cconv)
 168   {
 169   case 0: /* _stdcall */
 170 #if defined(i386_TARGET_ARCH)
 171     /* Magic constant computed by inspecting the code length of
 172        the following assembly language snippet
 173        (offset and machine code prefixed):
 174
 175      <0>:       58                popl   %eax              # temp. remove ret addr..
 176      <1>:       68 fd fc fe fa    pushl  0xfafefcfd        # constant is large enough to
 177                                                            # hold a StgStablePtr
 178      <6>:       50                pushl  %eax              # put back ret. addr
 179      <7>:       b8 fa ef ff 00    movl   $0x00ffeffa, %eax # load up wptr
 180      <c>:       ff e0             jmp    %eax              # and jump to it.
 181                 # the callee cleans up the stack
 182     */
 183     adjustor = mallocBytesRWX(14);
 184     {
 185         unsigned char *const adj_code = (unsigned char *)adjustor;
 186         adj_code[0x00] = (unsigned char)0x58;  /* popl %eax  */
 187
 188         adj_code[0x01] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 189         *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr;
 190
 191         adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */
 192
 193         adj_code[0x07] = (unsigned char)0xb8; /* movl  $wptr, %eax */
 194         *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr;
 195
 196         adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */
 197         adj_code[0x0d] = (unsigned char)0xe0;
 198     }
 199 #endif
 200     break;
 201
 202   case 1: /* _ccall */
 203 #if defined(i386_TARGET_ARCH)
 204   /* Magic constant computed by inspecting the code length of
 205      the following assembly language snippet
 206      (offset and machine code prefixed):
 207
 208   <00>: 68 ef be ad de     pushl  $0xdeadbeef      # constant is large enough to
 209                                                    # hold a StgStablePtr
 210   <05>: b8 fa ef ff 00     movl   $0x00ffeffa, %eax # load up wptr
 211   <0a>: 68 ef be ad de     pushl  $obscure_ccall_ret_code # push the return address
 212   <0f>: ff e0              jmp    *%eax            # jump to wptr
 213
 214     The ccall'ing version is a tad different, passing in the return
 215     address of the caller to the auto-generated C stub (which enters
 216     via the stable pointer.) (The auto-generated C stub is in on this
 217     game, don't worry :-)
 218
 219     See the comment next to obscure_ccall_ret_code why we need to
 220     perform a tail jump instead of a call, followed by some C stack
 221     fixup.
 222
 223     Note: The adjustor makes the assumption that any return value
 224     coming back from the C stub is not stored on the stack.
 225     That's (thankfully) the case here with the restricted set of
 226     return types that we support.
 227   */
 228     adjustor = mallocBytesRWX(17);
 229     {
 230         unsigned char *const adj_code = (unsigned char *)adjustor;
 231
 232         adj_code[0x00] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 233         *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr;
 234
 235         adj_code[0x05] = (unsigned char)0xb8;  /* movl  $wptr, %eax */
 236         *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr;
 237
 238         adj_code[0x0a] = (unsigned char)0x68;  /* pushl obscure_ccall_ret_code */
 239         *((StgFunPtr*)(adj_code + 0x0b)) = (StgFunPtr)obscure_ccall_ret_code;
 240
 241         adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
 242         adj_code[0x10] = (unsigned char)0xe0;
 243     }
 244 #elif defined(sparc_TARGET_ARCH)
 245   /* Magic constant computed by inspecting the code length of the following
 246      assembly language snippet (offset and machine code prefixed):
 247
 248      <00>: 9C23A008   sub   %sp, 8, %sp         ! make room for %o4/%o5 in caller's frame
 249      <04>: DA23A060   st    %o5, [%sp + 96]     ! shift registers by 2 positions
 250      <08>: D823A05C   st    %o4, [%sp + 92]
 251      <0C>: 9A10000B   mov   %o3, %o5
 252      <10>: 9810000A   mov   %o2, %o4
 253      <14>: 96100009   mov   %o1, %o3
 254      <18>: 94100008   mov   %o0, %o2
 255      <1C>: 13000000   sethi %hi(wptr), %o1      ! load up wptr (1 of 2)
 256      <20>: 11000000   sethi %hi(hptr), %o0      ! load up hptr (1 of 2)
 257      <24>: 81C26000   jmp   %o1 + %lo(wptr)     ! jump to wptr (load 2 of 2)
 258      <28>: 90122000   or    %o0, %lo(hptr), %o0 ! load up hptr (2 of 2, delay slot)
 259      <2C>  00000000                             ! place for getting hptr back easily
 260
 261      ccall'ing on SPARC is easy, because we are quite lucky to push a
 262      multiple of 8 bytes (1 word hptr + 1 word dummy arg) in front of the
 263      existing arguments (note that %sp must stay double-word aligned at
 264      all times, see ABI spec at http://www.sparc.org/standards/psABI3rd.pdf).
 265      To do this, we extend the *caller's* stack frame by 2 words and shift
 266      the output registers used for argument passing (%o0 - %o5, we are a *leaf*
 267      procedure because of the tail-jump) by 2 positions. This makes room in
 268      %o0 and %o1 for the additinal arguments, namely  hptr and a dummy (used
 269      for destination addr of jump on SPARC, return address on x86, ...). This
 270      shouldn't cause any problems for a C-like caller: alloca is implemented
 271      similarly, and local variables should be accessed via %fp, not %sp. In a
 272      nutshell: This should work! (Famous last words! :-)
 273   */
 274     adjustor = mallocBytesRWX(4*(11+1));
 275     {
 276         unsigned long *const adj_code = (unsigned long *)adjustor;
 277
 278         adj_code[ 0]  = 0x9C23A008UL;   /* sub   %sp, 8, %sp         */
 279         adj_code[ 1]  = 0xDA23A060UL;   /* st    %o5, [%sp + 96]     */
 280         adj_code[ 2]  = 0xD823A05CUL;   /* st    %o4, [%sp + 92]     */
 281         adj_code[ 3]  = 0x9A10000BUL;   /* mov   %o3, %o5            */
 282         adj_code[ 4]  = 0x9810000AUL;   /* mov   %o2, %o4            */
 283         adj_code[ 5]  = 0x96100009UL;   /* mov   %o1, %o3            */
 284         adj_code[ 6]  = 0x94100008UL;   /* mov   %o0, %o2            */
 285         adj_code[ 7]  = 0x13000000UL;   /* sethi %hi(wptr), %o1      */
 286         adj_code[ 7] |= ((unsigned long)wptr) >> 10;
 287         adj_code[ 8]  = 0x11000000UL;   /* sethi %hi(hptr), %o0      */
 288         adj_code[ 8] |= ((unsigned long)hptr) >> 10;
 289         adj_code[ 9]  = 0x81C26000UL;   /* jmp   %o1 + %lo(wptr)     */
 290         adj_code[ 9] |= ((unsigned long)wptr) & 0x000003FFUL;
 291         adj_code[10]  = 0x90122000UL;   /* or    %o0, %lo(hptr), %o0 */
 292         adj_code[10] |= ((unsigned long)hptr) & 0x000003FFUL;
 293
 294         adj_code[11]  = (unsigned long)hptr;
 295
 296         /* flush cache */
 297         asm("flush %0" : : "r" (adj_code     ));
 298         asm("flush %0" : : "r" (adj_code +  2));
 299         asm("flush %0" : : "r" (adj_code +  4));
 300         asm("flush %0" : : "r" (adj_code +  6));
 301         asm("flush %0" : : "r" (adj_code + 10));
 302
 303         /* max. 5 instructions latency, and we need at >= 1 for returning */
 304         asm("nop");
 305         asm("nop");
 306         asm("nop");
 307         asm("nop");
 308     }
 309 #elif defined(alpha_TARGET_ARCH)
 310   /* Magic constant computed by inspecting the code length of
 311      the following assembly language snippet
 312      (offset and machine code prefixed; note that the machine code
 313      shown is longwords stored in little-endian order):
 314
 315   <00>: 46520414        mov     a2, a4
 316   <04>: 46100412        mov     a0, a2
 317   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 318   <0c>: 46730415        mov     a3, a5
 319   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 320   <14>: 46310413        mov     a1, a3
 321   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 322   <1c>: 00000000                                # padding for alignment
 323   <20>: [8 bytes for hptr quadword]
 324   <28>: [8 bytes for wptr quadword]
 325
 326      The "computed" jump at <08> above is really a jump to a fixed
 327      location.  Accordingly, we place an always-correct hint in the
 328      jump instruction, namely the address offset from <0c> to wptr,
 329      divided by 4, taking the lowest 14 bits.
 330
 331      We only support passing 4 or fewer argument words, for the same
 332      reason described under sparc_TARGET_ARCH above by JRS, 21 Aug 01.
 333      On the Alpha the first 6 integer arguments are in a0 through a5,
 334      and the rest on the stack.  Hence we want to shuffle the original
 335      caller's arguments by two.
 336
 337      On the Alpha the calling convention is so complex and dependent
 338      on the callee's signature -- for example, the stack pointer has
 339      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 340      to handle the general case correctly without changing how the
 341      adjustor is called from C.  For now, our solution of shuffling
 342      registers only and ignoring the stack only works if the original
 343      caller passed 4 or fewer argument words.
 344
 345 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 346       header information (more precisely, if the overhead is no more than
 347       4 bytes), we should move the first three instructions above down by
 348       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 349   */
 350     ASSERT(((StgWord64)wptr & 3) == 0);
 351     adjustor = mallocBytesRWX(48);
 352     {
 353         StgWord64 *const code = (StgWord64 *)adjustor;
 354
 355         code[0] = 0x4610041246520414L;
 356         code[1] = 0x46730415a61b0020L;
 357         code[2] = 0x46310413a77b0028L;
 358         code[3] = 0x000000006bfb0000L
 359                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 360
 361         code[4] = (StgWord64)hptr;
 362         code[5] = (StgWord64)wptr;
 363
 364         /* Ensure that instruction cache is consistent with our new code */
 365         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 366     }
 367 #elif defined(powerpc_TARGET_ARCH)
 368 /*
 369         For PowerPC, the following code is used:
 370
 371         mr r10,r8
 372         mr r9,r7
 373         mr r8,r6
 374         mr r7,r5
 375         mr r6,r4
 376         mr r5,r3
 377         lis r0,0xDEAD ;hi(wptr)
 378         lis r3,0xDEAF ;hi(hptr)
 379         ori r0,r0,0xBEEF ; lo(wptr)
 380         ori r3,r3,0xFACE ; lo(hptr)
 381         mtctr r0
 382         bctr
 383
 384         The arguments (passed in registers r3 - r10) are shuffled along by two to
 385         make room for hptr and a dummy argument. As r9 and r10 are overwritten by
 386         this code, it only works for up to 6 arguments (when floating point arguments
 387         are involved, this may be more or less, depending on the exact situation).
 388 */
 389         adjustor = mallocBytesRWX(4*13);
 390         {
 391                 unsigned long *const adj_code = (unsigned long *)adjustor;
 392
 393                 // make room for extra arguments
 394                 adj_code[0] = 0x7d0a4378;       //mr r10,r8
 395                 adj_code[1] = 0x7ce93b78;       //mr r9,r7
 396                 adj_code[2] = 0x7cc83378;       //mr r8,r6
 397                 adj_code[3] = 0x7ca72b78;       //mr r7,r5
 398                 adj_code[4] = 0x7c862378;       //mr r6,r4
 399                 adj_code[5] = 0x7c651b78;       //mr r5,r3
 400
 401                 adj_code[6] = 0x3c000000;       //lis r0,hi(wptr)
 402                 adj_code[6] |= ((unsigned long)wptr) >> 16;
 403
 404                 adj_code[7] = 0x3c600000;       //lis r3,hi(hptr)
 405                 adj_code[7] |= ((unsigned long)hptr) >> 16;
 406
 407                 adj_code[8] = 0x60000000;       //ori r0,r0,lo(wptr)
 408                 adj_code[8] |= ((unsigned long)wptr) & 0xFFFF;
 409
 410                 adj_code[9] = 0x60630000;       //ori r3,r3,lo(hptr)
 411                 adj_code[9] |= ((unsigned long)hptr) & 0xFFFF;
 412
 413                 adj_code[10] = 0x7c0903a6;      //mtctr r0
 414                 adj_code[11] = 0x4e800420;      //bctr
 415                 adj_code[12] = (unsigned long)hptr;
 416
 417                 // Flush the Instruction cache:
 418                 //      MakeDataExecutable(adjustor,4*13);
 419                         /* This would require us to link with CoreServices.framework */
 420                 {               /* this should do the same: */
 421                         int n = 13;
 422                         unsigned long *p = adj_code;
 423                         while(n--)
 424                         {
 425                                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 426                                                     : : "r" (p));
 427                                 p++;
 428                         }
 429                         __asm__ volatile ("sync\n\tisync");
 430                 }
 431         }
 432 #elif defined(powerpc64_TARGET_ARCH)
 433         // This is for powerpc64 linux and powerpc64 AIX.
 434         // It probably won't apply to powerpc64-darwin.
 435
 436         {
 437                 typedef struct {
 438                         StgFunPtr               code;
 439                         void*                   toc;
 440                         void*                   env;
 441                 } FunDesc;
 442
 443                 FunDesc *desc = malloc(sizeof(FunDesc));
 444                 extern void *adjustorCode;
 445
 446                 desc->code = (void*) &adjustorCode;
 447                 desc->toc = (void*) wptr;
 448                 desc->env = (void*) hptr;
 449
 450                 adjustor = (void*) desc;
 451         }
 452         break;
 453
 454 #elif defined(ia64_TARGET_ARCH)
 455 /*
 456     Up to 8 inputs are passed in registers.  We flush the last two inputs to
 457     the stack, initially into the 16-byte scratch region left by the caller.
 458     We then shuffle the others along by 4 (taking 2 registers for ourselves
 459     to save return address and previous function state - we need to come back
 460     here on the way out to restore the stack, so this is a real function
 461     rather than just a trampoline).
 462
 463     The function descriptor we create contains the gp of the target function
 464     so gp is already loaded correctly.
 465
 466         [MLX]       alloc r16=ar.pfs,10,2,0
 467                     movl r17=wptr
 468         [MII]       st8.spill [r12]=r38,8               // spill in6 (out4)
 469                     mov r41=r37                         // out7 = in5 (out3)
 470                     mov r40=r36;;                       // out6 = in4 (out2)
 471         [MII]       st8.spill [r12]=r39                 // spill in7 (out5)
 472                     mov.sptk b6=r17,50
 473                     mov r38=r34;;                       // out4 = in2 (out0)
 474         [MII]       mov r39=r35                         // out5 = in3 (out1)
 475                     mov r37=r33                         // out3 = in1 (loc1)
 476                     mov r36=r32                         // out2 = in0 (loc0)
 477         [MLX]       adds r12=-24,r12                    // update sp
 478                     movl r34=hptr;;                     // out0 = hptr
 479         [MIB]       mov r33=r16                         // loc1 = ar.pfs
 480                     mov r32=b0                          // loc0 = retaddr
 481                     br.call.sptk.many b0=b6;;
 482
 483         [MII]       adds r12=-16,r12
 484                     mov b0=r32
 485                     mov.i ar.pfs=r33
 486         [MFB]       nop.m 0x0
 487                     nop.f 0x0
 488                     br.ret.sptk.many b0;;
 489 */
 490
 491 /* These macros distribute a long constant into the two words of an MLX bundle */
 492 #define BITS(val,start,count)   (((val) >> (start)) & ((1 << (count))-1))
 493 #define MOVL_LOWORD(val)        (BITS(val,22,18) << 46)
 494 #define MOVL_HIWORD(val)        (BITS(val,40,23) | (BITS(val,0,7) << 36) | (BITS(val,7,9) << 50) \
 495                                 | (BITS(val,16,5) << 55) | (BITS(val,21,1) << 44) | BITS(val,63,1) << 59)
 496
 497     {
 498         StgStablePtr stable;
 499         IA64FunDesc *wdesc = (IA64FunDesc *)wptr;
 500         StgWord64 wcode = wdesc->ip;
 501         IA64FunDesc *fdesc;
 502         StgWord64 *code;
 503
 504         /* we allocate on the Haskell heap since malloc'd memory isn't executable - argh */
 505         adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8, &stable);
 506
 507         fdesc = (IA64FunDesc *)adjustor;
 508         code = (StgWord64 *)(fdesc + 1);
 509         fdesc->ip = (StgWord64)code;
 510         fdesc->gp = wdesc->gp;
 511
 512         code[0]  = 0x0000058004288004 | MOVL_LOWORD(wcode);
 513         code[1]  = 0x6000000220000000 | MOVL_HIWORD(wcode);
 514         code[2]  = 0x029015d818984001;
 515         code[3]  = 0x8401200500420094;
 516         code[4]  = 0x886011d8189c0001;
 517         code[5]  = 0x84011004c00380c0;
 518         code[6]  = 0x0250210046013800;
 519         code[7]  = 0x8401000480420084;
 520         code[8]  = 0x0000233f19a06005 | MOVL_LOWORD((StgWord64)hptr);
 521         code[9]  = 0x6000000440000000 | MOVL_HIWORD((StgWord64)hptr);
 522         code[10] = 0x0200210020010811;
 523         code[11] = 0x1080006800006200;
 524         code[12] = 0x0000210018406000;
 525         code[13] = 0x00aa021000038005;
 526         code[14] = 0x000000010000001d;
 527         code[15] = 0x0084000880000200;
 528
 529         /* save stable pointers in convenient form */
 530         code[16] = (StgWord64)hptr;
 531         code[17] = (StgWord64)stable;
 532     }
 533 #else
 534     barf("adjustor creation not supported on this platform");
 535 #endif
 536     break;
 537
 538   default:
 539     ASSERT(0);
 540     break;
 541   }
 542
 543   /* Have fun! */
 544   return adjustor;
 545 }
 546
 547
 548 void
 549 freeHaskellFunctionPtr(void* ptr)
 550 {
 551 #if defined(i386_TARGET_ARCH)
 552  if ( *(unsigned char*)ptr != 0x68 &&
 553       *(unsigned char*)ptr != 0x58 ) {
 554    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 555    return;
 556  }
 557
 558  /* Free the stable pointer first..*/
 559  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
 560     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
 561  } else {
 562     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
 563  }
 564 #elif defined(sparc_TARGET_ARCH)
 565  if ( *(unsigned long*)ptr != 0x9C23A008UL ) {
 566    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 567    return;
 568  }
 569
 570  /* Free the stable pointer first..*/
 571  freeStablePtr(*((StgStablePtr*)((unsigned long*)ptr + 11)));
 572 #elif defined(alpha_TARGET_ARCH)
 573  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
 574    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 575    return;
 576  }
 577
 578  /* Free the stable pointer first..*/
 579  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
 580 #elif defined(powerpc_TARGET_ARCH)
 581  if ( *(StgWord*)ptr != 0x7d0a4378 ) {
 582    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 583    return;
 584  }
 585  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 4*12)));
 586 #elif defined(ia64_TARGET_ARCH)
 587  IA64FunDesc *fdesc = (IA64FunDesc *)ptr;
 588  StgWord64 *code = (StgWord64 *)(fdesc+1);
 589
 590  if (fdesc->ip != (StgWord64)code) {
 591    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 592    return;
 593  }
 594  freeStablePtr((StgStablePtr)code[16]);
 595  freeStablePtr((StgStablePtr)code[17]);
 596  return;
 597 #else
 598  ASSERT(0);
 599 #endif
 600  *((unsigned char*)ptr) = '\0';
 601
 602  stgFree(ptr);
 603 }
 604
 605
 606 /*
 607  * Function: initAdjustor()
 608  *
 609  * Perform initialisation of adjustor thunk layer (if needed.)
 610  */
 611 void
 612 initAdjustor(void)
 613 {
 614 #if defined(i386_TARGET_ARCH)
 615   /* Now here's something obscure for you:
 616
 617   When generating an adjustor thunk that uses the C calling
 618   convention, we have to make sure that the thunk kicks off
 619   the process of jumping into Haskell with a tail jump. Why?
 620   Because as a result of jumping in into Haskell we may end
 621   up freeing the very adjustor thunk we came from using
 622   freeHaskellFunctionPtr(). Hence, we better not return to
 623   the adjustor code on our way  out, since it could by then
 624   point to junk.
 625
 626   The fix is readily at hand, just include the opcodes
 627   for the C stack fixup code that we need to perform when
 628   returning in some static piece of memory and arrange
 629   to return to it before tail jumping from the adjustor thunk.
 630   */
 631
 632   obscure_ccall_ret_code = mallocBytesRWX(4);
 633
 634   obscure_ccall_ret_code[0x00] = (unsigned char)0x83;  /* addl $0x4, %esp */
 635   obscure_ccall_ret_code[0x01] = (unsigned char)0xc4;
 636   obscure_ccall_ret_code[0x02] = (unsigned char)0x04;
 637
 638   obscure_ccall_ret_code[0x03] = (unsigned char)0xc3;  /* ret */
 639 #endif
 640 }