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 void
  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         DWORD rc = GetLastError();
  79         barf("execPage: failed to protect 0x%p; error=%lu; old protection: %lu\n", addr, rc, dwOldProtect);
  80     }
  81 #else
  82     (void)addr;   (void)mode;   /* keep gcc -Wall happy */
  83 #endif
  84 }
  85
  86 #if defined(i386_TARGET_ARCH)
  87 static unsigned char *obscure_ccall_ret_code;
  88 #endif
  89
  90 #if defined(alpha_TARGET_ARCH)
  91 /* To get the definition of PAL_imb: */
  92 # if defined(linux_TARGET_OS)
  93 #  include <asm/pal.h>
  94 # else
  95 #  include <machine/pal.h>
  96 # endif
  97 #endif
  98
  99 #if defined(ia64_TARGET_ARCH)
 100 #include "Storage.h"
 101
 102 /* Layout of a function descriptor */
 103 typedef struct _IA64FunDesc {
 104     StgWord64 ip;
 105     StgWord64 gp;
 106 } IA64FunDesc;
 107
 108 static void *
 109 stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
 110 {
 111   StgArrWords* arr;
 112   nat data_size_in_words, total_size_in_words;
 113
 114   /* round up to a whole number of words */
 115   data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
 116   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 117
 118   /* allocate and fill it in */
 119   arr = (StgArrWords *)allocate(total_size_in_words);
 120   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 121
 122   /* obtain a stable ptr */
 123   *stable = getStablePtr((StgPtr)arr);
 124
 125   /* and return a ptr to the goods inside the array */
 126   return(BYTE_ARR_CTS(arr));
 127 }
 128 #endif
 129
 130 void*
 131 createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr)
 132 {
 133   void *adjustor = NULL;
 134
 135   switch (cconv)
 136   {
 137   case 0: /* _stdcall */
 138 #if defined(i386_TARGET_ARCH)
 139     /* Magic constant computed by inspecting the code length of
 140        the following assembly language snippet
 141        (offset and machine code prefixed):
 142
 143      <0>:       58                popl   %eax              # temp. remove ret addr..
 144      <1>:       68 fd fc fe fa    pushl  0xfafefcfd        # constant is large enough to
 145                                                            # hold a StgStablePtr
 146      <6>:       50                pushl  %eax              # put back ret. addr
 147      <7>:       b8 fa ef ff 00    movl   $0x00ffeffa, %eax # load up wptr
 148      <c>:       ff e0             jmp    %eax              # and jump to it.
 149                 # the callee cleans up the stack
 150     */
 151     adjustor = stgMallocBytes(14, "createAdjustor");
 152     {
 153         unsigned char *const adj_code = (unsigned char *)adjustor;
 154         adj_code[0x00] = (unsigned char)0x58;  /* popl %eax  */
 155
 156         adj_code[0x01] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 157         *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr;
 158
 159         adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */
 160
 161         adj_code[0x07] = (unsigned char)0xb8; /* movl  $wptr, %eax */
 162         *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr;
 163
 164         adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */
 165         adj_code[0x0d] = (unsigned char)0xe0;
 166
 167         execPage(adjustor, pageExecuteReadWrite);
 168     }
 169 #endif
 170     break;
 171
 172   case 1: /* _ccall */
 173 #if defined(i386_TARGET_ARCH)
 174   /* Magic constant computed by inspecting the code length of
 175      the following assembly language snippet
 176      (offset and machine code prefixed):
 177
 178   <00>: 68 ef be ad de     pushl  $0xdeadbeef      # constant is large enough to
 179                                                    # hold a StgStablePtr
 180   <05>: b8 fa ef ff 00     movl   $0x00ffeffa, %eax # load up wptr
 181   <0a>: 68 ef be ad de     pushl  $obscure_ccall_ret_code # push the return address
 182   <0f>: ff e0              jmp    *%eax            # jump to wptr
 183
 184     The ccall'ing version is a tad different, passing in the return
 185     address of the caller to the auto-generated C stub (which enters
 186     via the stable pointer.) (The auto-generated C stub is in on this
 187     game, don't worry :-)
 188
 189     See the comment next to obscure_ccall_ret_code why we need to
 190     perform a tail jump instead of a call, followed by some C stack
 191     fixup.
 192
 193     Note: The adjustor makes the assumption that any return value
 194     coming back from the C stub is not stored on the stack.
 195     That's (thankfully) the case here with the restricted set of
 196     return types that we support.
 197   */
 198     adjustor = stgMallocBytes(17, "createAdjustor");
 199     {
 200         unsigned char *const adj_code = (unsigned char *)adjustor;
 201
 202         adj_code[0x00] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 203         *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr;
 204
 205         adj_code[0x05] = (unsigned char)0xb8;  /* movl  $wptr, %eax */
 206         *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr;
 207
 208         adj_code[0x0a] = (unsigned char)0x68;  /* pushl obscure_ccall_ret_code */
 209         *((StgFunPtr*)(adj_code + 0x0b)) = (StgFunPtr)obscure_ccall_ret_code;
 210
 211         adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
 212         adj_code[0x10] = (unsigned char)0xe0;
 213
 214         execPage(adjustor, pageExecuteReadWrite);
 215     }
 216 #elif defined(sparc_TARGET_ARCH)
 217   /* Magic constant computed by inspecting the code length of the following
 218      assembly language snippet (offset and machine code prefixed):
 219
 220      <00>: 9C23A008   sub   %sp, 8, %sp         ! make room for %o4/%o5 in caller's frame
 221      <04>: DA23A060   st    %o5, [%sp + 96]     ! shift registers by 2 positions
 222      <08>: D823A05C   st    %o4, [%sp + 92]
 223      <0C>: 9A10000B   mov   %o3, %o5
 224      <10>: 9810000A   mov   %o2, %o4
 225      <14>: 96100009   mov   %o1, %o3
 226      <18>: 94100008   mov   %o0, %o2
 227      <1C>: 13000000   sethi %hi(wptr), %o1      ! load up wptr (1 of 2)
 228      <20>: 11000000   sethi %hi(hptr), %o0      ! load up hptr (1 of 2)
 229      <24>: 81C26000   jmp   %o1 + %lo(wptr)     ! jump to wptr (load 2 of 2)
 230      <28>: 90122000   or    %o0, %lo(hptr), %o0 ! load up hptr (2 of 2, delay slot)
 231      <2C>  00000000                             ! place for getting hptr back easily
 232
 233      ccall'ing on SPARC is easy, because we are quite lucky to push a
 234      multiple of 8 bytes (1 word hptr + 1 word dummy arg) in front of the
 235      existing arguments (note that %sp must stay double-word aligned at
 236      all times, see ABI spec at http://www.sparc.org/standards/psABI3rd.pdf).
 237      To do this, we extend the *caller's* stack frame by 2 words and shift
 238      the output registers used for argument passing (%o0 - %o5, we are a *leaf*
 239      procedure because of the tail-jump) by 2 positions. This makes room in
 240      %o0 and %o1 for the additinal arguments, namely  hptr and a dummy (used
 241      for destination addr of jump on SPARC, return address on x86, ...). This
 242      shouldn't cause any problems for a C-like caller: alloca is implemented
 243      similarly, and local variables should be accessed via %fp, not %sp. In a
 244      nutshell: This should work! (Famous last words! :-)
 245   */
 246     adjustor = stgMallocBytes(4*(11+1), "createAdjustor");
 247     {
 248         unsigned long *const adj_code = (unsigned long *)adjustor;
 249
 250         adj_code[ 0]  = 0x9C23A008UL;   /* sub   %sp, 8, %sp         */
 251         adj_code[ 1]  = 0xDA23A060UL;   /* st    %o5, [%sp + 96]     */
 252         adj_code[ 2]  = 0xD823A05CUL;   /* st    %o4, [%sp + 92]     */
 253         adj_code[ 3]  = 0x9A10000BUL;   /* mov   %o3, %o5            */
 254         adj_code[ 4]  = 0x9810000AUL;   /* mov   %o2, %o4            */
 255         adj_code[ 5]  = 0x96100009UL;   /* mov   %o1, %o3            */
 256         adj_code[ 6]  = 0x94100008UL;   /* mov   %o0, %o2            */
 257         adj_code[ 7]  = 0x13000000UL;   /* sethi %hi(wptr), %o1      */
 258         adj_code[ 7] |= ((unsigned long)wptr) >> 10;
 259         adj_code[ 8]  = 0x11000000UL;   /* sethi %hi(hptr), %o0      */
 260         adj_code[ 8] |= ((unsigned long)hptr) >> 10;
 261         adj_code[ 9]  = 0x81C26000UL;   /* jmp   %o1 + %lo(wptr)     */
 262         adj_code[ 9] |= ((unsigned long)wptr) & 0x000003FFUL;
 263         adj_code[10]  = 0x90122000UL;   /* or    %o0, %lo(hptr), %o0 */
 264         adj_code[10] |= ((unsigned long)hptr) & 0x000003FFUL;
 265
 266         adj_code[11]  = (unsigned long)hptr;
 267
 268         /* flush cache */
 269         asm("flush %0" : : "r" (adj_code     ));
 270         asm("flush %0" : : "r" (adj_code +  2));
 271         asm("flush %0" : : "r" (adj_code +  4));
 272         asm("flush %0" : : "r" (adj_code +  6));
 273         asm("flush %0" : : "r" (adj_code + 10));
 274
 275         /* max. 5 instructions latency, and we need at >= 1 for returning */
 276         asm("nop");
 277         asm("nop");
 278         asm("nop");
 279         asm("nop");
 280     }
 281 #elif defined(alpha_TARGET_ARCH)
 282   /* Magic constant computed by inspecting the code length of
 283      the following assembly language snippet
 284      (offset and machine code prefixed; note that the machine code
 285      shown is longwords stored in little-endian order):
 286
 287   <00>: 46520414        mov     a2, a4
 288   <04>: 46100412        mov     a0, a2
 289   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 290   <0c>: 46730415        mov     a3, a5
 291   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 292   <14>: 46310413        mov     a1, a3
 293   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 294   <1c>: 00000000                                # padding for alignment
 295   <20>: [8 bytes for hptr quadword]
 296   <28>: [8 bytes for wptr quadword]
 297
 298      The "computed" jump at <08> above is really a jump to a fixed
 299      location.  Accordingly, we place an always-correct hint in the
 300      jump instruction, namely the address offset from <0c> to wptr,
 301      divided by 4, taking the lowest 14 bits.
 302
 303      We only support passing 4 or fewer argument words, for the same
 304      reason described under sparc_TARGET_ARCH above by JRS, 21 Aug 01.
 305      On the Alpha the first 6 integer arguments are in a0 through a5,
 306      and the rest on the stack.  Hence we want to shuffle the original
 307      caller's arguments by two.
 308
 309      On the Alpha the calling convention is so complex and dependent
 310      on the callee's signature -- for example, the stack pointer has
 311      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 312      to handle the general case correctly without changing how the
 313      adjustor is called from C.  For now, our solution of shuffling
 314      registers only and ignoring the stack only works if the original
 315      caller passed 4 or fewer argument words.
 316
 317 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 318       header information (more precisely, if the overhead is no more than
 319       4 bytes), we should move the first three instructions above down by
 320       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 321   */
 322     ASSERT(((StgWord64)wptr & 3) == 0);
 323     adjustor = stgMallocBytes(48, "createAdjustor");
 324     {
 325         StgWord64 *const code = (StgWord64 *)adjustor;
 326
 327         code[0] = 0x4610041246520414L;
 328         code[1] = 0x46730415a61b0020L;
 329         code[2] = 0x46310413a77b0028L;
 330         code[3] = 0x000000006bfb0000L
 331                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 332
 333         code[4] = (StgWord64)hptr;
 334         code[5] = (StgWord64)wptr;
 335
 336         /* Ensure that instruction cache is consistent with our new code */
 337         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 338     }
 339 #elif defined(powerpc_TARGET_ARCH)
 340 /*
 341         For PowerPC, the following code is used:
 342
 343         mr r10,r8
 344         mr r9,r7
 345         mr r8,r6
 346         mr r7,r5
 347         mr r6,r4
 348         mr r5,r3
 349         lis r0,0xDEAD ;hi(wptr)
 350         lis r3,0xDEAF ;hi(hptr)
 351         ori r0,r0,0xBEEF ; lo(wptr)
 352         ori r3,r3,0xFACE ; lo(hptr)
 353         mtctr r0
 354         bctr
 355
 356         The arguments (passed in registers r3 - r10) are shuffled along by two to
 357         make room for hptr and a dummy argument. As r9 and r10 are overwritten by
 358         this code, it only works for up to 6 arguments (when floating point arguments
 359         are involved, this may be more or less, depending on the exact situation).
 360 */
 361         adjustor = stgMallocBytes(4*13, "createAdjustor");
 362         {
 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 void
 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 }