ghc/compiler/ghci/ByteCodeFFI.lhs

   1 %
   2 % (c) The University of Glasgow 2001
   3 %
   4 \section[ByteCodeGen]{Generate machine-code sequences for foreign import}
   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
  15 -- DON'T remove apparently unused imports here .. there is ifdeffery
  16 -- below
  17 import Bits             ( Bits(..), shiftR, shiftL )
  18
  19 import Word             ( Word8, Word32 )
  20 import Addr             ( Addr(..), writeWord8OffAddr )
  21 import Foreign          ( Ptr(..), mallocBytes )
  22 import IOExts           ( trace )
  23
  24 \end{code}
  25
  26 %************************************************************************
  27 %*                                                                      *
  28 \subsection{The sizes of things.  These are platform-independent.}
  29 %*                                                                      *
  30 %************************************************************************
  31
  32 \begin{code}
  33
  34 -- When I push one of these on the H stack, how much does Sp move by?
  35 taggedSizeW :: PrimRep -> Int
  36 taggedSizeW pr
  37    | isFollowableRep pr = 1 {-it's a pointer, Jim-}
  38    | otherwise          = 1 {-the tag-} + getPrimRepSize pr
  39
  40 -- The plain size of something, without tag.
  41 untaggedSizeW :: PrimRep -> Int
  42 untaggedSizeW pr
  43    | isFollowableRep pr = 1
  44    | otherwise          = getPrimRepSize pr
  45
  46 -- How big is this thing's tag?
  47 sizeOfTagW :: PrimRep -> Int
  48 sizeOfTagW pr
  49    | isFollowableRep pr = 0
  50    | otherwise          = 1
  51
  52 -- Blast a bunch of bytes into malloc'd memory and return the addr.
  53 sendBytesToMallocville :: [Word8] -> IO Addr
  54 sendBytesToMallocville bytes
  55    = do let n = length bytes
  56         (Ptr a#) <- mallocBytes n
  57         mapM ( \(off,byte) -> writeWord8OffAddr (A# a#) off byte )
  58              (zip [0 ..] bytes)
  59         return (A# a#)
  60 \end{code}
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsection{The platform-dependent marshall-code-generator.}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 \begin{code}
  69
  70 -- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
  71 #include "nativeGen/NCG.h"
  72
  73 {-
  74 Make a piece of code which expects to see the Haskell stack
  75 looking like this.  It is given a pointer to the lowest word in
  76 the stack -- presumably the tag of the placeholder.
  77
  78                   <arg_n>
  79                   ...
  80                   <arg_1>
  81                   Addr# address_of_C_fn
  82                   <placeholder-for-result#> (must be an unboxed type)
  83
  84 We cope with both ccall and stdcall for the C fn.  However, this code
  85 itself expects only to be called using the ccall convention -- that is,
  86 we don't clear our own (single) arg off the C stack.
  87 -}
  88 mkMarshalCode :: CCallConv
  89               -> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
  90               -> IO Addr
  91 mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
  92    = let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
  93                                    addr_offW arg_offs_n_reps
  94      in  sendBytesToMallocville bytes
  95
  96
  97
  98
  99 mkMarshalCode_wrk :: CCallConv
 100                   -> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
 101                   -> [Word8]
 102
 103 mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
 104
 105 #if i386_TARGET_ARCH
 106
 107    = let -- Don't change this without first consulting Intel Corp :-)
 108          bytes_per_word = 4
 109
 110          -- addr and result bits offsetsW
 111          offset_of_addr_bitsW = addr_offW + sizeOfTagW AddrRep
 112          offset_of_res_bitsW  = r_offW + sizeOfTagW r_rep
 113
 114          offsets_to_pushW
 115             = concat
 116               [ let -- where this arg's bits start
 117                     a_bits_offW = a_offW + sizeOfTagW a_rep
 118                 in
 119                     -- reversed because x86 is little-endian
 120                     reverse
 121                     [a_bits_offW .. a_bits_offW + untaggedSizeW a_rep - 1]
 122
 123                 -- reversed because args are pushed L -> R onto C stack
 124                 | (a_offW, a_rep) <- reverse arg_offs_n_reps
 125               ]
 126
 127          -- some helpers to assemble x86 insns.
 128          movl_offespmem_esi offB        -- movl   offB(%esp), %esi
 129             = [0x8B, 0xB4, 0x24] ++ lit32 offB
 130          movl_offesimem_ecx offB        -- movl   offB(%esi), %ecx
 131             = [0x8B, 0x8E] ++ lit32 offB
 132          save_regs                      -- pushl  all intregs except %esp
 133             = [0x50, 0x53, 0x51, 0x52, 0x56, 0x57, 0x55]
 134          restore_regs                   -- popl   ditto
 135             = [0x5D, 0x5F, 0x5E, 0x5A, 0x59, 0x5B, 0x58]
 136          pushl_ecx                      -- pushl  %ecx
 137             = [0x51]
 138          call_star_ecx                  -- call   * %ecx
 139             = [0xFF, 0xD1]
 140          add_lit_esp lit                -- addl   $lit, %esp
 141             = [0x81, 0xC4] ++ lit32 lit
 142          movl_eax_offesimem offB        -- movl   %eax, offB(%esi)
 143             = [0x89, 0x86] ++ lit32 offB
 144          ret                            -- ret
 145             = [0xC3]
 146          fstpl_offesimem offB           -- fstpl   offB(%esi)
 147             = [0xDD, 0x9E] ++ lit32 offB
 148          fstps_offesimem offB           -- fstps   offB(%esi)
 149             = [0xD9, 0x9E] ++ lit32 offB
 150          lit32 :: Int -> [Word8]
 151          lit32 i = let w32 = (fromIntegral i) :: Word32
 152                    in  map (fromIntegral . ( .&. 0xFF))
 153                            [w32, w32 `shiftR` 8,
 154                             w32 `shiftR` 16,  w32 `shiftR` 24]
 155          {-
 156              2 0000 8BB42478    movl    0x12345678(%esp), %esi
 157              2      563412
 158              3 0007 8B8E7856    movl    0x12345678(%esi), %ecx
 159              3      3412
 160              4
 161              5 000d 50535152    pushl %eax ; pushl %ebx ; pushl %ecx ; pushl  %edx
 162              6 0011 565755      pushl %esi ; pushl %edi ; pushl %ebp
 163              7
 164              8 0014 5D5F5E      popl %ebp ; popl %edi ; popl %esi
 165              9 0017 5A595B58    popl %edx ; popl %ecx ; popl %ebx ; popl %eax
 166             10
 167             11 001b 51          pushl %ecx
 168             12 001c FFD1        call * %ecx
 169             13
 170             14 001e 81C47856    addl $0x12345678, %esp
 171             14      3412
 172             15 0024 89867856    movl %eax, 0x12345678(%esi)
 173             15      3412
 174             16 002a 89967856    movl %edx, 0x12345678(%esi)
 175             16      3412
 176             17
 177             18 0030 DD967856    fstl    0x12345678(%esi)
 178             18      3412
 179             19 0036 DD9E7856    fstpl   0x12345678(%esi)
 180             19      3412
 181             20 003c D9967856    fsts    0x12345678(%esi)
 182             20      3412
 183             21 0042 D99E7856    fstps   0x12345678(%esi)
 184             18
 185             19 0030 C3          ret
 186             20
 187
 188          -}
 189
 190      in
 191      --trace (show (map fst arg_offs_n_reps))
 192      (
 193      {- On entry, top of C stack 0(%esp) is the RA and 4(%esp) is
 194         arg passed from the interpreter.
 195
 196         Push all callee saved regs.  Push all of them anyway ...
 197            pushl       %eax
 198            pushl       %ebx
 199            pushl       %ecx
 200            pushl       %edx
 201            pushl       %esi
 202            pushl       %edi
 203            pushl       %ebp
 204      -}
 205      save_regs
 206
 207      {- Now 28+0(%esp) is RA and 28+4(%esp) is the arg (the H stack ptr).
 208         We'll use %esi as a temporary to point at the H stack, and
 209         %ecx as a temporary to copy via.
 210
 211            movl        28+4(%esp), %esi
 212      -}
 213      ++ movl_offespmem_esi 32
 214
 215      {- For each arg in args_offs_n_reps, examine the associated PrimRep
 216         to determine how many payload (non-tag) words there are, and
 217         whether or not there is a tag.  This gives a bunch of offsets on
 218         the H stack to copy to the C stack:
 219
 220            movl        off1(%esi), %ecx
 221            pushl       %ecx
 222      -}
 223      ++ concatMap (\offW -> movl_offesimem_ecx (bytes_per_word * offW)
 224                             ++ pushl_ecx)
 225                   offsets_to_pushW
 226
 227      {- Get the addr to call into %ecx, bearing in mind that there's
 228         an Addr# tag at the indicated location, and do the call:
 229
 230            movl        4*(1 /*tag*/ +addr_offW)(%esi), %ecx
 231            call        * %ecx
 232      -}
 233      ++ movl_offesimem_ecx (bytes_per_word * offset_of_addr_bitsW)
 234      ++ call_star_ecx
 235
 236      {- Nuke the args just pushed and re-establish %esi at the
 237         H-stack ptr:
 238
 239            addl        $4*number_of_args_pushed, %esp (ccall only)
 240            movl        28+4(%esp), %esi
 241      -}
 242      ++ (if   cconv /= StdCallConv
 243          then add_lit_esp (bytes_per_word * length offsets_to_pushW)
 244          else [])
 245      ++ movl_offespmem_esi 32
 246
 247      {- Depending on what the return type is, get the result
 248         from %eax or %edx:%eax or %st(0).
 249
 250            movl        %eax, 4(%esi)        -- assuming tagged result
 251         or
 252            movl        %edx, 4(%esi)
 253            movl        %eax, 8(%esi)
 254         or
 255            fstpl       4(%esi)
 256         or
 257            fstps       4(%esi)
 258      -}
 259      ++ case r_rep of
 260            CharRep   -> movl_eax_offesimem 4
 261            IntRep    -> movl_eax_offesimem 4
 262            WordRep   -> movl_eax_offesimem 4
 263            AddrRep   -> movl_eax_offesimem 4
 264            DoubleRep -> fstpl_offesimem 4
 265            FloatRep  -> fstps_offesimem 4
 266            VoidRep   -> []
 267            other     -> pprPanic "ByteCodeFFI.mkMarshalCode_wrk(x86)"
 268                                  (ppr r_rep)
 269
 270      {- Restore all the pushed regs and go home.
 271
 272            pushl        %ebp
 273            pushl        %edi
 274            pushl        %esi
 275            pushl        %edx
 276            pushl        %ecx
 277            pushl        %ebx
 278            pushl        %eax
 279
 280            ret
 281      -}
 282      ++ restore_regs
 283      ++ ret
 284      )
 285
 286 #elif sparc_TARGET_ARCH
 287
 288    = let -- At least for sparc V8
 289          bytes_per_word = 4
 290
 291          -- speaks for itself
 292          w32_to_w8s_bigEndian :: Word32 -> [Word8]
 293          w32_to_w8s_bigEndian w
 294             =  [fromIntegral (0xFF .&. (w `shiftR` 24)),
 295                 fromIntegral (0xFF .&. (w `shiftR` 16)),
 296                 fromIntegral (0xFF .&. (w `shiftR` 8)),
 297                 fromIntegral (0xFF .&. w)]
 298
 299          -- addr and result bits offsetsW
 300          offset_of_addr_bitsW = addr_offW + sizeOfTagW AddrRep
 301          offset_of_res_bitsW  = r_offW + sizeOfTagW r_rep
 302
 303          offsets_to_pushW
 304             = concat
 305               [ let -- where this arg's bits start
 306                     a_bits_offW = a_offW + sizeOfTagW a_rep
 307                 in
 308                     [a_bits_offW .. a_bits_offW + untaggedSizeW a_rep - 1]
 309
 310                 | (a_offW, a_rep) <- arg_offs_n_reps
 311               ]
 312
 313          total_argWs    = length offsets_to_pushW
 314          argWs_on_stack = if total_argWs > 6 then total_argWs - 6
 315                                              else 0
 316
 317          -- The stack pointer must be kept 8-byte aligned, which means
 318          -- we need to calculate this quantity too
 319          argWs_on_stack_ROUNDED_UP
 320             | odd argWs_on_stack = 1 + argWs_on_stack
 321             | otherwise          = argWs_on_stack
 322
 323          -- some helpers to assemble sparc insns.
 324          -- REGS
 325          iReg, oReg, gReg, fReg :: Int -> Word32
 326          iReg = fromIntegral . (+ 24)
 327          oReg = fromIntegral . (+ 8)
 328          gReg = fromIntegral . (+ 0)
 329          fReg = fromIntegral
 330
 331          sp = oReg 6
 332          i0 = iReg 0
 333          i7 = iReg 7
 334          o0 = oReg 0
 335          o1 = oReg 1
 336          o7 = oReg 7
 337          g0 = gReg 0
 338          g1 = gReg 1
 339          f0 = fReg 0
 340          f1 = fReg 1
 341
 342          -- INSN templates
 343          insn_r_r_i :: Word32 -> Word32 -> Word32 -> Int -> Word32
 344          insn_r_r_i op3 rs1 rd imm13
 345             = (3 `shiftL` 30)
 346               .|. (rs1 `shiftL` 25)
 347               .|. (op3 `shiftL` 19)
 348               .|. (rd `shiftL` 14)
 349               .|. (1 `shiftL` 13)
 350               .|. mkSimm13 imm13
 351
 352          insn_r_i_r :: Word32 -> Word32 -> Int -> Word32 -> Word32
 353          insn_r_i_r op3 rs1 imm13 rd
 354             = (2 `shiftL` 30)
 355               .|. (rd `shiftL` 25)
 356               .|. (op3 `shiftL` 19)
 357               .|. (rs1 `shiftL` 14)
 358               .|. (1 `shiftL` 13)
 359               .|. mkSimm13 imm13
 360
 361          mkSimm13 :: Int -> Word32
 362          mkSimm13 imm13
 363             = let imm13w = (fromIntegral imm13) :: Word32
 364               in  imm13w .&. 0x1FFF
 365
 366          -- REAL (non-synthetic) insns
 367          -- or %rs1, %rs2, %rd
 368          mkOR :: Word32 -> Word32 -> Word32 -> Word32
 369          mkOR rs1 rs2 rd
 370             = (2 `shiftL` 30)
 371               .|. (rd `shiftL` 25)
 372               .|. (op3_OR `shiftL` 19)
 373               .|. (rs1 `shiftL` 14)
 374               .|. (0 `shiftL` 13)
 375               .|. rs2
 376               where op3_OR = 2 :: Word32
 377
 378          -- ld(int)   [%rs + imm13], %rd
 379          mkLD rs1 imm13 rd = insn_r_r_i 0x00{-op3_LD-} rd rs1 imm13
 380
 381          -- st(int)   %rs, [%rd + imm13]
 382          mkST   = insn_r_r_i 0x04 -- op3_ST
 383
 384          -- st(float) %rs, [%rd + imm13]
 385          mkSTF  = insn_r_r_i 0x24 -- op3_STF
 386
 387          -- jmpl     %rs + imm13, %rd
 388          mkJMPL = insn_r_i_r 0x38 -- op3_JMPL
 389
 390          -- save     %rs + imm13, %rd
 391          mkSAVE = insn_r_i_r 0x3C -- op3_SAVE
 392
 393          -- restore  %rs + imm13, %rd
 394          mkRESTORE = insn_r_i_r 0x3D -- op3_RESTORE
 395
 396          -- SYNTHETIC insns
 397          mkNOP             = mkOR g0 g0 g0
 398          mkCALL reg        = mkJMPL reg 0 o7
 399          mkRET             = mkJMPL i7 8 g0
 400          mkRESTORE_TRIVIAL = mkRESTORE g0 0 g0
 401      in
 402      --trace (show (map fst arg_offs_n_reps))
 403      concatMap w32_to_w8s_bigEndian (
 404
 405      {- On entry, %o0 is the arg passed from the interpreter.  After
 406         the initial save insn, it will be in %i0.  Studying the sparc
 407         docs one would have thought that the minimum frame size is 92
 408         bytes, but gcc always uses at least 112, and indeed there are
 409         segfaults a-plenty with 92.  So I use 112 here as well.  I
 410         don't understand why, tho.
 411      -}
 412      [mkSAVE sp (- ({-92-}112 + 4*argWs_on_stack_ROUNDED_UP)) sp]
 413
 414      {- For each arg in args_offs_n_reps, examine the associated PrimRep
 415         to determine how many payload (non-tag) words there are, and
 416         whether or not there is a tag.  This gives a bunch of offsets on
 417         the H stack.  Move the first 6 words into %o0 .. %o5 and the
 418         rest on the stack, starting at [%sp+92].  Use %g1 as a temp.
 419      -}
 420      ++ let doArgW (offW, wordNo)
 421               | wordNo < 6
 422               = [mkLD i0 (bytes_per_word * offW) (oReg wordNo)]
 423               | otherwise
 424               = [mkLD i0 (bytes_per_word * offW) g1,
 425                  mkST g1 sp (92 + bytes_per_word * (wordNo - 6))]
 426         in
 427             concatMap doArgW (zip offsets_to_pushW [0 ..])
 428
 429      {- Get the addr to call into %g1, bearing in mind that there's
 430         an Addr# tag at the indicated location, and do the call:
 431
 432            ld     [4*(1 /*tag*/ +addr_offW) + %i0], %g1
 433            call   %g1
 434      -}
 435      ++ [mkLD i0 (bytes_per_word * offset_of_addr_bitsW) g1,
 436          mkCALL g1,
 437          mkNOP]
 438
 439      {- Depending on what the return type is, get the result
 440         from %o0 or %o1:%o0 or %f0 or %f1:%f0.
 441
 442            st          %o0, [%i0 + 4]        -- 32 bit int
 443         or
 444            st          %o0, [%i0 + 4]        -- 64 bit int
 445            st          %o1, [%i0 + 8]        -- or the other way round?
 446         or
 447            st          %f0, [%i0 + 4]        -- 32 bit float
 448         or
 449            st          %f0, [%i0 + 4]        -- 64 bit float
 450            st          %f1, [%i0 + 8]        -- or the other way round?
 451
 452      -}
 453      ++ let i32 = [mkST o0 i0 4]
 454             i64 = [mkST o0 i0 4, mkST o1 i0 8]
 455             f32 = [mkSTF f0 i0 4]
 456             f64 = [mkSTF f0 i0 4, mkSTF f1 i0 8]
 457         in
 458             case r_rep of
 459                CharRep   -> i32
 460                IntRep    -> i32
 461                WordRep   -> i32
 462                AddrRep   -> i32
 463                DoubleRep -> f64
 464                FloatRep  -> f32
 465                VoidRep   -> []
 466                other     -> pprPanic "ByteCodeFFI.mkMarshalCode_wrk(sparc)"
 467                                      (ppr r_rep)
 468
 469      ++ [mkRET,
 470          mkRESTORE_TRIVIAL]  -- this is in the delay slot of the RET
 471      )
 472
 473 #else
 474
 475    = undefined
 476
 477 #endif
 478
 479 \end{code}
 480