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