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