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 "Rts.h"
  40 #include "RtsUtils.h"
  41 #include "RtsFlags.h"
  42
  43 /* Heavily arch-specific, I'm afraid.. */
  44 #if defined(i386_TARGET_ARCH) || defined(sparc_TARGET_ARCH) || defined(alpha_TARGET_ARCH)
  45
  46 #if defined(i386_TARGET_ARCH)
  47 /* Now here's something obscure for you:
  48
  49    When generating an adjustor thunk that uses the C calling
  50    convention, we have to make sure that the thunk kicks off
  51    the process of jumping into Haskell with a tail jump. Why?
  52    Because as a result of jumping in into Haskell we may end
  53    up freeing the very adjustor thunk we came from using
  54    freeHaskellFunctionPtr(). Hence, we better not return to
  55    the adjustor code on our way  out, since it could by then
  56    point to junk.
  57
  58    The fix is readily at hand, just include the opcodes
  59    for the C stack fixup code that we need to perform when
  60    returning in some static piece of memory and arrange
  61    to return to it before tail jumping from the adjustor thunk.
  62
  63    For this to work we make the assumption that bytes in .data
  64    are considered executable.
  65 */
  66 static unsigned char __obscure_ccall_ret_code [] =
  67   { 0x83, 0xc4, 0x04 /* addl $0x4, %esp */
  68   , 0xc3             /* ret */
  69   };
  70 #endif
  71
  72 void*
  73 createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr)
  74 {
  75   void *adjustor = NULL;
  76
  77   switch (cconv)
  78   {
  79   case 0: /* _stdcall */
  80 #if defined(i386_TARGET_ARCH)
  81     /* Magic constant computed by inspecting the code length of
  82        the following assembly language snippet
  83        (offset and machine code prefixed):
  84
  85      <0>:       58                popl   %eax              # temp. remove ret addr..
  86      <1>:       68 fd fc fe fa    pushl  0xfafefcfd        # constant is large enough to
  87                                                            # hold a StgStablePtr
  88      <6>:       50                pushl  %eax              # put back ret. addr
  89      <7>:       b8 fa ef ff 00    movl   $0x00ffeffa, %eax # load up wptr
  90      <c>:       ff e0             jmp    %eax              # and jump to it.
  91                 # the callee cleans up the stack
  92     */
  93     if ((adjustor = stgMallocBytes(14, "createAdjustor")) != NULL) {
  94         unsigned char *const adj_code = (unsigned char *)adjustor;
  95         adj_code[0x00] = (unsigned char)0x58;  /* popl %eax  */
  96
  97         adj_code[0x01] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
  98         *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr;
  99
 100         adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */
 101
 102         adj_code[0x07] = (unsigned char)0xb8; /* movl  $wptr, %eax */
 103         *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr;
 104
 105         adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */
 106         adj_code[0x0d] = (unsigned char)0xe0;
 107     }
 108 #endif
 109     break;
 110
 111   case 1: /* _ccall */
 112 #if defined(i386_TARGET_ARCH)
 113   /* Magic constant computed by inspecting the code length of
 114      the following assembly language snippet
 115      (offset and machine code prefixed):
 116
 117   <00>: 68 ef be ad de     pushl  $0xdeadbeef      # constant is large enough to
 118                                                    # hold a StgStablePtr
 119   <05>: b8 fa ef ff 00     movl   $0x00ffeffa, %eax # load up wptr
 120   <0a>: 68 ef be ad de     pushl  $__obscure_ccall_ret_code # push the return address
 121   <0f>: ff e0              jmp    *%eax            # jump to wptr
 122
 123     The ccall'ing version is a tad different, passing in the return
 124     address of the caller to the auto-generated C stub (which enters
 125     via the stable pointer.) (The auto-generated C stub is in on this
 126     game, don't worry :-)
 127
 128     See the comment next to __obscure_ccall_ret_code why we need to
 129     perform a tail jump instead of a call, followed by some C stack
 130     fixup.
 131
 132     Note: The adjustor makes the assumption that any return value
 133     coming back from the C stub is not stored on the stack.
 134     That's (thankfully) the case here with the restricted set of
 135     return types that we support.
 136   */
 137     if ((adjustor = stgMallocBytes(17, "createAdjustor")) != NULL) {
 138         unsigned char *const adj_code = (unsigned char *)adjustor;
 139
 140         adj_code[0x00] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 141         *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr;
 142
 143         adj_code[0x05] = (unsigned char)0xb8;  /* movl  $wptr, %eax */
 144         *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr;
 145
 146         adj_code[0x0a] = (unsigned char)0x68;  /* pushl __obscure_ccall_ret_code */
 147         *((StgFunPtr*)(adj_code + 0x0b)) = (StgFunPtr)__obscure_ccall_ret_code;
 148
 149         adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
 150         adj_code[0x10] = (unsigned char)0xe0;
 151     }
 152 #elif defined(sparc_TARGET_ARCH)
 153   /* Magic constant computed by inspecting the code length of
 154      the following assembly language snippet
 155      (offset and machine code prefixed):
 156
 157   <00>: 13 00 3f fb     sethi  %hi(0x00ffeffa), %o1 # load up wptr (1 of 2)
 158   <04>: 11 37 ab 6f     sethi  %hi(0xdeadbeef), %o0 # load up hptr (1 of 2)
 159   <08>: 81 c2 63 fa     jmp    %o1+%lo(0x00ffeffa)  # jump to wptr (load 2 of 2)
 160   <0c>: 90 12 22 ef     or     %o0, %lo(0xdeadbeef), %o0 # load up hptr (2 of 2)
 161                                                          # [in delay slot]
 162   <10>: de ad be ef     # Place the value of the StgStablePtr somewhere readable
 163
 164     ccall'ing on a SPARC leaves little to be performed by the caller.
 165     The callee shifts the window on entry and restores it on exit.
 166     Input paramters and results are passed via registers. (%o0 in the
 167     code above contains the input paramter to wptr.) The return address
 168     is stored in %o7/%i7. Since we don't shift the window in this code,
 169     the return address is preserved and wptr will return to our caller.
 170   */
 171     if ((adjustor = stgMallocBytes(28, "createAdjustor")) != NULL) {
 172         unsigned char *const adj_code = (unsigned char *)adjustor;
 173
 174         /* sethi %hi(wptr), %o1 */
 175         *((unsigned long*)(adj_code+0x00)) = (unsigned long)0x13000000;
 176         *((unsigned long*)(adj_code+0x00)) |= ((unsigned long)wptr) >> 10;
 177
 178         /* sethi %hi(hptr), %o0 */
 179         *((unsigned long*)(adj_code+0x04)) = (unsigned long)0x11000000;
 180         *((unsigned long*)(adj_code+0x04)) |= ((unsigned long)hptr) >> 10;
 181
 182         /* jmp %o1+%lo(wptr) */
 183         *((unsigned long*)(adj_code+0x08)) = (unsigned long)0x81c26000;
 184         *((unsigned long*)(adj_code+0x08)) |= ((unsigned long)wptr) & 0x000003ff;
 185
 186         /* or %o0, %lo(hptr), %o0 */
 187         *((unsigned long*)(adj_code+0x0c)) = (unsigned long)0x90122000;
 188         *((unsigned long*)(adj_code+0x0c)) |= ((unsigned long)hptr) & 0x000003ff;
 189
 190         *((StgStablePtr*)(adj_code+0x10)) = (StgStablePtr)hptr;
 191     }
 192 #elif defined(alpha_TARGET_ARCH)
 193   /* Magic constant computed by inspecting the code length of
 194      the following assembly language snippet
 195      (offset and machine code prefixed; note that the machine code
 196      shown is longwords stored in little-endian order):
 197
 198   <00>: a61b0010        ldq a0, 0x10(pv)        # load up hptr
 199   <04>: a77b0018        ldq pv, 0x18(pv)        # load up wptr
 200   <08>: 6bfbabcd        jmp (pv), 0xabcd        # jump to wptr (with hint)
 201   <0c>: 47ff041f        nop                     # padding for alignment
 202   <10>: [8 bytes for hptr quadword]
 203   <18>: [8 bytes for wptr quadword]
 204
 205      The "computed" jump at <08> above is really a jump to a fixed
 206      location.  Accordingly, we place an always-correct hint in the
 207      jump instruction, namely the address offset from <0c> to wptr,
 208      divided by 4, taking the lowest 14 bits.
 209
 210 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 211       header information (more precisely, if the overhead is no more than
 212       4 bytes), we should move the first three instructions above down by
 213       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 214   */
 215     ASSERT(((StgWord64)wptr & 3) == 0);
 216     if ((adjustor = stgMallocBytes(32, "createAdjustor")) != NULL) {
 217         StgWord64 *const code = (StgWord64 *)adjustor;
 218
 219         code[0] = 0xa77b0018a61b0010L;
 220         code[1] = 0x47ff041f6bfb0000L
 221                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 222
 223         code[2] = (StgWord64)hptr;
 224         code[3] = (StgWord64)wptr;
 225     }
 226 #else
 227 #error Adjustor creation is not supported on this platform.
 228 #endif
 229     break;
 230
 231   default:
 232     ASSERT(0);
 233     break;
 234   }
 235
 236   /* Have fun! */
 237   return adjustor;
 238 }
 239
 240 #endif
 241
 242 void
 243 freeHaskellFunctionPtr(void* ptr)
 244 {
 245 #if defined(i386_TARGET_ARCH)
 246  if ( *(unsigned char*)ptr != 0x68 &&
 247       *(unsigned char*)ptr != 0x58 ) {
 248    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 249    return;
 250  }
 251
 252  /* Free the stable pointer first..*/
 253  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
 254     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
 255  } else {
 256     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
 257  }
 258 #elif defined(sparc_TARGET_ARCH)
 259  if ( *(unsigned char*)ptr != 0x13 ) {
 260    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 261    return;
 262  }
 263
 264  /* Free the stable pointer first..*/
 265  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
 266 #elif defined(sparc_TARGET_ARCH)
 267  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
 268    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 269    return;
 270  }
 271
 272  /* Free the stable pointer first..*/
 273  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
 274 #else
 275  ASSERT(0);
 276 #endif
 277  *((unsigned char*)ptr) = '\0';
 278
 279  free(ptr);
 280 }
 281