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