#include "HsVersions.h"
+import Outputable
import PrimRep ( PrimRep(..), getPrimRepSize, isFollowableRep )
import Bits ( Bits(..), shiftR )
import Word ( Word8, Word32 )
[ let -- where this arg's bits start
a_bits_offW = a_offW + sizeOfTagW a_rep
in
+ reverse
[a_bits_offW .. a_bits_offW + untaggedSizeW a_rep - 1]
| (a_offW, a_rep) <- reverse arg_offs_n_reps
= [0x89, 0x86] ++ lit32 offB
ret -- ret
= [0xC3]
-
+ fstl_offesimem offB -- fstl offB(%esi)
+ = [0xDD, 0x96] ++ lit32 offB
+ fsts_offesimem offB -- fsts offB(%esi)
+ = [0xD9, 0x96] ++ lit32 offB
lit32 :: Int -> [Word8]
lit32 i = let w32 = (fromIntegral i) :: Word32
in map (fromIntegral . ( .&. 0xFF))
15 3412
16 002a 89967856 movl %edx, 0x12345678(%esi)
16 3412
+ 17
+ 18 0030 DD967856 fstl 0x12345678(%esi)
+ 18 3412
+ 19 0036 DD9E7856 fstpl 0x12345678(%esi)
+ 19 3412
+ 20 003c D9967856 fsts 0x12345678(%esi)
+ 20 3412
+ 21 0042 D99E7856 fstps 0x12345678(%esi)
18
19 0030 C3 ret
20
-}
in
- trace (show (map fst arg_offs_n_reps))
+ --trace (show (map fst arg_offs_n_reps))
(
{- On entry, top of C stack 0(%esp) is the RA and 4(%esp) is
arg passed from the interpreter.
movl %edx, 4(%esi)
movl %eax, 8(%esi)
or
- fstpl 4(%esi)
+ fstl 4(%esi)
or
- fstps 4(%esi)
+ fsts 4(%esi)
-}
++ case r_rep of
- IntRep -> movl_eax_offesimem 4
+ IntRep -> movl_eax_offesimem 4
+ WordRep -> movl_eax_offesimem 4
+ AddrRep -> movl_eax_offesimem 4
+ DoubleRep -> fstl_offesimem 4
+ FloatRep -> fsts_offesimem 4
+ other -> pprPanic "ByteCodeFFI.mkMarshalCode_wrk(x86)" (ppr r_rep)
{- Restore all the pushed regs and go home.
(schemeE d s p new_expr)
-schemeE d s p (fvs, AnnCase scrut bndr alts0)
- = let
- alts = case alts0 of
- [(DataAlt dc, [bind1, bind2], rhs)]
- | isUnboxedTupleCon dc
- && VoidRep == typePrimRep (idType bind1)
- -> [(DEFAULT, [bind2], rhs)]
- other
- -> alts0
+{- Convert case .... of (# VoidRep'd-thing, a #) -> ...
+ as
+ case .... of a -> ...
+ Use a as the name of the binder too.
+-}
+schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
+ | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
+ = trace "automagic mashing of case alts (# VoidRep, a #)" (
+ schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)])
+ )
+
+schemeE d s p (fvs, AnnCase scrut bndr alts)
+ = let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
-- When an alt is entered, it assumes the returned value is
scrut_primrep = typePrimRep (idType bndr)
isAlgCase
- = case scrut_primrep of
- CharRep -> False ; AddrRep -> False ; WordRep -> False
- IntRep -> False ; FloatRep -> False ; DoubleRep -> False
- VoidRep -> False ;
- PtrRep -> True
- other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
+ | scrut_primrep == PtrRep
+ = True
+ | scrut_primrep `elem`
+ [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep,
+ VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep,
+ Word8Rep, Word16Rep, Word32Rep, Word64Rep]
+ = False
+ | otherwise
+ = pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep)
-- given an alt, return a discr and code for it.
codeAlt alt@(discr, binds_f, rhs)
= mkMarshalCode (r_offW, r_rep) addr_offW
(zip args_offW a_reps)
in
- trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
+ --trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
target_addr
`seq`
(push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup)
- )
+ --)
| otherwise
= case maybe_dcon of
mkDummyLiteral :: PrimRep -> Literal
mkDummyLiteral pr
= case pr of
- IntRep -> MachInt 0
- _ -> pprPanic "mkDummyLiteral" (ppr pr)
+ IntRep -> MachInt 0
+ DoubleRep -> MachDouble 0
+ FloatRep -> MachFloat 0
+ AddrRep | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0
+ _ -> pprPanic "mkDummyLiteral" (ppr pr)
-- Convert (eg)
code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
do_nptrs off_h off_s [] = nilOL
do_nptrs off_h off_s (npr:nprs)
- = case npr of
- IntRep -> approved ; FloatRep -> approved
- DoubleRep -> approved ; AddrRep -> approved
- CharRep -> approved
- _ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
+ | npr `elem` [IntRep, FloatRep, DoubleRep, CharRep, AddrRep]
+ = approved
+ | otherwise
+ = pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
where
approved = UPK_TAG usizeW (off_h-usizeW) off_s `consOL` theRest
theRest = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
literal st (MachFloat r) = float st (fromRational r)
literal st (MachDouble r) = double st (fromRational r)
literal st (MachChar c) = int st c
- literal st other = pprPanic "ByteCodeLink.mkBits" (ppr other)
+ literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
ctoi_itbl st pk
= addr st ret_itbl_addr
where
- ret_itbl_addr = case pk of
- PtrRep -> stg_ctoi_ret_R1p_info
- WordRep -> stg_ctoi_ret_R1n_info
- IntRep -> stg_ctoi_ret_R1n_info
- AddrRep -> stg_ctoi_ret_R1n_info
- CharRep -> stg_ctoi_ret_R1n_info
- FloatRep -> stg_ctoi_ret_F1_info
- DoubleRep -> stg_ctoi_ret_D1_info
- VoidRep -> stg_ctoi_ret_V_info
- _ -> pprPanic "mkBits.ctoi_itbl" (ppr pk)
+ ret_itbl_addr
+ = case pk of
+ PtrRep -> stg_ctoi_ret_R1p_info
+ WordRep -> stg_ctoi_ret_R1n_info
+ IntRep -> stg_ctoi_ret_R1n_info
+ AddrRep -> stg_ctoi_ret_R1n_info
+ CharRep -> stg_ctoi_ret_R1n_info
+ FloatRep -> stg_ctoi_ret_F1_info
+ DoubleRep -> stg_ctoi_ret_D1_info
+ VoidRep -> stg_ctoi_ret_V_info
+ other -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk)
itoc_itbl st pk
= addr st ret_itbl_addr
where
- ret_itbl_addr = case pk of
- CharRep -> stg_gc_unbx_r1_ret_info
- IntRep -> stg_gc_unbx_r1_ret_info
- FloatRep -> stg_gc_f1_ret_info
- DoubleRep -> stg_gc_d1_ret_info
- VoidRep -> nullAddr
- -- Interpreter.c spots this special case
+ ret_itbl_addr
+ = case pk of
+ CharRep -> stg_gc_unbx_r1_ret_info
+ IntRep -> stg_gc_unbx_r1_ret_info
+ AddrRep -> stg_gc_unbx_r1_ret_info
+ FloatRep -> stg_gc_f1_ret_info
+ DoubleRep -> stg_gc_d1_ret_info
+ VoidRep -> nullAddr
+ -- Interpreter.c spots this special case
+ other -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk)
foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Addr
foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Addr
projects / ghc-hetmet.git / commitdiff