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 "RtsUtils.h"
  42 #include "RtsFlags.h"
  43
  44 /* Heavily arch-specific, I'm afraid.. */
  45 #if defined(i386_TARGET_ARCH) || defined(sparc_TARGET_ARCH) || defined(alpha_TARGET_ARCH) || defined(powerpc_TARGET_ARCH)
  46
  47 #if defined(i386_TARGET_ARCH)
  48 /* Now here's something obscure for you:
  49
  50    When generating an adjustor thunk that uses the C calling
  51    convention, we have to make sure that the thunk kicks off
  52    the process of jumping into Haskell with a tail jump. Why?
  53    Because as a result of jumping in into Haskell we may end
  54    up freeing the very adjustor thunk we came from using
  55    freeHaskellFunctionPtr(). Hence, we better not return to
  56    the adjustor code on our way  out, since it could by then
  57    point to junk.
  58
  59    The fix is readily at hand, just include the opcodes
  60    for the C stack fixup code that we need to perform when
  61    returning in some static piece of memory and arrange
  62    to return to it before tail jumping from the adjustor thunk.
  63
  64    For this to work we make the assumption that bytes in .data
  65    are considered executable.
  66 */
  67 static unsigned char __obscure_ccall_ret_code [] =
  68   { 0x83, 0xc4, 0x04 /* addl $0x4, %esp */
  69   , 0xc3             /* ret */
  70   };
  71 #endif
  72
  73 #if defined(alpha_TARGET_ARCH)
  74 /* To get the definition of PAL_imb: */
  75 #include <machine/pal.h>
  76 #endif
  77
  78 void*
  79 createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr)
  80 {
  81   void *adjustor = NULL;
  82
  83   switch (cconv)
  84   {
  85   case 0: /* _stdcall */
  86 #if defined(i386_TARGET_ARCH)
  87     /* Magic constant computed by inspecting the code length of
  88        the following assembly language snippet
  89        (offset and machine code prefixed):
  90
  91      <0>:       58                popl   %eax              # temp. remove ret addr..
  92      <1>:       68 fd fc fe fa    pushl  0xfafefcfd        # constant is large enough to
  93                                                            # hold a StgStablePtr
  94      <6>:       50                pushl  %eax              # put back ret. addr
  95      <7>:       b8 fa ef ff 00    movl   $0x00ffeffa, %eax # load up wptr
  96      <c>:       ff e0             jmp    %eax              # and jump to it.
  97                 # the callee cleans up the stack
  98     */
  99     if ((adjustor = stgMallocBytes(14, "createAdjustor")) != NULL) {
 100         unsigned char *const adj_code = (unsigned char *)adjustor;
 101         adj_code[0x00] = (unsigned char)0x58;  /* popl %eax  */
 102
 103         adj_code[0x01] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 104         *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr;
 105
 106         adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */
 107
 108         adj_code[0x07] = (unsigned char)0xb8; /* movl  $wptr, %eax */
 109         *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr;
 110
 111         adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */
 112         adj_code[0x0d] = (unsigned char)0xe0;
 113     }
 114 #endif
 115     break;
 116
 117   case 1: /* _ccall */
 118 #if defined(i386_TARGET_ARCH)
 119   /* Magic constant computed by inspecting the code length of
 120      the following assembly language snippet
 121      (offset and machine code prefixed):
 122
 123   <00>: 68 ef be ad de     pushl  $0xdeadbeef      # constant is large enough to
 124                                                    # hold a StgStablePtr
 125   <05>: b8 fa ef ff 00     movl   $0x00ffeffa, %eax # load up wptr
 126   <0a>: 68 ef be ad de     pushl  $__obscure_ccall_ret_code # push the return address
 127   <0f>: ff e0              jmp    *%eax            # jump to wptr
 128
 129     The ccall'ing version is a tad different, passing in the return
 130     address of the caller to the auto-generated C stub (which enters
 131     via the stable pointer.) (The auto-generated C stub is in on this
 132     game, don't worry :-)
 133
 134     See the comment next to __obscure_ccall_ret_code why we need to
 135     perform a tail jump instead of a call, followed by some C stack
 136     fixup.
 137
 138     Note: The adjustor makes the assumption that any return value
 139     coming back from the C stub is not stored on the stack.
 140     That's (thankfully) the case here with the restricted set of
 141     return types that we support.
 142   */
 143     if ((adjustor = stgMallocBytes(17, "createAdjustor")) != NULL) {
 144         unsigned char *const adj_code = (unsigned char *)adjustor;
 145
 146         adj_code[0x00] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 147         *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr;
 148
 149         adj_code[0x05] = (unsigned char)0xb8;  /* movl  $wptr, %eax */
 150         *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr;
 151
 152         adj_code[0x0a] = (unsigned char)0x68;  /* pushl __obscure_ccall_ret_code */
 153         *((StgFunPtr*)(adj_code + 0x0b)) = (StgFunPtr)__obscure_ccall_ret_code;
 154
 155         adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
 156         adj_code[0x10] = (unsigned char)0xe0;
 157     }
 158 #elif defined(sparc_TARGET_ARCH)
 159   /* Magic constant computed by inspecting the code length of
 160      the following assembly language snippet
 161      (offset and machine code prefixed):
 162
 163   <00>: BA 10 00 1B     mov    %i3, %i5
 164   <04>: B8 10 00 1A     mov    %i2, %i4
 165   <08>: B6 10 00 19     mov    %i1, %i3
 166   <0c>: B4 10 00 18     mov    %i0, %i2
 167   <10>: 13 00 3f fb     sethi  %hi(0x00ffeffa), %o1 # load up wptr (1 of 2)
 168   <14>: 11 37 ab 6f     sethi  %hi(0xdeadbeef), %o0 # load up hptr (1 of 2)
 169   <18>: 81 c2 63 fa     jmp    %o1+%lo(0x00ffeffa)  # jump to wptr (load 2 of 2)
 170   <1c>: 90 12 22 ef     or     %o0, %lo(0xdeadbeef), %o0 # load up hptr (2 of 2)
 171                                                          # [in delay slot]
 172   <20>: de ad be ef     # Place the value of the StgStablePtr somewhere readable
 173
 174     ccall'ing on a SPARC leaves little to be performed by the caller.
 175     The callee shifts the window on entry and restores it on exit.
 176     Input paramters and results are passed via registers. (%o0 in the
 177     code above contains the input paramter to wptr.) The return address
 178     is stored in %o7/%i7. Since we don't shift the window in this code,
 179     the return address is preserved and wptr will return to our caller.
 180
 181     JRS, 21 Aug 01: the above para is a fiction.  The caller passes
 182     args in %i0 .. %i5 and then the rest at [%sp+92].  We want to
 183     tailjump to wptr, passing hptr as the new first arg, and a dummy
 184     second arg, which would be where the return address is on x86.
 185     That means we have to shuffle the original caller's args along by
 186     two.
 187
 188     We do a half-correct solution which works only if the original
 189     caller passed 4 or fewer arg words.  Move %i0 .. %i3 into %i3
 190     .. %i6, so we can park hptr in %i0 and a bogus arg in %i1.  The
 191     fully correct solution would be to subtract 8 from %sp and then
 192     place %i4 and %i5 at [%sp+92] and [%sp+96] respectively.  This
 193     machinery should then work in all cases.  (Or would it?  Perhaps
 194     it would trash parts of the caller's frame.  Dunno).
 195
 196     SUP, 25 Apr 02: We are quite lucky to push a multiple of 8 bytes in
 197     front of the existing arguments, because %sp must stay double-word
 198     aligned at all times, see: http://www.sparc.org/standards/psABI3rd.pdf
 199     Although we extend the *caller's* stack frame, this shouldn't cause
 200     any problems for a C-like caller: alloca is implemented similarly, and
 201     local variables should be accessed via %fp, not %sp. In a nutshell:
 202     This should work. (Famous last words! :-)
 203   */
 204     if ((adjustor = stgMallocBytes(4*(8+1), "createAdjustor")) != NULL) {
 205         unsigned long *const adj_code = (unsigned long *)adjustor;
 206
 207         /* mov  %o3, %o5 */
 208         adj_code[0] = (unsigned long)0x9A10000B;
 209         /* mov  %o2, %o4 */
 210         adj_code[1] = (unsigned long)0x9810000A;
 211         /* mov  %o1, %o3 */
 212         adj_code[2] = (unsigned long)0x96100009;
 213         /* mov  %o0, %o2 */
 214         adj_code[3] = (unsigned long)0x94100008;
 215
 216         /* sethi %hi(wptr), %o1 */
 217         adj_code[4] = (unsigned long)0x13000000;
 218         adj_code[4] |= ((unsigned long)wptr) >> 10;
 219
 220         /* sethi %hi(hptr), %o0 */
 221         adj_code[5] = (unsigned long)0x11000000;
 222         adj_code[5] |= ((unsigned long)hptr) >> 10;
 223
 224         /* jmp %o1+%lo(wptr) */
 225         adj_code[6] = (unsigned long)0x81c26000;
 226         adj_code[6] |= ((unsigned long)wptr) & 0x000003ff;
 227
 228         /* or %o0, %lo(hptr), %o0 */
 229         adj_code[7] = (unsigned long)0x90122000;
 230         adj_code[7] |= ((unsigned long)hptr) & 0x000003ff;
 231
 232         adj_code[8] = (StgStablePtr)hptr;
 233
 234         /* flush cache */
 235         asm("flush %0" : : "r" (adj_code    ));
 236         asm("flush %0" : : "r" (adj_code + 2));
 237         asm("flush %0" : : "r" (adj_code + 4));
 238         asm("flush %0" : : "r" (adj_code + 6));
 239
 240         /* max. 5 instructions latency, and we need at >= 1 for returning */
 241         asm("nop");
 242         asm("nop");
 243         asm("nop");
 244         asm("nop");
 245     }
 246 #elif defined(alpha_TARGET_ARCH)
 247   /* Magic constant computed by inspecting the code length of
 248      the following assembly language snippet
 249      (offset and machine code prefixed; note that the machine code
 250      shown is longwords stored in little-endian order):
 251
 252   <00>: 46520414        mov     a2, a4
 253   <04>: 46100412        mov     a0, a2
 254   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 255   <0c>: 46730415        mov     a3, a5
 256   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 257   <14>: 46310413        mov     a1, a3
 258   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 259   <1c>: 00000000                                # padding for alignment
 260   <20>: [8 bytes for hptr quadword]
 261   <28>: [8 bytes for wptr quadword]
 262
 263      The "computed" jump at <08> above is really a jump to a fixed
 264      location.  Accordingly, we place an always-correct hint in the
 265      jump instruction, namely the address offset from <0c> to wptr,
 266      divided by 4, taking the lowest 14 bits.
 267
 268      We only support passing 4 or fewer argument words, for the same
 269      reason described under sparc_TARGET_ARCH above by JRS, 21 Aug 01.
 270      On the Alpha the first 6 integer arguments are in a0 through a5,
 271      and the rest on the stack.  Hence we want to shuffle the original
 272      caller's arguments by two.
 273
 274      On the Alpha the calling convention is so complex and dependent
 275      on the callee's signature -- for example, the stack pointer has
 276      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 277      to handle the general case correctly without changing how the
 278      adjustor is called from C.  For now, our solution of shuffling
 279      registers only and ignoring the stack only works if the original
 280      caller passed 4 or fewer argument words.
 281
 282 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 283       header information (more precisely, if the overhead is no more than
 284       4 bytes), we should move the first three instructions above down by
 285       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 286   */
 287     ASSERT(((StgWord64)wptr & 3) == 0);
 288     if ((adjustor = stgMallocBytes(48, "createAdjustor")) != NULL) {
 289         StgWord64 *const code = (StgWord64 *)adjustor;
 290
 291         code[0] = 0x4610041246520414L;
 292         code[1] = 0x46730415a61b0020L;
 293         code[2] = 0x46310413a77b0028L;
 294         code[3] = 0x000000006bfb0000L
 295                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 296
 297         code[4] = (StgWord64)hptr;
 298         code[5] = (StgWord64)wptr;
 299
 300         /* Ensure that instruction cache is consistent with our new code */
 301         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 302     }
 303 #elif defined(powerpc_TARGET_ARCH)
 304 /*
 305         For PowerPC, the following code is used:
 306
 307         mr r10,r8
 308         mr r9,r7
 309         mr r8,r6
 310         mr r7,r5
 311         mr r6,r4
 312         mr r5,r3
 313         lis r0,0xDEAD ;hi(wptr)
 314         lis r3,0xDEAF ;hi(hptr)
 315         ori r0,r0,0xBEEF ; lo(wptr)
 316         ori r3,r3,0xFACE ; lo(hptr)
 317         mtctr r0
 318         bctr
 319
 320         The arguments (passed in registers r3 - r10) are shuffled along by two to
 321         make room for hptr and a dummy argument. As r9 and r10 are overwritten by
 322         this code, it only works for up to 6 arguments (when floating point arguments
 323         are involved, this may be more or less, depending on the exact situation).
 324 */
 325         if ((adjustor = stgMallocBytes(4*13, "createAdjustor")) != NULL) {
 326                 unsigned long *const adj_code = (unsigned long *)adjustor;
 327
 328                 // make room for extra arguments
 329                 adj_code[0] = 0x7d0a4378;       //mr r10,r8
 330                 adj_code[1] = 0x7ce93b78;       //mr r9,r7
 331                 adj_code[2] = 0x7cc83378;       //mr r8,r6
 332                 adj_code[3] = 0x7ca72b78;       //mr r7,r5
 333                 adj_code[4] = 0x7c862378;       //mr r6,r4
 334                 adj_code[5] = 0x7c651b78;       //mr r5,r3
 335
 336                 adj_code[6] = 0x3c000000;       //lis r0,hi(wptr)
 337                 adj_code[6] |= ((unsigned long)wptr) >> 16;
 338
 339                 adj_code[7] = 0x3c600000;       //lis r3,hi(hptr)
 340                 adj_code[6] |= ((unsigned long)hptr) >> 16;
 341
 342                 adj_code[8] = 0x60000000;       //ori r0,r0,lo(wptr)
 343                 adj_code[8] |= ((unsigned long)wptr) & 0xFFFF;
 344
 345                 adj_code[9] = 0x60630000;       //ori r3,r3,lo(hptr)
 346                 adj_code[9] |= ((unsigned long)hptr) & 0xFFFF;
 347
 348                 adj_code[10] = 0x7c0903a6;      //mtctr r0
 349                 adj_code[11] = 0x4e800420;      //bctr
 350                 adj_code[12] = (unsigned long)hptr;
 351
 352                 // Flush the Instruction cache:
 353                 //      MakeDataExecutable(adjustor,4*13);
 354                         /* This would require us to link with CoreServices.framework */
 355                 {               /* this should do the same: */
 356                         int n = 13;
 357                         unsigned long *p = adj_code;
 358                         while(n--)
 359                         {
 360                                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 361                                                     : : "g" (p));
 362                                 p++;
 363                         }
 364                         __asm__ volatile ("sync\n\tisync");
 365                 }
 366         }
 367 #else
 368 #error Adjustor creation is not supported on this platform.
 369 #endif
 370     break;
 371
 372   default:
 373     ASSERT(0);
 374     break;
 375   }
 376
 377   /* Have fun! */
 378   return adjustor;
 379 }
 380
 381 #endif
 382
 383 void
 384 freeHaskellFunctionPtr(void* ptr)
 385 {
 386 #if defined(i386_TARGET_ARCH)
 387  if ( *(unsigned char*)ptr != 0x68 &&
 388       *(unsigned char*)ptr != 0x58 ) {
 389    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 390    return;
 391  }
 392
 393  /* Free the stable pointer first..*/
 394  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
 395     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
 396  } else {
 397     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
 398  }
 399 #elif defined(sparc_TARGET_ARCH)
 400  if ( *(unsigned long*)ptr != 0x9A10000B ) {
 401    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 402    return;
 403  }
 404
 405  /* Free the stable pointer first..*/
 406  freeStablePtr(*((StgStablePtr*)((unsigned long*)ptr + 8)));
 407 #elif defined(alpha_TARGET_ARCH)
 408  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
 409    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 410    return;
 411  }
 412
 413  /* Free the stable pointer first..*/
 414  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
 415 #elif defined(powerpc_TARGET_ARCH)
 416  if ( *(StgWord*)ptr != 0x7d0a4378 ) {
 417    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 418    return;
 419  }
 420  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 4*12)));
 421 #else
 422  ASSERT(0);
 423 #endif
 424  *((unsigned char*)ptr) = '\0';
 425
 426  free(ptr);
 427 }
 428