ghc/compiler/ghci/ByteCodeFFI.lhs

   1 %
   2 % (c) The University of Glasgow 2000
   3 %
   4 \section[ByteCodeGen]{Generate bytecode from Core}
   5
   6 \begin{code}
   7 module ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode ) where
   8
   9 #include "HsVersions.h"
  10
  11 import Outputable
  12 import PrimRep          ( PrimRep(..), getPrimRepSize, isFollowableRep )
  13 import ForeignCall      ( CCallConv(..) )
  14 import Bits             ( Bits(..), shiftR )
  15 import Word             ( Word8, Word32 )
  16 import Addr             ( Addr(..), writeWord8OffAddr )
  17 import Foreign          ( Ptr(..), mallocBytes )
  18 import IOExts           ( unsafePerformIO, trace )
  19
  20 \end{code}
  21
  22 %************************************************************************
  23 %*                                                                      *
  24 \subsection{The sizes of things.  These are platform-independent.}
  25 %*                                                                      *
  26 %************************************************************************
  27
  28 \begin{code}
  29
  30 -- When I push one of these on the H stack, how much does Sp move by?
  31 taggedSizeW :: PrimRep -> Int
  32 taggedSizeW pr
  33    | isFollowableRep pr = 1 {-it's a pointer, Jim-}
  34    | otherwise          = 1 {-the tag-} + getPrimRepSize pr
  35
  36 -- The plain size of something, without tag.
  37 untaggedSizeW :: PrimRep -> Int
  38 untaggedSizeW pr
  39    | isFollowableRep pr = 1
  40    | otherwise          = getPrimRepSize pr
  41
  42 -- How big is this thing's tag?
  43 sizeOfTagW :: PrimRep -> Int
  44 sizeOfTagW pr
  45    | isFollowableRep pr = 0
  46    | otherwise          = 1
  47
  48 -- Blast a bunch of bytes into malloc'd memory and return the addr.
  49 sendBytesToMallocville :: [Word8] -> IO Addr
  50 sendBytesToMallocville bytes
  51    = do let n = length bytes
  52         (Ptr a#) <- mallocBytes n
  53         mapM ( \(off,byte) -> writeWord8OffAddr (A# a#) off byte )
  54              (zip [0 ..] bytes)
  55         return (A# a#)
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{The platform-dependent marshall-code-generator.}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65
  66 -- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
  67 #include "nativeGen/NCG.h"
  68
  69 {-
  70 Make a piece of code which expects to see the Haskell stack
  71 looking like this.  It is given a pointer to the lowest word in
  72 the stack -- presumably the tag of the placeholder.
  73
  74                   <arg_n>
  75                   ...
  76                   <arg_1>
  77                   Addr# address_of_C_fn
  78                   <placeholder-for-result#> (must be an unboxed type)
  79
  80 We cope with both ccall and stdcall for the C fn.  However, this code
  81 itself expects only to be called using the ccall convention -- that is,
  82 we don't clear our own (single) arg off the C stack.
  83 -}
  84 mkMarshalCode :: CCallConv
  85               -> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
  86               -> Addr
  87 mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
  88    = let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
  89                                    addr_offW arg_offs_n_reps
  90      in  unsafePerformIO (sendBytesToMallocville bytes)
  91
  92
  93
  94
  95 mkMarshalCode_wrk :: CCallConv
  96                   -> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
  97                   -> [Word8]
  98
  99 #if i386_TARGET_ARCH
 100
 101 mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
 102
 103    = let -- Don't change this without first consulting Intel Corp :-)
 104          bytes_per_word = 4
 105
 106          -- addr and result bits offsetsW
 107          offset_of_addr_bitsW = addr_offW + sizeOfTagW AddrRep
 108          offset_of_res_bitsW  = r_offW + sizeOfTagW r_rep
 109
 110          offsets_to_pushW
 111             = concat
 112               [ let -- where this arg's bits start
 113                     a_bits_offW = a_offW + sizeOfTagW a_rep
 114                 in
 115                     reverse
 116                     [a_bits_offW .. a_bits_offW + untaggedSizeW a_rep - 1]
 117
 118                 | (a_offW, a_rep) <- reverse arg_offs_n_reps
 119               ]
 120
 121          -- some helpers to assemble x86 insns.
 122          movl_offespmem_esi offB        -- movl   offB(%esp), %esi
 123             = [0x8B, 0xB4, 0x24] ++ lit32 offB
 124          movl_offesimem_ecx offB        -- movl   offB(%esi), %ecx
 125             = [0x8B, 0x8E] ++ lit32 offB
 126          save_regs                      -- pushl  all intregs except %esp
 127             = [0x50, 0x53, 0x51, 0x52, 0x56, 0x57, 0x55]
 128          restore_regs                   -- popl   ditto
 129             = [0x5D, 0x5F, 0x5E, 0x5A, 0x59, 0x5B, 0x58]
 130          pushl_ecx                      -- pushl  %ecx
 131             = [0x51]
 132          call_star_ecx                  -- call   * %ecx
 133             = [0xFF, 0xD1]
 134          add_lit_esp lit                -- addl   $lit, %esp
 135             = [0x81, 0xC4] ++ lit32 lit
 136          movl_eax_offesimem offB        -- movl   %eax, offB(%esi)
 137             = [0x89, 0x86] ++ lit32 offB
 138          ret                            -- ret
 139             = [0xC3]
 140          fstpl_offesimem offB           -- fstpl   offB(%esi)
 141             = [0xDD, 0x9E] ++ lit32 offB
 142          fstps_offesimem offB           -- fstps   offB(%esi)
 143             = [0xD9, 0x9E] ++ lit32 offB
 144          lit32 :: Int -> [Word8]
 145          lit32 i = let w32 = (fromIntegral i) :: Word32
 146                    in  map (fromIntegral . ( .&. 0xFF))
 147                            [w32, w32 `shiftR` 8,
 148                             w32 `shiftR` 16,  w32 `shiftR` 24]
 149          {-
 150              2 0000 8BB42478    movl    0x12345678(%esp), %esi
 151              2      563412
 152              3 0007 8B8E7856    movl    0x12345678(%esi), %ecx
 153              3      3412
 154              4
 155              5 000d 50535152    pushl %eax ; pushl %ebx ; pushl %ecx ; pushl  %edx
 156              6 0011 565755      pushl %esi ; pushl %edi ; pushl %ebp
 157              7
 158              8 0014 5D5F5E      popl %ebp ; popl %edi ; popl %esi
 159              9 0017 5A595B58    popl %edx ; popl %ecx ; popl %ebx ; popl %eax
 160             10
 161             11 001b 51          pushl %ecx
 162             12 001c FFD1        call * %ecx
 163             13
 164             14 001e 81C47856    addl $0x12345678, %esp
 165             14      3412
 166             15 0024 89867856    movl %eax, 0x12345678(%esi)
 167             15      3412
 168             16 002a 89967856    movl %edx, 0x12345678(%esi)
 169             16      3412
 170             17
 171             18 0030 DD967856    fstl    0x12345678(%esi)
 172             18      3412
 173             19 0036 DD9E7856    fstpl   0x12345678(%esi)
 174             19      3412
 175             20 003c D9967856    fsts    0x12345678(%esi)
 176             20      3412
 177             21 0042 D99E7856    fstps   0x12345678(%esi)
 178             18
 179             19 0030 C3          ret
 180             20
 181
 182          -}
 183
 184      in
 185      --trace (show (map fst arg_offs_n_reps))
 186      (
 187      {- On entry, top of C stack 0(%esp) is the RA and 4(%esp) is
 188         arg passed from the interpreter.
 189
 190         Push all callee saved regs.  Push all of them anyway ...
 191            pushl       %eax
 192            pushl       %ebx
 193            pushl       %ecx
 194            pushl       %edx
 195            pushl       %esi
 196            pushl       %edi
 197            pushl       %ebp
 198      -}
 199      save_regs
 200
 201      {- Now 28+0(%esp) is RA and 28+4(%esp) is the arg (the H stack ptr).
 202         We'll use %esi as a temporary to point at the H stack, and
 203         %ecx as a temporary to copy via.
 204
 205            movl        28+4(%esp), %esi
 206      -}
 207      ++ movl_offespmem_esi 32
 208
 209      {- For each arg in args_offs_n_reps, examine the associated PrimRep
 210         to determine how many payload (non-tag) words there are, and
 211         whether or not there is a tag.  This gives a bunch of offsets on
 212         the H stack to copy to the C stack:
 213
 214            movl        off1(%esi), %ecx
 215            pushl       %ecx
 216      -}
 217      ++ concatMap (\offW -> movl_offesimem_ecx (bytes_per_word * offW)
 218                             ++ pushl_ecx)
 219                   offsets_to_pushW
 220
 221      {- Get the addr to call into %ecx, bearing in mind that there's
 222         an Addr# tag at the indicated location, and do the call:
 223
 224            movl        4*(1 /*tag*/ +addr_offW)(%esi), %ecx
 225            call        * %ecx
 226      -}
 227      ++ movl_offesimem_ecx (bytes_per_word * offset_of_addr_bitsW)
 228      ++ call_star_ecx
 229
 230      {- Nuke the args just pushed and re-establish %esi at the
 231         H-stack ptr:
 232
 233            addl        $4*number_of_args_pushed, %esp (ccall only)
 234            movl        28+4(%esp), %esi
 235      -}
 236      ++ (if   cconv /= StdCallConv
 237          then add_lit_esp (bytes_per_word * length offsets_to_pushW)
 238          else [])
 239      ++ movl_offespmem_esi 32
 240
 241      {- Depending on what the return type is, get the result
 242         from %eax or %edx:%eax or %st(0).
 243
 244            movl        %eax, 4(%esi)        -- assuming tagged result
 245         or
 246            movl        %edx, 4(%esi)
 247            movl        %eax, 8(%esi)
 248         or
 249            fstpl       4(%esi)
 250         or
 251            fstps       4(%esi)
 252      -}
 253      ++ case r_rep of
 254            IntRep    -> movl_eax_offesimem 4
 255            WordRep   -> movl_eax_offesimem 4
 256            AddrRep   -> movl_eax_offesimem 4
 257            DoubleRep -> fstpl_offesimem 4
 258            FloatRep  -> fstps_offesimem 4
 259            VoidRep   -> []
 260            other     -> pprPanic "ByteCodeFFI.mkMarshalCode_wrk(x86)" (ppr r_rep)
 261
 262      {- Restore all the pushed regs and go home.
 263
 264            pushl        %ebp
 265            pushl        %edi
 266            pushl        %esi
 267            pushl        %edx
 268            pushl        %ecx
 269            pushl        %ebx
 270            pushl        %eax
 271
 272            ret
 273      -}
 274      ++ restore_regs
 275      ++ ret
 276      )
 277
 278 #endif /* i386_TARGET_ARCH */
 279
 280 \end{code}
 281