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