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