ghc-9.14.1: GHC/ByteCode/Asm.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
--
-- (c) The University of Glasgow 2002-2006
--
-- | Bytecode assembler and linker
module GHC.ByteCode.Asm (
assembleBCOs,
bcoFreeNames,
SizedSeq, sizeSS, ssElts,
iNTERP_STACK_CHECK_THRESH,
mkNativeCallInfoLit,
-- * For testing
assembleBCO
) where
import GHC.Prelude hiding ( any )
import GHC.ByteCode.Instr
import GHC.ByteCode.InfoTable
import GHC.ByteCode.Types
import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Literal
import GHC.Types.Unique.DSet
import GHC.Types.SptEntry
import GHC.Types.Unique.FM
import GHC.Unit.Types
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.TyCon
import GHC.Data.SizedSeq
import GHC.Data.SmallArray
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Cmm.Expr
import GHC.Cmm.Reg ( GlobalArgRegs(..) )
import GHC.Cmm.CallConv ( allArgRegsCover )
import GHC.Platform
import GHC.Platform.Profile
import Language.Haskell.Syntax.Module.Name
import Control.Monad
import qualified Control.Monad.Trans.State.Strict as MTL
import qualified Data.Array.Unboxed as Array
import qualified Data.Array.IO as Array
import Data.Array.Base ( UArray(..), numElements, unsafeFreeze )
#if ! defined(DEBUG)
import Data.Array.Base ( unsafeWrite )
#endif
import Foreign hiding (shiftL, shiftR)
import Data.ByteString (ByteString)
import Data.Char (ord)
import Data.Maybe (fromMaybe)
import GHC.Float (castFloatToWord32, castDoubleToWord64)
import qualified Data.List as List ( any )
import GHC.Exts
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
-- CompiledByteCode represents the result of byte-code
-- compiling a bunch of functions and data types
-- | Finds external references. Remember to remove the names
-- defined by this group of BCOs themselves
bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
bcoFreeNames bco
= bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]
where
bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
= unionManyUniqDSets (
mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] :
mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] :
map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ]
)
-- -----------------------------------------------------------------------------
-- The bytecode assembler
-- The object format for bytecodes is: 16 bits for the opcode, and 16
-- for each field -- so the code can be considered a sequence of
-- 16-bit ints. Each field denotes either a stack offset or number of
-- items on the stack (eg SLIDE), and index into the pointer table (eg
-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
-- bytecode address in this BCO.
-- Top level assembler fn.
assembleBCOs
:: Profile
-> FlatBag (ProtoBCO Name)
-> [TyCon]
-> [(Name, ByteString)]
-> Maybe InternalModBreaks
-> [SptEntry]
-> IO CompiledByteCode
assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do
-- TODO: the profile should be bundled with the interpreter: the rts ways are
-- fixed for an interpreter
let itbls = mkITbls profile tycons
bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos
return CompiledByteCode
{ bc_bcos = bcos
, bc_itbls = itbls
, bc_strs = top_strs
, bc_breaks = modbreaks
, bc_spt_entries = spt_entries
}
-- Note [Allocating string literals]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Our strategy for handling top-level string literal bindings is described in
-- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode,
-- but not all Addr# literals in a program are guaranteed to be lifted to the
-- top level. Our strategy for handling local Addr# literals is somewhat simpler:
-- after assembling, we find all the BCONPtrStr arguments in the program, malloc
-- memory for them, and bake the resulting addresses into the instruction stream
-- in the form of BCONPtrWord arguments.
--
-- We used to allocate remote buffers for BCONPtrStr ByteStrings when
-- assembling, but this gets in the way of bytecode serialization: we
-- want the ability to serialize and reload assembled bytecode, so
-- it's better to preserve BCONPtrStr as-is, and only perform the
-- actual allocation at link-time.
--
-- Note that, as with top-level string literal bindings, this memory is never
-- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for
-- top-level string literal bindings] in GHC.StgToByteCode for some discussion
-- about why.
--
data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)
, ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)
, lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr )
}
data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16)
, final_ptr_array :: !(SmallArray BCOPtr)
, final_lit_array :: !(SmallArray BCONPtr) }
-- How many words we have written so far.
data AsmState = AsmState { nisn :: !Int, nptr :: !Int, nlit :: !Int }
{-# NOINLINE inspectInstrs #-}
-- | Perform analysis of the bytecode to determine
-- 1. How many instructions we will produce
-- 2. If we are going to need long jumps.
-- 3. The offsets that labels refer to
inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState
inspectInstrs platform long_jump e instrs =
inspectAsm long_jump e (mapM_ (assembleInspectAsm platform) instrs)
{-# NOINLINE runInstrs #-}
-- | Assemble the bytecode from the instructions.
runInstrs :: Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult
runInstrs platform long_jumps is_state instrs = do
-- Produce arrays of exactly the right size, corresponding to the result of inspectInstrs.
isn_array <- Array.newArray_ (0, (fromIntegral $ instrCount is_state) - 1)
ptr_array <- newSmallArrayIO (fromIntegral $ ptrCount is_state) undefined
lit_array <- newSmallArrayIO (fromIntegral $ litCount is_state) undefined
let env :: LocalLabel -> Word
env lbl = fromMaybe
(pprPanic "assembleBCO.findLabel" (ppr lbl))
(lookupUFM (lblEnv is_state) lbl)
let initial_state = AsmState 0 0 0
let initial_reader = RunAsmReader{..}
runAsm long_jumps env initial_reader initial_state (mapM_ (\i -> assembleRunAsm platform i) instrs)
final_isn_array <- unsafeFreeze isn_array
final_ptr_array <- unsafeFreezeSmallArrayIO ptr_array
final_lit_array <- unsafeFreezeSmallArrayIO lit_array
return $ RunAsmResult {..}
assembleRunAsm :: Platform -> BCInstr -> RunAsm ()
assembleRunAsm p i = assembleI @RunAsm p i
assembleInspectAsm :: Platform -> BCInstr -> InspectAsm ()
assembleInspectAsm p i = assembleI @InspectAsm p i
assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO platform
(ProtoBCO { protoBCOName = nm
, protoBCOInstrs = instrs
, protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize
, protoBCOArity = arity }) = do
-- pass 1: collect up the offsets of the local labels.
let initial_offset = 0
-- Jump instructions are variable-sized, there are long and short variants
-- depending on the magnitude of the offset. However, we can't tell what
-- size instructions we will need until we have calculated the offsets of
-- the labels, which depends on the size of the instructions... So we
-- first create the label environment assuming that all jumps are short,
-- and if the final size is indeed small enough for short jumps, we are
-- done. Otherwise, we repeat the calculation, and we force all jumps in
-- this BCO to be long.
is0 = inspectInstrs platform False initial_offset instrs
(is1, long_jumps)
| isLargeInspectState is0
= (inspectInstrs platform True initial_offset instrs, True)
| otherwise = (is0, False)
-- pass 2: run assembler and generate instructions, literals and pointers
RunAsmResult{..} <- runInstrs platform long_jumps is1 instrs
-- precomputed size should be equal to final size
massertPpr (fromIntegral (instrCount is1) == numElements final_isn_array
&& fromIntegral (ptrCount is1) == sizeofSmallArray final_ptr_array
&& fromIntegral (litCount is1) == sizeofSmallArray final_lit_array)
(text "bytecode instruction count mismatch")
let !insns_arr = mkBCOByteArray $ final_isn_array
!bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap
ul_bco = UnlinkedBCO { unlinkedBCOName = nm
, unlinkedBCOArity = arity
, unlinkedBCOInstrs = insns_arr
, unlinkedBCOBitmap = bitmap_arr
, unlinkedBCOLits = fromSmallArray final_lit_array
, unlinkedBCOPtrs = fromSmallArray final_ptr_array
}
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
-- we figure out what to do.
-- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
return ul_bco
-- | Construct a word-array containing an @StgLargeBitmap@.
mkBitmapArray :: Word -> [StgWord] -> UArray Int Word
-- Here the return type must be an array of Words, not StgWords,
-- because the underlying ByteArray# will end up as a component
-- of a BCO object.
mkBitmapArray bsize bitmap
= Array.listArray (0, length bitmap) $
fromIntegral bsize : map (fromInteger . fromStgWord) bitmap
data Operand
= Op Word
| IOp Int
| SmallOp Word16
| LabelOp LocalLabel
wOp :: WordOff -> Operand
wOp = Op . fromIntegral
bOp :: ByteOff -> Operand
bOp = Op . fromIntegral
truncHalfWord :: Platform -> HalfWord -> Operand
truncHalfWord platform w = case platformWordSize platform of
PW4 | w <= 65535 -> Op (fromIntegral w)
PW8 | w <= 4294967295 -> Op (fromIntegral w)
_ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w)
ptr :: MonadAssembler m => BCOPtr -> m Word
ptr = ioptr . return
type LabelEnv = LocalLabel -> Word
largeOp :: Bool -> Operand -> Bool
largeOp long_jumps op = case op of
SmallOp _ -> False
Op w -> isLargeW w
IOp i -> isLargeI i
LabelOp _ -> long_jumps
newtype RunAsm a = RunAsm' { runRunAsm :: Bool
-> LabelEnv
-> RunAsmReader
-> AsmState
-> IO (AsmState, a) }
pattern RunAsm :: (Bool -> LabelEnv -> RunAsmReader -> AsmState -> IO (AsmState, a))
-> RunAsm a
pattern RunAsm m <- RunAsm' m
where
RunAsm m = RunAsm' (oneShot $ \a -> oneShot $ \b -> oneShot $ \c -> oneShot $ \d -> m a b c d)
{-# COMPLETE RunAsm #-}
instance Functor RunAsm where
fmap f (RunAsm x) = RunAsm (\a b c !s -> fmap (fmap f) (x a b c s))
instance Applicative RunAsm where
pure x = RunAsm $ \_ _ _ !s -> pure (s, x)
(RunAsm f) <*> (RunAsm x) = RunAsm $ \a b c !s -> do
(!s', f') <- f a b c s
(!s'', x') <- x a b c s'
return (s'', f' x')
{-# INLINE (<*>) #-}
instance Monad RunAsm where
return = pure
(RunAsm m) >>= f = RunAsm $ \a b c !s -> m a b c s >>= \(s', r) -> runRunAsm (f r) a b c s'
{-# INLINE (>>=) #-}
runAsm :: Bool -> LabelEnv -> RunAsmReader -> AsmState -> RunAsm a -> IO a
runAsm long_jumps e r s (RunAsm'{runRunAsm}) = fmap snd $ runRunAsm long_jumps e r s
expand :: PlatformWordSize -> Bool -> Operand -> RunAsm ()
expand word_size largeArgs o = do
e <- askEnv
case o of
(SmallOp w) -> writeIsn w
(LabelOp w) -> let !r = e w in handleLargeArg r
(Op w) -> handleLargeArg w
(IOp i) -> handleLargeArg i
where
handleLargeArg :: Integral a => a -> RunAsm ()
handleLargeArg w =
if largeArgs
then largeArg word_size (fromIntegral w)
else writeIsn (fromIntegral w)
lift :: IO a -> RunAsm a
lift io = RunAsm $ \_ _ _ s -> io >>= \a -> pure (s, a)
askLongJumps :: RunAsm Bool
askLongJumps = RunAsm $ \a _ _ s -> pure (s, a)
askEnv :: RunAsm LabelEnv
askEnv = RunAsm $ \_ b _ s -> pure (s, b)
writePtr :: BCOPtr -> RunAsm Word
writePtr w
= RunAsm $ \_ _ (RunAsmReader{..}) asm -> do
writeSmallArrayIO ptr_array (nptr asm) w
let !n' = nptr asm + 1
let !asm' = asm { nptr = n' }
return (asm', fromIntegral (nptr asm))
writeLit :: BCONPtr -> RunAsm Word
writeLit w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do
writeSmallArrayIO lit_array (nlit asm) w
let !n' = nlit asm + 1
let !asm' = asm { nlit = n' }
return (asm', fromIntegral (nlit asm))
writeLits :: OneOrTwo BCONPtr -> RunAsm Word
writeLits (OnlyOne l) = writeLit l
writeLits (OnlyTwo l1 l2) = writeLit l1 <* writeLit l2
writeIsn :: Word16 -> RunAsm ()
writeIsn w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do
#if defined(DEBUG)
Array.writeArray isn_array (nisn asm) w
#else
unsafeWrite isn_array (nisn asm) w
#endif
let !n' = nisn asm + 1
let !asm' = asm { nisn = n' }
return (asm', ())
{-# INLINE any #-}
-- Any is unrolled manually so that the call in `emit` can be eliminated without
-- relying on SpecConstr (which does not work across modules).
any :: (a -> Bool) -> [a] -> Bool
any _ [] = False
any f [x] = f x
any f [x,y] = f x || f y
any f [x,y,z] = f x || f y || f z
any f [x1,x2,x3,x4] = f x1 || f x2 || f x3 || f x4
any f [x1,x2,x3,x4, x5] = f x1 || f x2 || f x3 || f x4 || f x5
any f [x1,x2,x3,x4,x5,x6] = f x1 || f x2 || f x3 || f x4 || f x5 || f x6
any f xs = List.any f xs
{-# INLINE mapM6_ #-}
mapM6_ :: Monad m => (a -> m b) -> [a] -> m ()
mapM6_ _ [] = return ()
mapM6_ f [x] = () <$ f x
mapM6_ f [x,y] = () <$ f x <* f y
mapM6_ f [x,y,z] = () <$ f x <* f y <* f z
mapM6_ f [a1,a2,a3,a4] = () <$ f a1 <* f a2 <* f a3 <* f a4
mapM6_ f [a1,a2,a3,a4,a5] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5
mapM6_ f [a1,a2,a3,a4,a5,a6] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 <* f a6
mapM6_ f xs = mapM_ f xs
instance MonadAssembler RunAsm where
ioptr p_io = do
p <- lift p_io
writePtr p
lit lits = writeLits lits
label _ = return ()
emit pwordsize w ops = do
long_jumps <- askLongJumps
-- See the definition of `any` above
let largeArgs = any (largeOp long_jumps) ops
let opcode
| largeArgs = largeArgInstr w
| otherwise = w
writeIsn opcode
mapM6_ (expand pwordsize largeArgs) ops
{-# INLINE emit #-}
{-# INLINE label #-}
{-# INLINE lit #-}
{-# INLINE ioptr #-}
type LabelEnvMap = UniqFM LocalLabel Word
data InspectState = InspectState
{ instrCount :: !Word
, ptrCount :: !Word
, litCount :: !Word
, lblEnv :: LabelEnvMap
}
instance Outputable InspectState where
ppr (InspectState i p l m) = text "InspectState" <+> ppr [ppr i, ppr p, ppr l, ppr (sizeUFM m)]
isLargeInspectState :: InspectState -> Bool
isLargeInspectState InspectState{..} =
isLargeW (fromIntegral $ sizeUFM lblEnv)
|| isLargeW instrCount
newtype InspectEnv = InspectEnv { _inspectLongJumps :: Bool
}
newtype InspectAsm a = InspectAsm' { runInspectAsm :: InspectEnv -> InspectState -> (# InspectState, a #) }
pattern InspectAsm :: (InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
pattern InspectAsm m <- InspectAsm' m
where
InspectAsm m = InspectAsm' (oneShot $ \a -> oneShot $ \b -> m a b)
{-# COMPLETE InspectAsm #-}
instance Functor InspectAsm where
fmap f (InspectAsm k) = InspectAsm $ \a b -> case k a b of
(# b', c #) -> (# b', f c #)
instance Applicative InspectAsm where
pure x = InspectAsm $ \_ s -> (# s, x #)
(InspectAsm f) <*> (InspectAsm x) = InspectAsm $ \a b -> case f a b of
(# s', f' #) ->
case x a s' of
(# s'', x' #) -> (# s'', f' x' #)
instance Monad InspectAsm where
return = pure
(InspectAsm m) >>= f = InspectAsm $ \ a b -> case m a b of
(# s', a' #) -> runInspectAsm (f a') a s'
get_ :: InspectAsm InspectState
get_ = InspectAsm $ \_ b -> (# b, b #)
put_ :: InspectState -> InspectAsm ()
put_ !s = InspectAsm $ \_ _ -> (# s, () #)
modify_ :: (InspectState -> InspectState) -> InspectAsm ()
modify_ f = InspectAsm $ \_ s -> let !s' = f s in (# s', () #)
ask_ :: InspectAsm InspectEnv
ask_ = InspectAsm $ \a b -> (# b, a #)
inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState
inspectAsm long_jumps initial_offset (InspectAsm s) =
case s (InspectEnv long_jumps) (InspectState initial_offset 0 0 emptyUFM) of
(# res, () #) -> res
{-# INLINE inspectAsm #-}
instance MonadAssembler InspectAsm where
ioptr _ = do
s <- get_
let n = ptrCount s
put_ (s { ptrCount = n + 1 })
return n
lit ls = do
s <- get_
let n = litCount s
put_ (s { litCount = n + oneTwoLength ls })
return n
label lbl = modify_ (\s -> let !count = instrCount s in let !env' = addToUFM (lblEnv s) lbl count in s { lblEnv = env' })
emit pwordsize _ ops = do
InspectEnv long_jumps <- ask_
-- Size is written in this way as `mapM6_` is also used by RunAsm, and guaranteed
-- to unroll for arguments up to size 6.
let size = (MTL.execState (mapM6_ (\x -> MTL.modify (count' x +)) ops) 0) + 1
largeOps = any (largeOp long_jumps) ops
bigSize = largeArg16s pwordsize
count' = if largeOps then countLarge bigSize else countSmall bigSize
s <- get_
put_ (s { instrCount = instrCount s + size })
{-# INLINE emit #-}
{-# INLINE label #-}
{-# INLINE lit #-}
{-# INLINE ioptr #-}
count :: Word -> Bool -> Operand -> Word
count _ _ (SmallOp _) = 1
count big largeOps (LabelOp _) = if largeOps then big else 1
count big largeOps (Op _) = if largeOps then big else 1
count big largeOps (IOp _) = if largeOps then big else 1
{-# INLINE count #-}
countSmall, countLarge :: Word -> Operand -> Word
countLarge big x = count big True x
countSmall big x = count big False x
-- Bring in all the bci_ bytecode constants.
#include "Bytecodes.h"
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
{-# INLINE largeArg #-}
largeArg :: PlatformWordSize -> Word64 -> RunAsm ()
largeArg wsize w = case wsize of
PW8 -> do writeIsn (fromIntegral (w `shiftR` 48))
writeIsn (fromIntegral (w `shiftR` 32))
writeIsn (fromIntegral (w `shiftR` 16))
writeIsn (fromIntegral w)
PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32))
(text "largeArg too big:" <+> ppr w) $ do
writeIsn (fromIntegral (w `shiftR` 16))
writeIsn (fromIntegral w)
largeArg16s :: PlatformWordSize -> Word
largeArg16s pwordsize = case pwordsize of
PW8 -> 4
PW4 -> 2
data OneOrTwo a = OnlyOne a | OnlyTwo a a deriving (Functor)
oneTwoLength :: OneOrTwo a -> Word
oneTwoLength (OnlyOne {}) = 1
oneTwoLength (OnlyTwo {}) = 2
class Monad m => MonadAssembler m where
ioptr :: IO BCOPtr -> m Word
lit :: OneOrTwo BCONPtr -> m Word
label :: LocalLabel -> m ()
emit :: PlatformWordSize -> Word16 -> [Operand] -> m ()
lit1 :: MonadAssembler m => BCONPtr -> m Word
lit1 p = lit (OnlyOne p)
{-# SPECIALISE assembleI :: Platform -> BCInstr -> InspectAsm () #-}
{-# SPECIALISE assembleI :: Platform -> BCInstr -> RunAsm () #-}
assembleI :: forall m . MonadAssembler m
=> Platform
-> BCInstr
-> m ()
assembleI platform i = case i of
STKCHECK n -> emit_ bci_STKCHECK [Op n]
PUSH_L o1 -> emit_ bci_PUSH_L [wOp o1]
PUSH_LL o1 o2 -> emit_ bci_PUSH_LL [wOp o1, wOp o2]
PUSH_LLL o1 o2 o3 -> emit_ bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]
PUSH8 o1 -> emit_ bci_PUSH8 [bOp o1]
PUSH16 o1 -> emit_ bci_PUSH16 [bOp o1]
PUSH32 o1 -> emit_ bci_PUSH32 [bOp o1]
PUSH8_W o1 -> emit_ bci_PUSH8_W [bOp o1]
PUSH16_W o1 -> emit_ bci_PUSH16_W [bOp o1]
PUSH32_W o1 -> emit_ bci_PUSH32_W [bOp o1]
PUSH_G nm -> do p <- ptr (BCOPtrName nm)
emit_ bci_PUSH_G [Op p]
PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op)
emit_ bci_PUSH_G [Op p]
PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit_ bci_PUSH_G [Op p]
PUSH_ALTS proto pk
-> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit_ (push_alts pk) [Op p]
PUSH_ALTS_TUPLE proto call_info tuple_proto
-> do let ul_bco = assembleBCO platform proto
ul_tuple_bco = assembleBCO platform
tuple_proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
info <- word (fromIntegral $
mkNativeCallInfoSig platform call_info)
emit_ bci_PUSH_ALTS_T
[Op p, Op info, Op p_tup]
PUSH_PAD8 -> emit_ bci_PUSH_PAD8 []
PUSH_PAD16 -> emit_ bci_PUSH_PAD16 []
PUSH_PAD32 -> emit_ bci_PUSH_PAD32 []
PUSH_UBX8 lit -> do np <- literal lit
emit_ bci_PUSH_UBX8 [Op np]
PUSH_UBX16 lit -> do np <- literal lit
emit_ bci_PUSH_UBX16 [Op np]
PUSH_UBX32 lit -> do np <- literal lit
emit_ bci_PUSH_UBX32 [Op np]
PUSH_UBX lit nws -> do np <- literal lit
emit_ bci_PUSH_UBX [Op np, wOp nws]
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
PUSH_ADDR nm -> do np <- lit1 (BCONPtrAddr nm)
emit_ bci_PUSH_UBX [Op np, SmallOp 1]
PUSH_APPLY_N -> emit_ bci_PUSH_APPLY_N []
PUSH_APPLY_V -> emit_ bci_PUSH_APPLY_V []
PUSH_APPLY_F -> emit_ bci_PUSH_APPLY_F []
PUSH_APPLY_D -> emit_ bci_PUSH_APPLY_D []
PUSH_APPLY_L -> emit_ bci_PUSH_APPLY_L []
PUSH_APPLY_P -> emit_ bci_PUSH_APPLY_P []
PUSH_APPLY_PP -> emit_ bci_PUSH_APPLY_PP []
PUSH_APPLY_PPP -> emit_ bci_PUSH_APPLY_PPP []
PUSH_APPLY_PPPP -> emit_ bci_PUSH_APPLY_PPPP []
PUSH_APPLY_PPPPP -> emit_ bci_PUSH_APPLY_PPPPP []
PUSH_APPLY_PPPPPP -> emit_ bci_PUSH_APPLY_PPPPPP []
SLIDE n by -> emit_ bci_SLIDE [wOp n, wOp by]
ALLOC_AP n -> emit_ bci_ALLOC_AP [truncHalfWord platform n]
ALLOC_AP_NOUPD n -> emit_ bci_ALLOC_AP_NOUPD [truncHalfWord platform n]
ALLOC_PAP arity n -> emit_ bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]
MKAP off sz -> emit_ bci_MKAP [wOp off, truncHalfWord platform sz]
MKPAP off sz -> emit_ bci_MKPAP [wOp off, truncHalfWord platform sz]
UNPACK n -> emit_ bci_UNPACK [wOp n]
PACK dcon sz -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon))
emit_ bci_PACK [Op itbl_no, wOp sz]
LABEL lbl -> label lbl
TESTLT_I i l -> do np <- int i
emit_ bci_TESTLT_I [Op np, LabelOp l]
TESTEQ_I i l -> do np <- int i
emit_ bci_TESTEQ_I [Op np, LabelOp l]
TESTLT_W w l -> do np <- word w
emit_ bci_TESTLT_W [Op np, LabelOp l]
TESTEQ_W w l -> do np <- word w
emit_ bci_TESTEQ_W [Op np, LabelOp l]
TESTLT_I64 i l -> do np <- word64 (fromIntegral i)
emit_ bci_TESTLT_I64 [Op np, LabelOp l]
TESTEQ_I64 i l -> do np <- word64 (fromIntegral i)
emit_ bci_TESTEQ_I64 [Op np, LabelOp l]
TESTLT_I32 i l -> do np <- word (fromIntegral i)
emit_ bci_TESTLT_I32 [Op np, LabelOp l]
TESTEQ_I32 i l -> do np <- word (fromIntegral i)
emit_ bci_TESTEQ_I32 [Op np, LabelOp l]
TESTLT_I16 i l -> do np <- word (fromIntegral i)
emit_ bci_TESTLT_I16 [Op np, LabelOp l]
TESTEQ_I16 i l -> do np <- word (fromIntegral i)
emit_ bci_TESTEQ_I16 [Op np, LabelOp l]
TESTLT_I8 i l -> do np <- word (fromIntegral i)
emit_ bci_TESTLT_I8 [Op np, LabelOp l]
TESTEQ_I8 i l -> do np <- word (fromIntegral i)
emit_ bci_TESTEQ_I8 [Op np, LabelOp l]
TESTLT_W64 w l -> do np <- word64 w
emit_ bci_TESTLT_W64 [Op np, LabelOp l]
TESTEQ_W64 w l -> do np <- word64 w
emit_ bci_TESTEQ_W64 [Op np, LabelOp l]
TESTLT_W32 w l -> do np <- word (fromIntegral w)
emit_ bci_TESTLT_W32 [Op np, LabelOp l]
TESTEQ_W32 w l -> do np <- word (fromIntegral w)
emit_ bci_TESTEQ_W32 [Op np, LabelOp l]
TESTLT_W16 w l -> do np <- word (fromIntegral w)
emit_ bci_TESTLT_W16 [Op np, LabelOp l]
TESTEQ_W16 w l -> do np <- word (fromIntegral w)
emit_ bci_TESTEQ_W16 [Op np, LabelOp l]
TESTLT_W8 w l -> do np <- word (fromIntegral w)
emit_ bci_TESTLT_W8 [Op np, LabelOp l]
TESTEQ_W8 w l -> do np <- word (fromIntegral w)
emit_ bci_TESTEQ_W8 [Op np, LabelOp l]
TESTLT_F f l -> do np <- float f
emit_ bci_TESTLT_F [Op np, LabelOp l]
TESTEQ_F f l -> do np <- float f
emit_ bci_TESTEQ_F [Op np, LabelOp l]
TESTLT_D d l -> do np <- double d
emit_ bci_TESTLT_D [Op np, LabelOp l]
TESTEQ_D d l -> do np <- double d
emit_ bci_TESTEQ_D [Op np, LabelOp l]
TESTLT_P i l -> emit_ bci_TESTLT_P [SmallOp i, LabelOp l]
TESTEQ_P i l -> emit_ bci_TESTEQ_P [SmallOp i, LabelOp l]
CASEFAIL -> emit_ bci_CASEFAIL []
SWIZZLE stkoff n -> emit_ bci_SWIZZLE [wOp stkoff, IOp n]
JMP l -> emit_ bci_JMP [LabelOp l]
ENTER -> emit_ bci_ENTER []
RETURN rep -> emit_ (return_non_tuple rep) []
RETURN_TUPLE -> emit_ bci_RETURN_T []
CCALL off ffi i -> do np <- lit1 $ BCONPtrFFIInfo ffi
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
OP_ADD w -> case w of
W64 -> emit_ bci_OP_ADD_64 []
W32 -> emit_ bci_OP_ADD_32 []
W16 -> emit_ bci_OP_ADD_16 []
W8 -> emit_ bci_OP_ADD_08 []
_ -> unsupported_width
OP_SUB w -> case w of
W64 -> emit_ bci_OP_SUB_64 []
W32 -> emit_ bci_OP_SUB_32 []
W16 -> emit_ bci_OP_SUB_16 []
W8 -> emit_ bci_OP_SUB_08 []
_ -> unsupported_width
OP_AND w -> case w of
W64 -> emit_ bci_OP_AND_64 []
W32 -> emit_ bci_OP_AND_32 []
W16 -> emit_ bci_OP_AND_16 []
W8 -> emit_ bci_OP_AND_08 []
_ -> unsupported_width
OP_XOR w -> case w of
W64 -> emit_ bci_OP_XOR_64 []
W32 -> emit_ bci_OP_XOR_32 []
W16 -> emit_ bci_OP_XOR_16 []
W8 -> emit_ bci_OP_XOR_08 []
_ -> unsupported_width
OP_OR w -> case w of
W64 -> emit_ bci_OP_OR_64 []
W32 -> emit_ bci_OP_OR_32 []
W16 -> emit_ bci_OP_OR_16 []
W8 -> emit_ bci_OP_OR_08 []
_ -> unsupported_width
OP_NOT w -> case w of
W64 -> emit_ bci_OP_NOT_64 []
W32 -> emit_ bci_OP_NOT_32 []
W16 -> emit_ bci_OP_NOT_16 []
W8 -> emit_ bci_OP_NOT_08 []
_ -> unsupported_width
OP_NEG w -> case w of
W64 -> emit_ bci_OP_NEG_64 []
W32 -> emit_ bci_OP_NEG_32 []
W16 -> emit_ bci_OP_NEG_16 []
W8 -> emit_ bci_OP_NEG_08 []
_ -> unsupported_width
OP_MUL w -> case w of
W64 -> emit_ bci_OP_MUL_64 []
W32 -> emit_ bci_OP_MUL_32 []
W16 -> emit_ bci_OP_MUL_16 []
W8 -> emit_ bci_OP_MUL_08 []
_ -> unsupported_width
OP_SHL w -> case w of
W64 -> emit_ bci_OP_SHL_64 []
W32 -> emit_ bci_OP_SHL_32 []
W16 -> emit_ bci_OP_SHL_16 []
W8 -> emit_ bci_OP_SHL_08 []
_ -> unsupported_width
OP_ASR w -> case w of
W64 -> emit_ bci_OP_ASR_64 []
W32 -> emit_ bci_OP_ASR_32 []
W16 -> emit_ bci_OP_ASR_16 []
W8 -> emit_ bci_OP_ASR_08 []
_ -> unsupported_width
OP_LSR w -> case w of
W64 -> emit_ bci_OP_LSR_64 []
W32 -> emit_ bci_OP_LSR_32 []
W16 -> emit_ bci_OP_LSR_16 []
W8 -> emit_ bci_OP_LSR_08 []
_ -> unsupported_width
OP_NEQ w -> case w of
W64 -> emit_ bci_OP_NEQ_64 []
W32 -> emit_ bci_OP_NEQ_32 []
W16 -> emit_ bci_OP_NEQ_16 []
W8 -> emit_ bci_OP_NEQ_08 []
_ -> unsupported_width
OP_EQ w -> case w of
W64 -> emit_ bci_OP_EQ_64 []
W32 -> emit_ bci_OP_EQ_32 []
W16 -> emit_ bci_OP_EQ_16 []
W8 -> emit_ bci_OP_EQ_08 []
_ -> unsupported_width
OP_U_LT w -> case w of
W64 -> emit_ bci_OP_U_LT_64 []
W32 -> emit_ bci_OP_U_LT_32 []
W16 -> emit_ bci_OP_U_LT_16 []
W8 -> emit_ bci_OP_U_LT_08 []
_ -> unsupported_width
OP_S_LT w -> case w of
W64 -> emit_ bci_OP_S_LT_64 []
W32 -> emit_ bci_OP_S_LT_32 []
W16 -> emit_ bci_OP_S_LT_16 []
W8 -> emit_ bci_OP_S_LT_08 []
_ -> unsupported_width
OP_U_GE w -> case w of
W64 -> emit_ bci_OP_U_GE_64 []
W32 -> emit_ bci_OP_U_GE_32 []
W16 -> emit_ bci_OP_U_GE_16 []
W8 -> emit_ bci_OP_U_GE_08 []
_ -> unsupported_width
OP_S_GE w -> case w of
W64 -> emit_ bci_OP_S_GE_64 []
W32 -> emit_ bci_OP_S_GE_32 []
W16 -> emit_ bci_OP_S_GE_16 []
W8 -> emit_ bci_OP_S_GE_08 []
_ -> unsupported_width
OP_U_GT w -> case w of
W64 -> emit_ bci_OP_U_GT_64 []
W32 -> emit_ bci_OP_U_GT_32 []
W16 -> emit_ bci_OP_U_GT_16 []
W8 -> emit_ bci_OP_U_GT_08 []
_ -> unsupported_width
OP_S_GT w -> case w of
W64 -> emit_ bci_OP_S_GT_64 []
W32 -> emit_ bci_OP_S_GT_32 []
W16 -> emit_ bci_OP_S_GT_16 []
W8 -> emit_ bci_OP_S_GT_08 []
_ -> unsupported_width
OP_U_LE w -> case w of
W64 -> emit_ bci_OP_U_LE_64 []
W32 -> emit_ bci_OP_U_LE_32 []
W16 -> emit_ bci_OP_U_LE_16 []
W8 -> emit_ bci_OP_U_LE_08 []
_ -> unsupported_width
OP_S_LE w -> case w of
W64 -> emit_ bci_OP_S_LE_64 []
W32 -> emit_ bci_OP_S_LE_32 []
W16 -> emit_ bci_OP_S_LE_16 []
W8 -> emit_ bci_OP_S_LE_08 []
_ -> unsupported_width
OP_INDEX_ADDR w -> case w of
W64 -> emit_ bci_OP_INDEX_ADDR_64 []
W32 -> emit_ bci_OP_INDEX_ADDR_32 []
W16 -> emit_ bci_OP_INDEX_ADDR_16 []
W8 -> emit_ bci_OP_INDEX_ADDR_08 []
_ -> unsupported_width
BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do
p1 <- ptr $ BCOPtrBreakArray info_mod
let -- cast that checks that round-tripping through Word32 doesn't change the value
infoW32 = let r = fromIntegral infox :: Word32
in if fromIntegral r == infox
then r
else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr infox)
ix_hi = fromIntegral (infoW32 `shiftR` 16)
ix_lo = fromIntegral (infoW32 .&. 0xffff)
info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod
info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId info_mod
np <- lit1 $ BCONPtrCostCentre ibi
emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr
, SmallOp ix_hi, SmallOp ix_lo, Op np ]
#if MIN_VERSION_rts(1,0,3)
BCO_NAME name -> do np <- lit1 (BCONPtrStr name)
emit_ bci_BCO_NAME [Op np]
#endif
where
unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width"
emit_ = emit word_size
literal :: Literal -> m Word
literal (LitLabel fs _) = litlabel fs
literal LitNullAddr = word 0
literal (LitFloat r) = float (fromRational r)
literal (LitDouble r) = double (fromRational r)
literal (LitChar c) = int (ord c)
literal (LitString bs) = lit1 (BCONPtrStr bs)
-- LitString requires a zero-terminator when emitted
literal (LitNumber nt i) = case nt of
LitNumInt -> word (fromIntegral i)
LitNumWord -> word (fromIntegral i)
LitNumInt8 -> word8 (fromIntegral i)
LitNumWord8 -> word8 (fromIntegral i)
LitNumInt16 -> word16 (fromIntegral i)
LitNumWord16 -> word16 (fromIntegral i)
LitNumInt32 -> word32 (fromIntegral i)
LitNumWord32 -> word32 (fromIntegral i)
LitNumInt64 -> word64 (fromIntegral i)
LitNumWord64 -> word64 (fromIntegral i)
LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"
-- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
-- likely to elicit a crash (rather than corrupt memory) in case absence
-- analysis messed up.
literal (LitRubbish {}) = word 0
litlabel fs = lit1 (BCONPtrLbl fs)
words ws = lit (fmap BCONPtrWord ws)
word w = words (OnlyOne w)
word2 w1 w2 = words (OnlyTwo w1 w2)
word_size = platformWordSize platform
word_size_bits = platformWordSizeInBits platform
-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
-- bit pattern is correct for the host's word size and endianness.
--
-- Note that we only support host endianness == target endianness for now,
-- even with the external interpreter. This would need to be fixed to
-- support host endianness /= target endianness
int :: Int -> m Word
int i = word (fromIntegral i)
float :: Float -> m Word
float f = word32 (castFloatToWord32 f)
double :: Double -> m Word
double d = word64 (castDoubleToWord64 d)
word64 :: Word64 -> m Word
word64 ww = case word_size of
PW4 ->
let !wl = fromIntegral ww
!wh = fromIntegral (ww `unsafeShiftR` 32)
in case platformByteOrder platform of
LittleEndian -> word2 wl wh
BigEndian -> word2 wh wl
PW8 -> word (fromIntegral ww)
word8 :: Word8 -> m Word
word8 x = case platformByteOrder platform of
LittleEndian -> word (fromIntegral x)
BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8))
word16 :: Word16 -> m Word
word16 x = case platformByteOrder platform of
LittleEndian -> word (fromIntegral x)
BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16))
word32 :: Word32 -> m Word
word32 x = case platformByteOrder platform of
LittleEndian -> word (fromIntegral x)
BigEndian -> case word_size of
PW4 -> word (fromIntegral x)
PW8 -> word (fromIntegral x `unsafeShiftL` 32)
isLargeW :: Word -> Bool
isLargeW n = n > 65535
isLargeI :: Int -> Bool
isLargeI n = n > 32767 || n < -32768
push_alts :: ArgRep -> Word16
push_alts V = bci_PUSH_ALTS_V
push_alts P = bci_PUSH_ALTS_P
push_alts N = bci_PUSH_ALTS_N
push_alts L = bci_PUSH_ALTS_L
push_alts F = bci_PUSH_ALTS_F
push_alts D = bci_PUSH_ALTS_D
push_alts V16 = error "push_alts: vector"
push_alts V32 = error "push_alts: vector"
push_alts V64 = error "push_alts: vector"
return_non_tuple :: ArgRep -> Word16
return_non_tuple V = bci_RETURN_V
return_non_tuple P = bci_RETURN_P
return_non_tuple N = bci_RETURN_N
return_non_tuple L = bci_RETURN_L
return_non_tuple F = bci_RETURN_F
return_non_tuple D = bci_RETURN_D
return_non_tuple V16 = error "return_non_tuple: vector"
return_non_tuple V32 = error "return_non_tuple: vector"
return_non_tuple V64 = error "return_non_tuple: vector"
{-
we can only handle up to a fixed number of words on the stack,
because we need a stg_ctoi_tN stack frame for each size N. See
Note [unboxed tuple bytecodes and tuple_BCO].
If needed, you can support larger tuples by adding more in
Jumps.cmm, StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and
raising this limit.
Note that the limit is the number of words passed on the stack.
If the calling convention passes part of the tuple in registers, the
maximum number of tuple elements may be larger. Elements can also
take multiple words on the stack (for example Double# on a 32 bit
platform).
-}
maxTupleReturnNativeStackSize :: WordOff
maxTupleReturnNativeStackSize = 62
{-
Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall
use to convert arguments between the native calling convention and the
interpreter.
See Note [GHCi and native call registers] for more information.
-}
mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32
mkNativeCallInfoSig platform NativeCallInfo{..}
| nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize
= pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler"
(ppr nativeCallStackSpillSize <+> text "stack words." <+>
text "Use -fobject-code to get around this limit"
)
| otherwise
= -- 24 bits for register bitmap
assertPpr (length argRegs <= 24) (text "too many registers for bitmap:" <+> ppr (length argRegs))
-- 8 bits for continuation offset (only for NativeTupleReturn)
assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset)
-- all regs accounted for
assertPpr (all (`elem` (map fst argRegs)) (regSetToList nativeCallRegs))
( vcat
[ text "not all registers accounted for"
, text "argRegs:" <+> ppr argRegs
, text "nativeCallRegs:" <+> ppr nativeCallRegs
] ) $
-- SIMD GHCi TODO: the above assertion doesn't account for register overlap;
-- it will need to be adjusted for SIMD vector support in the bytecode interpreter.
foldl' reg_bit 0 argRegs .|. (cont_offset `shiftL` 24)
where
cont_offset :: Word32
cont_offset
| nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize
| otherwise = 0 -- there is no continuation for primcalls
reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
reg_bit x (r, n)
| r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n
| otherwise = x
argRegs = zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..]
-- The bytecode interpreter does not (currently) handle vector registers,
-- so we only use the scalar argument-passing registers here.
mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal
mkNativeCallInfoLit platform call_info =
mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH