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 SMRep            ( CgRep(..), cgRepSizeW )
  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, CgRep) -> Int -> [(Int, CgRep)]
  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, CgRep) -> Int -> [(Int, CgRep)]
  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 + cgRepSizeW 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         CgRep 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            NonPtrArg -> i32
 239            DoubleArg -> f64
 240            FloatArg  -> f32
 241            -- LongArg -> i64
 242            VoidArg   -> []
 243            other     -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(x86)"
 244                                (ppr r_rep)
 245
 246      {- Restore all the pushed regs and go home.
 247
 248            pushl        %ebp
 249            pushl        %edi
 250            pushl        %esi
 251            pushl        %edx
 252            pushl        %ecx
 253            pushl        %ebx
 254            pushl        %eax
 255
 256            ret
 257      -}
 258      ++ restore_regs
 259      ++ ret
 260      )
 261
 262 #elif sparc_TARGET_ARCH
 263
 264    = let -- At least for sparc V8
 265          bytes_per_word = 4
 266
 267          -- speaks for itself
 268          w32_to_w8s_bigEndian :: Word32 -> [Word8]
 269          w32_to_w8s_bigEndian w
 270             =  [fromIntegral (0xFF .&. (w `shiftR` 24)),
 271                 fromIntegral (0xFF .&. (w `shiftR` 16)),
 272                 fromIntegral (0xFF .&. (w `shiftR` 8)),
 273                 fromIntegral (0xFF .&. w)]
 274
 275          offsets_to_pushW
 276             = concat
 277               [  [a_offW .. a_offW + cgRepSizeW a_rep - 1]
 278
 279                 | (a_offW, a_rep) <- arg_offs_n_reps
 280               ]
 281
 282          total_argWs    = length offsets_to_pushW
 283          argWs_on_stack = if total_argWs > 6 then total_argWs - 6
 284                                              else 0
 285
 286          -- The stack pointer must be kept 8-byte aligned, which means
 287          -- we need to calculate this quantity too
 288          argWs_on_stack_ROUNDED_UP
 289             | odd argWs_on_stack = 1 + argWs_on_stack
 290             | otherwise          = argWs_on_stack
 291
 292          -- some helpers to assemble sparc insns.
 293          -- REGS
 294          iReg, oReg, gReg, fReg :: Int -> Word32
 295          iReg = fromIntegral . (+ 24)
 296          oReg = fromIntegral . (+ 8)
 297          gReg = fromIntegral . (+ 0)
 298          fReg = fromIntegral
 299
 300          sp = oReg 6
 301          i0 = iReg 0
 302          i7 = iReg 7
 303          o0 = oReg 0
 304          o1 = oReg 1
 305          o7 = oReg 7
 306          g0 = gReg 0
 307          g1 = gReg 1
 308          f0 = fReg 0
 309          f1 = fReg 1
 310
 311          -- INSN templates
 312          insn_r_r_i :: Word32 -> Word32 -> Word32 -> Int -> Word32
 313          insn_r_r_i op3 rs1 rd imm13
 314             = (3 `shiftL` 30)
 315               .|. (rs1 `shiftL` 25)
 316               .|. (op3 `shiftL` 19)
 317               .|. (rd `shiftL` 14)
 318               .|. (1 `shiftL` 13)
 319               .|. mkSimm13 imm13
 320
 321          insn_r_i_r :: Word32 -> Word32 -> Int -> Word32 -> Word32
 322          insn_r_i_r op3 rs1 imm13 rd
 323             = (2 `shiftL` 30)
 324               .|. (rd `shiftL` 25)
 325               .|. (op3 `shiftL` 19)
 326               .|. (rs1 `shiftL` 14)
 327               .|. (1 `shiftL` 13)
 328               .|. mkSimm13 imm13
 329
 330          mkSimm13 :: Int -> Word32
 331          mkSimm13 imm13
 332             = let imm13w = (fromIntegral imm13) :: Word32
 333               in  imm13w .&. 0x1FFF
 334
 335          -- REAL (non-synthetic) insns
 336          -- or %rs1, %rs2, %rd
 337          mkOR :: Word32 -> Word32 -> Word32 -> Word32
 338          mkOR rs1 rs2 rd
 339             = (2 `shiftL` 30)
 340               .|. (rd `shiftL` 25)
 341               .|. (op3_OR `shiftL` 19)
 342               .|. (rs1 `shiftL` 14)
 343               .|. (0 `shiftL` 13)
 344               .|. rs2
 345               where op3_OR = 2 :: Word32
 346
 347          -- ld(int)   [%rs + imm13], %rd
 348          mkLD rs1 imm13 rd = insn_r_r_i 0x00{-op3_LD-} rd rs1 imm13
 349
 350          -- st(int)   %rs, [%rd + imm13]
 351          mkST   = insn_r_r_i 0x04 -- op3_ST
 352
 353          -- st(float) %rs, [%rd + imm13]
 354          mkSTF  = insn_r_r_i 0x24 -- op3_STF
 355
 356          -- jmpl     %rs + imm13, %rd
 357          mkJMPL = insn_r_i_r 0x38 -- op3_JMPL
 358
 359          -- save     %rs + imm13, %rd
 360          mkSAVE = insn_r_i_r 0x3C -- op3_SAVE
 361
 362          -- restore  %rs + imm13, %rd
 363          mkRESTORE = insn_r_i_r 0x3D -- op3_RESTORE
 364
 365          -- SYNTHETIC insns
 366          mkNOP             = mkOR g0 g0 g0
 367          mkCALL reg        = mkJMPL reg 0 o7
 368          mkRET             = mkJMPL i7 8 g0
 369          mkRESTORE_TRIVIAL = mkRESTORE g0 0 g0
 370      in
 371      --trace (show (map fst arg_offs_n_reps))
 372      concatMap w32_to_w8s_bigEndian (
 373
 374      {- On entry, %o0 is the arg passed from the interpreter.  After
 375         the initial save insn, it will be in %i0.  Studying the sparc
 376         docs one would have thought that the minimum frame size is 92
 377         bytes, but gcc always uses at least 112, and indeed there are
 378         segfaults a-plenty with 92.  So I use 112 here as well.  I
 379         don't understand why, tho.
 380      -}
 381      [mkSAVE sp (- ({-92-}112 + 4*argWs_on_stack_ROUNDED_UP)) sp]
 382
 383      {- For each arg in args_offs_n_reps, examine the associated
 384         CgRep to determine how many words there are.  This gives a
 385         bunch of offsets on the H stack.  Move the first 6 words into
 386         %o0 .. %o5 and the rest on the stack, starting at [%sp+92].
 387         Use %g1 as a temp.
 388      -}
 389      ++ let doArgW (offW, wordNo)
 390               | wordNo < 6
 391               = [mkLD i0 (bytes_per_word * offW) (oReg wordNo)]
 392               | otherwise
 393               = [mkLD i0 (bytes_per_word * offW) g1,
 394                  mkST g1 sp (92 + bytes_per_word * (wordNo - 6))]
 395         in
 396             concatMap doArgW (zip offsets_to_pushW [0 ..])
 397
 398      {- Get the addr to call into %g1, bearing in mind that there's
 399         an Addr# tag at the indicated location, and do the call:
 400
 401            ld     [4*(1 /*tag*/ +addr_offW) + %i0], %g1
 402            call   %g1
 403      -}
 404      ++ [mkLD i0 (bytes_per_word * addr_offW) g1,
 405          mkCALL g1,
 406          mkNOP]
 407
 408      {- Depending on what the return type is, get the result
 409         from %o0 or %o1:%o0 or %f0 or %f1:%f0.
 410
 411            st          %o0, [%i0 + 4]        -- 32 bit int
 412         or
 413            st          %o0, [%i0 + 4]        -- 64 bit int
 414            st          %o1, [%i0 + 8]        -- or the other way round?
 415         or
 416            st          %f0, [%i0 + 4]        -- 32 bit float
 417         or
 418            st          %f0, [%i0 + 4]        -- 64 bit float
 419            st          %f1, [%i0 + 8]        -- or the other way round?
 420
 421      -}
 422      ++ let i32 = [mkST o0 i0 0]
 423             i64 = [mkST o0 i0 0, mkST o1 i0 4]
 424             f32 = [mkSTF f0 i0 0]
 425             f64 = [mkSTF f0 i0 0, mkSTF f1 i0 4]
 426         in
 427             case r_rep of
 428                NonPtrArg -> i32
 429                DoubleArg -> f64
 430                FloatArg  -> f32
 431                VoidArg   -> []
 432                other     -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(sparc)"
 433                                    (ppr r_rep)
 434
 435      ++ [mkRET,
 436          mkRESTORE_TRIVIAL]  -- this is in the delay slot of the RET
 437      )
 438 #elif powerpc_TARGET_ARCH
 439
 440    = let
 441          bytes_per_word = 4
 442
 443          -- speaks for itself
 444          w32_to_w8s_bigEndian :: Word32 -> [Word8]
 445          w32_to_w8s_bigEndian w
 446             =  [fromIntegral (0xFF .&. (w `shiftR` 24)),
 447                 fromIntegral (0xFF .&. (w `shiftR` 16)),
 448                 fromIntegral (0xFF .&. (w `shiftR` 8)),
 449                 fromIntegral (0xFF .&. w)]
 450
 451          -- addr and result bits offsetsW
 452          a_off = addr_offW * bytes_per_word
 453          result_off  = r_offW * bytes_per_word
 454
 455          linkageArea = 24
 456          parameterArea = sum [ cgRepSizeW a_rep * bytes_per_word
 457                         | (_, a_rep) <- arg_offs_n_reps ]
 458          savedRegisterArea = 4
 459          frameSize = padTo16 (linkageArea + max parameterArea 32 + savedRegisterArea)
 460          padTo16 x = case x `mod` 16 of
 461             0 -> x
 462             y -> x - y + 16
 463
 464          pass_parameters [] _ _ = []
 465          pass_parameters ((a_offW, a_rep):args) nextFPR offsetW =
 466             let
 467                haskellArgOffset = a_offW * bytes_per_word
 468                offsetW' = offsetW + cgRepSizeW a_rep
 469
 470                pass_word w
 471                    | offsetW + w < 8 =
 472                       [0x801f0000    -- lwz rX, src(r31)
 473                         .|. (fromIntegral src .&. 0xFFFF)
 474                         .|. (fromIntegral (offsetW+w+3) `shiftL` 21)]
 475                    | otherwise =
 476                       [0x801f0000    -- lwz r0, src(r31)
 477                         .|. (fromIntegral src .&. 0xFFFF),
 478                        0x90010000    -- stw r0, dst(r1)
 479                         .|. (fromIntegral dst .&. 0xFFFF)]
 480                   where
 481                      src = haskellArgOffset + w*bytes_per_word
 482                      dst = linkageArea + (offsetW+w) * bytes_per_word
 483             in
 484                case a_rep of
 485                   FloatArg | nextFPR < 14 ->
 486                       (0xc01f0000    -- lfs fX, haskellArgOffset(r31)
 487                         .|. (fromIntegral haskellArgOffset .&. 0xFFFF)
 488                         .|. (fromIntegral nextFPR `shiftL` 21))
 489                       : pass_parameters args (nextFPR+1) offsetW'
 490                   DoubleArg | nextFPR < 14 ->
 491                       (0xc81f0000    -- lfd fX, haskellArgOffset(r31)
 492                         .|. (fromIntegral haskellArgOffset .&. 0xFFFF)
 493                         .|. (fromIntegral nextFPR `shiftL` 21))
 494                       : pass_parameters args (nextFPR+1) offsetW'
 495                   _ ->
 496                       concatMap pass_word [0 .. cgRepSizeW a_rep - 1]
 497                       ++ pass_parameters args nextFPR offsetW'
 498
 499          gather_result = case r_rep of
 500             VoidArg -> []
 501             FloatArg ->
 502                [0xd03f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
 503                -- stfs f1, result_off(r31)
 504             DoubleArg ->
 505                [0xd83f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
 506                -- stfs f1, result_off(r31)
 507             _ | cgRepSizeW r_rep == 2 ->
 508                [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF),
 509                 0x909f0000 .|. (fromIntegral (result_off+4) .&. 0xFFFF)]
 510                -- stw r3, result_off(r31)
 511                -- stw r4, result_off+4(r31)
 512             _ | cgRepSizeW r_rep == 1 ->
 513                [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
 514                -- stw r3, result_off(r31)
 515      in
 516          concatMap w32_to_w8s_bigEndian $ [
 517             0x7c0802a6,         -- mflr r0
 518             0x93e1fffc,         -- stw r31,-4(r1)
 519             0x90010008,         -- stw r0,8(r1)
 520             0x94210000 .|. (fromIntegral (-frameSize) .&. 0xFFFF),
 521                                 -- stwu r1, -frameSize(r1)
 522             0x7c7f1b78          -- mr r31, r3
 523          ] ++ pass_parameters arg_offs_n_reps 1 0 ++ [
 524             0x819f0000 .|. (fromIntegral a_off .&. 0xFFFF),
 525                                 -- lwz r12, a_off(r31)
 526             0x7d8903a6,         -- mtctr r12
 527             0x4e800421          -- bctrl
 528          ] ++ gather_result ++ [
 529             0x80210000,         -- lwz r1, 0(r1)
 530             0x83e1fffc,         -- lwz r31, -4(r1)
 531             0x80010008,         -- lwz r0, 8(r1)
 532             0x7c0803a6,         -- mtlr r0
 533             0x4e800020          -- blr
 534          ]
 535 #else
 536
 537    = undefined
 538
 539 #endif
 540
 541 \end{code}
 542