{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
module GHC.ByteCode.Asm (
assembleBCOs, assembleOneBCO,
bcoFreeNames,
SizedSeq, sizeSS, ssElts,
iNTERP_STACK_CHECK_THRESH,
mkNativeCallInfoLit
) where
import GHC.Prelude
import GHC.ByteCode.Instr
import GHC.ByteCode.InfoTable
import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHC.Runtime.Interpreter
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.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.TyCon
import GHC.Data.FlatBag
import GHC.Data.SizedSeq
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 Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import qualified Data.Array.Unboxed as Array
import Data.Array.Base ( UArray(..) )
import Foreign hiding (shiftL, shiftR)
import Data.Char ( ord )
import Data.List ( genericLength )
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as Map
import GHC.Float (castFloatToWord32, castDoubleToWord64)
bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
bcoFreeNames UnlinkedBCO
bco
= UnlinkedBCO -> UniqDSet Name
bco_refs UnlinkedBCO
bco UniqDSet Name -> UniqSet Name -> UniqDSet Name
forall a. UniqDSet a -> UniqSet a -> UniqDSet a
`uniqDSetMinusUniqSet` [Name] -> UniqSet Name
mkNameSet [UnlinkedBCO -> Name
unlinkedBCOName UnlinkedBCO
bco]
where
bco_refs :: UnlinkedBCO -> UniqDSet Name
bco_refs (UnlinkedBCO Name
_ Int
_ BCOByteArray Word16
_ BCOByteArray Word
_ FlatBag BCONPtr
nonptrs FlatBag BCOPtr
ptrs)
= [UniqDSet Name] -> UniqDSet Name
forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets (
[Name] -> UniqDSet Name
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet [ Name
n | BCOPtrName Name
n <- FlatBag BCOPtr -> [BCOPtr]
forall a. FlatBag a -> [a]
elemsFlatBag FlatBag BCOPtr
ptrs ] UniqDSet Name -> [UniqDSet Name] -> [UniqDSet Name]
forall a. a -> [a] -> [a]
:
[Name] -> UniqDSet Name
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet [ Name
n | BCONPtrItbl Name
n <- FlatBag BCONPtr -> [BCONPtr]
forall a. FlatBag a -> [a]
elemsFlatBag FlatBag BCONPtr
nonptrs ] UniqDSet Name -> [UniqDSet Name] -> [UniqDSet Name]
forall a. a -> [a] -> [a]
:
(UnlinkedBCO -> UniqDSet Name) -> [UnlinkedBCO] -> [UniqDSet Name]
forall a b. (a -> b) -> [a] -> [b]
map UnlinkedBCO -> UniqDSet Name
bco_refs [ UnlinkedBCO
bco | BCOPtrBCO UnlinkedBCO
bco <- FlatBag BCOPtr -> [BCOPtr]
forall a. FlatBag a -> [a]
elemsFlatBag FlatBag BCOPtr
ptrs ]
)
assembleBCOs
:: Interp
-> Profile
-> FlatBag (ProtoBCO Name)
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
-> [SptEntry]
-> IO CompiledByteCode
assembleBCOs :: Interp
-> Profile
-> FlatBag (ProtoBCO Name)
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
-> [SptEntry]
-> IO CompiledByteCode
assembleBCOs Interp
interp Profile
profile FlatBag (ProtoBCO Name)
proto_bcos [TyCon]
tycons AddrEnv
top_strs Maybe ModBreaks
modbreaks [SptEntry]
spt_entries = do
itblenv <- Interp -> Profile -> [TyCon] -> IO ItblEnv
mkITbls Interp
interp Profile
profile [TyCon]
tycons
bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos
bcos' <- mallocStrings interp bcos
return CompiledByteCode
{ bc_bcos = bcos'
, bc_itbls = itblenv
, bc_ffis = concatMap protoBCOFFIs proto_bcos
, bc_strs = top_strs
, bc_breaks = modbreaks
, bc_spt_entries = spt_entries
}
mallocStrings :: Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)
mallocStrings :: Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)
mallocStrings Interp
interp FlatBag UnlinkedBCO
ulbcos = do
let bytestrings :: [ByteString]
bytestrings = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (State [ByteString] () -> [ByteString] -> [ByteString]
forall s a. State s a -> s -> s
execState ((UnlinkedBCO -> State [ByteString] ())
-> FlatBag UnlinkedBCO -> State [ByteString] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ UnlinkedBCO -> State [ByteString] ()
forall {m :: * -> *}.
Monad m =>
UnlinkedBCO -> StateT [ByteString] m ()
collect FlatBag UnlinkedBCO
ulbcos) [])
ptrs <- Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp ([ByteString] -> Message [RemotePtr ()]
MallocStrings [ByteString]
bytestrings)
return (evalState (mapM splice ulbcos) ptrs)
where
splice :: UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
splice bco :: UnlinkedBCO
bco@UnlinkedBCO{Int
BCOByteArray Word
BCOByteArray Word16
Name
FlatBag BCONPtr
FlatBag BCOPtr
unlinkedBCOName :: UnlinkedBCO -> Name
unlinkedBCOName :: Name
unlinkedBCOArity :: Int
unlinkedBCOInstrs :: BCOByteArray Word16
unlinkedBCOBitmap :: BCOByteArray Word
unlinkedBCOLits :: FlatBag BCONPtr
unlinkedBCOPtrs :: FlatBag BCOPtr
unlinkedBCOPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedBCOLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedBCOBitmap :: UnlinkedBCO -> BCOByteArray Word
unlinkedBCOInstrs :: UnlinkedBCO -> BCOByteArray Word16
unlinkedBCOArity :: UnlinkedBCO -> Int
..} = do
lits <- (BCONPtr -> StateT [RemotePtr a] m BCONPtr)
-> FlatBag BCONPtr -> StateT [RemotePtr a] m (FlatBag BCONPtr)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FlatBag a -> m (FlatBag b)
mapM BCONPtr -> StateT [RemotePtr a] m BCONPtr
forall {m :: * -> *} {a}.
Monad m =>
BCONPtr -> StateT [RemotePtr a] m BCONPtr
spliceLit FlatBag BCONPtr
unlinkedBCOLits
ptrs <- mapM splicePtr unlinkedBCOPtrs
return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
spliceLit :: BCONPtr -> StateT [RemotePtr a] m BCONPtr
spliceLit (BCONPtrStr ByteString
_) = do
rptrs <- StateT [RemotePtr a] m [RemotePtr a]
forall (m :: * -> *) s. Monad m => StateT s m s
get
case rptrs of
(RemotePtr Word64
p : [RemotePtr a]
rest) -> do
[RemotePtr a] -> StateT [RemotePtr a] m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [RemotePtr a]
rest
BCONPtr -> StateT [RemotePtr a] m BCONPtr
forall a. a -> StateT [RemotePtr a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word -> BCONPtr
BCONPtrWord (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p))
[RemotePtr a]
_ -> String -> StateT [RemotePtr a] m BCONPtr
forall a. HasCallStack => String -> a
panic String
"mallocStrings:spliceLit"
spliceLit BCONPtr
other = BCONPtr -> StateT [RemotePtr a] m BCONPtr
forall a. a -> StateT [RemotePtr a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return BCONPtr
other
splicePtr :: BCOPtr -> StateT [RemotePtr a] m BCOPtr
splicePtr (BCOPtrBCO UnlinkedBCO
bco) = UnlinkedBCO -> BCOPtr
BCOPtrBCO (UnlinkedBCO -> BCOPtr)
-> StateT [RemotePtr a] m UnlinkedBCO
-> StateT [RemotePtr a] m BCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
splice UnlinkedBCO
bco
splicePtr BCOPtr
other = BCOPtr -> StateT [RemotePtr a] m BCOPtr
forall a. a -> StateT [RemotePtr a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return BCOPtr
other
collect :: UnlinkedBCO -> StateT [ByteString] m ()
collect UnlinkedBCO{Int
BCOByteArray Word
BCOByteArray Word16
Name
FlatBag BCONPtr
FlatBag BCOPtr
unlinkedBCOName :: UnlinkedBCO -> Name
unlinkedBCOPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedBCOLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedBCOBitmap :: UnlinkedBCO -> BCOByteArray Word
unlinkedBCOInstrs :: UnlinkedBCO -> BCOByteArray Word16
unlinkedBCOArity :: UnlinkedBCO -> Int
unlinkedBCOName :: Name
unlinkedBCOArity :: Int
unlinkedBCOInstrs :: BCOByteArray Word16
unlinkedBCOBitmap :: BCOByteArray Word
unlinkedBCOLits :: FlatBag BCONPtr
unlinkedBCOPtrs :: FlatBag BCOPtr
..} = do
(BCONPtr -> StateT [ByteString] m ())
-> FlatBag BCONPtr -> StateT [ByteString] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BCONPtr -> StateT [ByteString] m ()
forall {m :: * -> *}.
Monad m =>
BCONPtr -> StateT [ByteString] m ()
collectLit FlatBag BCONPtr
unlinkedBCOLits
(BCOPtr -> StateT [ByteString] m ())
-> FlatBag BCOPtr -> StateT [ByteString] m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BCOPtr -> StateT [ByteString] m ()
collectPtr FlatBag BCOPtr
unlinkedBCOPtrs
collectLit :: BCONPtr -> StateT [ByteString] m ()
collectLit (BCONPtrStr ByteString
bs) = do
strs <- StateT [ByteString] m [ByteString]
forall (m :: * -> *) s. Monad m => StateT s m s
get
put (bs:strs)
collectLit BCONPtr
_ = () -> StateT [ByteString] m ()
forall a. a -> StateT [ByteString] m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
collectPtr :: BCOPtr -> StateT [ByteString] m ()
collectPtr (BCOPtrBCO UnlinkedBCO
bco) = UnlinkedBCO -> StateT [ByteString] m ()
collect UnlinkedBCO
bco
collectPtr BCOPtr
_ = () -> StateT [ByteString] m ()
forall a. a -> StateT [ByteString] m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO Interp
interp Profile
profile ProtoBCO Name
pbco = do
ubco <- Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (Profile -> Platform
profilePlatform Profile
profile) ProtoBCO Name
pbco
UnitFlatBag ubco' <- mallocStrings interp (UnitFlatBag ubco)
return ubco'
assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO Platform
platform (ProtoBCO { protoBCOName :: forall a. ProtoBCO a -> a
protoBCOName = Name
nm
, protoBCOInstrs :: forall a. ProtoBCO a -> [BCInstr]
protoBCOInstrs = [BCInstr]
instrs
, protoBCOBitmap :: forall a. ProtoBCO a -> [StgWord]
protoBCOBitmap = [StgWord]
bitmap
, protoBCOBitmapSize :: forall a. ProtoBCO a -> Word
protoBCOBitmapSize = Word
bsize
, protoBCOArity :: forall a. ProtoBCO a -> Int
protoBCOArity = Int
arity }) = do
let asm :: Assembler ()
asm = (BCInstr -> Assembler ()) -> [BCInstr] -> Assembler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Platform -> BCInstr -> Assembler ()
assembleI Platform
platform) [BCInstr]
instrs
initial_offset :: Word
initial_offset = Word
0
(Word
n_insns0, LabelEnvMap
lbl_map0) = Platform -> Bool -> Word -> Assembler () -> (Word, LabelEnvMap)
forall a.
Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm Platform
platform Bool
False Word
initial_offset Assembler ()
asm
((Word
n_insns, LabelEnvMap
lbl_map), Bool
long_jumps)
| Word -> Bool
isLargeW (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ LabelEnvMap -> Int
forall k a. Map k a -> Int
Map.size LabelEnvMap
lbl_map0)
Bool -> Bool -> Bool
|| Word -> Bool
isLargeW Word
n_insns0
= (Platform -> Bool -> Word -> Assembler () -> (Word, LabelEnvMap)
forall a.
Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm Platform
platform Bool
True Word
initial_offset Assembler ()
asm, Bool
True)
| Bool
otherwise = ((Word
n_insns0, LabelEnvMap
lbl_map0), Bool
False)
env :: LocalLabel -> Word
env :: LocalLabel -> Word
env LocalLabel
lbl = Word -> Maybe Word -> Word
forall a. a -> Maybe a -> a
fromMaybe
(String -> SDoc -> Word
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"assembleBCO.findLabel" (LocalLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocalLabel
lbl))
(LocalLabel -> LabelEnvMap -> Maybe Word
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup LocalLabel
lbl LabelEnvMap
lbl_map)
let initial_state :: (SizedSeq a, SizedSeq a, SizedSeq a)
initial_state = (SizedSeq a
forall a. SizedSeq a
emptySS, SizedSeq a
forall a. SizedSeq a
emptySS, SizedSeq a
forall a. SizedSeq a
emptySS)
(final_insns, final_lits, final_ptrs) <- (StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
-> (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr))
-> (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
-> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
-> (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
forall {a} {a} {a}. (SizedSeq a, SizedSeq a, SizedSeq a)
initial_state (StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
-> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr))
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
-> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
forall a b. (a -> b) -> a -> b
$ Platform
-> Bool
-> (LocalLabel -> Word)
-> Assembler ()
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
forall a.
Platform
-> Bool
-> (LocalLabel -> Word)
-> Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
runAsm Platform
platform Bool
long_jumps LocalLabel -> Word
env Assembler ()
asm
massertPpr (n_insns == sizeSS final_insns)
(text "bytecode instruction count mismatch")
let asm_insns = SizedSeq Word16 -> [Word16]
forall a. SizedSeq a -> [a]
ssElts SizedSeq Word16
final_insns
!insns_arr = UArray Int Word16 -> BCOByteArray Word16
forall a. UArray Int a -> BCOByteArray a
mkBCOByteArray (UArray Int Word16 -> BCOByteArray Word16)
-> UArray Int Word16 -> BCOByteArray Word16
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Word16] -> UArray Int Word16
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
Array.listArray (Int
0 :: Int, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n_insns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Word16]
asm_insns
!bitmap_arr = UArray Int Word -> BCOByteArray Word
forall a. UArray Int a -> BCOByteArray a
mkBCOByteArray (UArray Int Word -> BCOByteArray Word)
-> UArray Int Word -> BCOByteArray Word
forall a b. (a -> b) -> a -> b
$ Word -> [StgWord] -> UArray Int Word
mkBitmapArray Word
bsize [StgWord]
bitmap
ul_bco = Name
-> Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> FlatBag BCONPtr
-> FlatBag BCOPtr
-> UnlinkedBCO
UnlinkedBCO Name
nm Int
arity BCOByteArray Word16
insns_arr BCOByteArray Word
bitmap_arr (SizedSeq BCONPtr -> FlatBag BCONPtr
forall a. SizedSeq a -> FlatBag a
fromSizedSeq SizedSeq BCONPtr
final_lits) (SizedSeq BCOPtr -> FlatBag BCOPtr
forall a. SizedSeq a -> FlatBag a
fromSizedSeq SizedSeq BCOPtr
final_ptrs)
return ul_bco
mkBitmapArray :: Word -> [StgWord] -> UArray Int Word
mkBitmapArray :: Word -> [StgWord] -> UArray Int Word
mkBitmapArray Word
bsize [StgWord]
bitmap
= (Int, Int) -> [Word] -> UArray Int Word
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
Array.listArray (Int
0, [StgWord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgWord]
bitmap) ([Word] -> UArray Int Word) -> [Word] -> UArray Int Word
forall a b. (a -> b) -> a -> b
$
Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
bsize Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
: (StgWord -> Word) -> [StgWord] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Word
forall a. Num a => Integer -> a
fromInteger (Integer -> Word) -> (StgWord -> Integer) -> StgWord -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgWord -> Integer
fromStgWord) [StgWord]
bitmap
type AsmState = (SizedSeq Word16,
SizedSeq BCONPtr,
SizedSeq BCOPtr)
data Operand
= Op Word
| IOp Int
| SmallOp Word16
| LabelOp LocalLabel
wOp :: WordOff -> Operand
wOp :: WordOff -> Operand
wOp = Word -> Operand
Op (Word -> Operand) -> (WordOff -> Word) -> WordOff -> Operand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordOff -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral
bOp :: ByteOff -> Operand
bOp :: ByteOff -> Operand
bOp = Word -> Operand
Op (Word -> Operand) -> (ByteOff -> Word) -> ByteOff -> Operand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteOff -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral
truncHalfWord :: Platform -> HalfWord -> Operand
truncHalfWord :: Platform -> HalfWord -> Operand
truncHalfWord Platform
platform HalfWord
w = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 | HalfWord
w HalfWord -> HalfWord -> Bool
forall a. Ord a => a -> a -> Bool
<= HalfWord
65535 -> Word -> Operand
Op (HalfWord -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral HalfWord
w)
PlatformWordSize
PW8 | HalfWord
w HalfWord -> HalfWord -> Bool
forall a. Ord a => a -> a -> Bool
<= HalfWord
4294967295 -> Word -> Operand
Op (HalfWord -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral HalfWord
w)
PlatformWordSize
_ -> String -> SDoc -> Operand
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.ByteCode.Asm.truncHalfWord" (HalfWord -> SDoc
forall a. Outputable a => a -> SDoc
ppr HalfWord
w)
data Assembler a
= AllocPtr (IO BCOPtr) (Word -> Assembler a)
| AllocLit [BCONPtr] (Word -> Assembler a)
| AllocLabel LocalLabel (Assembler a)
| Emit Word16 [Operand] (Assembler a)
| NullAsm a
deriving ((forall a b. (a -> b) -> Assembler a -> Assembler b)
-> (forall a b. a -> Assembler b -> Assembler a)
-> Functor Assembler
forall a b. a -> Assembler b -> Assembler a
forall a b. (a -> b) -> Assembler a -> Assembler b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Assembler a -> Assembler b
fmap :: forall a b. (a -> b) -> Assembler a -> Assembler b
$c<$ :: forall a b. a -> Assembler b -> Assembler a
<$ :: forall a b. a -> Assembler b -> Assembler a
Functor)
instance Applicative Assembler where
pure :: forall a. a -> Assembler a
pure = a -> Assembler a
forall a. a -> Assembler a
NullAsm
<*> :: forall a b. Assembler (a -> b) -> Assembler a -> Assembler b
(<*>) = Assembler (a -> b) -> Assembler a -> Assembler b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Assembler where
NullAsm a
x >>= :: forall a b. Assembler a -> (a -> Assembler b) -> Assembler b
>>= a -> Assembler b
f = a -> Assembler b
f a
x
AllocPtr IO BCOPtr
p Word -> Assembler a
k >>= a -> Assembler b
f = IO BCOPtr -> (Word -> Assembler b) -> Assembler b
forall a. IO BCOPtr -> (Word -> Assembler a) -> Assembler a
AllocPtr IO BCOPtr
p (Word -> Assembler a
k (Word -> Assembler a) -> (a -> Assembler b) -> Word -> Assembler b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> Assembler b
f)
AllocLit [BCONPtr]
l Word -> Assembler a
k >>= a -> Assembler b
f = [BCONPtr] -> (Word -> Assembler b) -> Assembler b
forall a. [BCONPtr] -> (Word -> Assembler a) -> Assembler a
AllocLit [BCONPtr]
l (Word -> Assembler a
k (Word -> Assembler a) -> (a -> Assembler b) -> Word -> Assembler b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> Assembler b
f)
AllocLabel LocalLabel
lbl Assembler a
k >>= a -> Assembler b
f = LocalLabel -> Assembler b -> Assembler b
forall a. LocalLabel -> Assembler a -> Assembler a
AllocLabel LocalLabel
lbl (Assembler a
k Assembler a -> (a -> Assembler b) -> Assembler b
forall a b. Assembler a -> (a -> Assembler b) -> Assembler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Assembler b
f)
Emit Word16
w [Operand]
ops Assembler a
k >>= a -> Assembler b
f = Word16 -> [Operand] -> Assembler b -> Assembler b
forall a. Word16 -> [Operand] -> Assembler a -> Assembler a
Emit Word16
w [Operand]
ops (Assembler a
k Assembler a -> (a -> Assembler b) -> Assembler b
forall a b. Assembler a -> (a -> Assembler b) -> Assembler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Assembler b
f)
ioptr :: IO BCOPtr -> Assembler Word
ioptr :: IO BCOPtr -> Assembler Word
ioptr IO BCOPtr
p = IO BCOPtr -> (Word -> Assembler Word) -> Assembler Word
forall a. IO BCOPtr -> (Word -> Assembler a) -> Assembler a
AllocPtr IO BCOPtr
p Word -> Assembler Word
forall a. a -> Assembler a
forall (m :: * -> *) a. Monad m => a -> m a
return
ptr :: BCOPtr -> Assembler Word
ptr :: BCOPtr -> Assembler Word
ptr = IO BCOPtr -> Assembler Word
ioptr (IO BCOPtr -> Assembler Word)
-> (BCOPtr -> IO BCOPtr) -> BCOPtr -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BCOPtr -> IO BCOPtr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
lit :: [BCONPtr] -> Assembler Word
lit :: [BCONPtr] -> Assembler Word
lit [BCONPtr]
l = [BCONPtr] -> (Word -> Assembler Word) -> Assembler Word
forall a. [BCONPtr] -> (Word -> Assembler a) -> Assembler a
AllocLit [BCONPtr]
l Word -> Assembler Word
forall a. a -> Assembler a
forall (m :: * -> *) a. Monad m => a -> m a
return
label :: LocalLabel -> Assembler ()
label :: LocalLabel -> Assembler ()
label LocalLabel
w = LocalLabel -> Assembler () -> Assembler ()
forall a. LocalLabel -> Assembler a -> Assembler a
AllocLabel LocalLabel
w (() -> Assembler ()
forall a. a -> Assembler a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
emit :: Word16 -> [Operand] -> Assembler ()
emit :: Word16 -> [Operand] -> Assembler ()
emit Word16
w [Operand]
ops = Word16 -> [Operand] -> Assembler () -> Assembler ()
forall a. Word16 -> [Operand] -> Assembler a -> Assembler a
Emit Word16
w [Operand]
ops (() -> Assembler ()
forall a. a -> Assembler a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
type LabelEnv = LocalLabel -> Word
largeOp :: Bool -> Operand -> Bool
largeOp :: Bool -> Operand -> Bool
largeOp Bool
long_jumps Operand
op = case Operand
op of
SmallOp Word16
_ -> Bool
False
Op Word
w -> Word -> Bool
isLargeW Word
w
IOp Int
i -> Int -> Bool
isLargeI Int
i
LabelOp LocalLabel
_ -> Bool
long_jumps
runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
runAsm :: forall a.
Platform
-> Bool
-> (LocalLabel -> Word)
-> Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
runAsm Platform
platform Bool
long_jumps LocalLabel -> Word
e = Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
go
where
go :: Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
go (NullAsm a
x) = a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
forall a.
a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
go (AllocPtr IO BCOPtr
p_io Word -> Assembler a
k) = do
p <- IO BCOPtr
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO BCOPtr
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO BCOPtr
p_io
w <- state $ \(SizedSeq Word16
st_i0,SizedSeq BCONPtr
st_l0,SizedSeq BCOPtr
st_p0) ->
let st_p1 :: SizedSeq BCOPtr
st_p1 = SizedSeq BCOPtr -> BCOPtr -> SizedSeq BCOPtr
forall a. SizedSeq a -> a -> SizedSeq a
addToSS SizedSeq BCOPtr
st_p0 BCOPtr
p
in (SizedSeq BCOPtr -> Word
forall a. SizedSeq a -> Word
sizeSS SizedSeq BCOPtr
st_p0, (SizedSeq Word16
st_i0,SizedSeq BCONPtr
st_l0,SizedSeq BCOPtr
st_p1))
go $ k w
go (AllocLit [BCONPtr]
lits Word -> Assembler a
k) = do
w <- ((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> (Word, (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO Word
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> (Word, (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO Word)
-> ((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> (Word, (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO Word
forall a b. (a -> b) -> a -> b
$ \(SizedSeq Word16
st_i0,SizedSeq BCONPtr
st_l0,SizedSeq BCOPtr
st_p0) ->
let st_l1 :: SizedSeq BCONPtr
st_l1 = SizedSeq BCONPtr -> [BCONPtr] -> SizedSeq BCONPtr
forall a. SizedSeq a -> [a] -> SizedSeq a
addListToSS SizedSeq BCONPtr
st_l0 [BCONPtr]
lits
in (SizedSeq BCONPtr -> Word
forall a. SizedSeq a -> Word
sizeSS SizedSeq BCONPtr
st_l0, (SizedSeq Word16
st_i0,SizedSeq BCONPtr
st_l1,SizedSeq BCOPtr
st_p0))
go $ k w
go (AllocLabel LocalLabel
_ Assembler a
k) = Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
go Assembler a
k
go (Emit Word16
w [Operand]
ops Assembler a
k) = do
let largeArgs :: Bool
largeArgs = (Operand -> Bool) -> [Operand] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Operand -> Bool
largeOp Bool
long_jumps) [Operand]
ops
opcode :: Word16
opcode
| Bool
largeArgs = Word16 -> Word16
largeArgInstr Word16
w
| Bool
otherwise = Word16
w
words :: [Word16]
words = (Operand -> [Word16]) -> [Operand] -> [Word16]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Operand -> [Word16]
expand [Operand]
ops
expand :: Operand -> [Word16]
expand (SmallOp Word16
w) = [Word16
w]
expand (LabelOp LocalLabel
w) = Operand -> [Word16]
expand (Word -> Operand
Op (LocalLabel -> Word
e LocalLabel
w))
expand (Op Word
w) = if Bool
largeArgs then Platform -> Word64 -> [Word16]
largeArg Platform
platform (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w) else [Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]
expand (IOp Int
i) = if Bool
largeArgs then Platform -> Word64 -> [Word16]
largeArg Platform
platform (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) else [Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i]
((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> ((), (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> ((), (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ())
-> ((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
-> ((), (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
forall a b. (a -> b) -> a -> b
$ \(SizedSeq Word16
st_i0,SizedSeq BCONPtr
st_l0,SizedSeq BCOPtr
st_p0) ->
let st_i1 :: SizedSeq Word16
st_i1 = SizedSeq Word16 -> [Word16] -> SizedSeq Word16
forall a. SizedSeq a -> [a] -> SizedSeq a
addListToSS SizedSeq Word16
st_i0 (Word16
opcode Word16 -> [Word16] -> [Word16]
forall a. a -> [a] -> [a]
: [Word16]
words)
in ((), (SizedSeq Word16
st_i1,SizedSeq BCONPtr
st_l0,SizedSeq BCOPtr
st_p0))
Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
go Assembler a
k
type LabelEnvMap = Map LocalLabel Word
data InspectState = InspectState
{ InspectState -> Word
instrCount :: !Word
, InspectState -> Word
ptrCount :: !Word
, InspectState -> Word
litCount :: !Word
, InspectState -> LabelEnvMap
lblEnv :: LabelEnvMap
}
inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm :: forall a.
Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm Platform
platform Bool
long_jumps Word
initial_offset
= InspectState -> Assembler a -> (Word, LabelEnvMap)
go (Word -> Word -> Word -> LabelEnvMap -> InspectState
InspectState Word
initial_offset Word
0 Word
0 LabelEnvMap
forall k a. Map k a
Map.empty)
where
go :: InspectState -> Assembler a -> (Word, LabelEnvMap)
go InspectState
s (NullAsm a
_) = (InspectState -> Word
instrCount InspectState
s, InspectState -> LabelEnvMap
lblEnv InspectState
s)
go InspectState
s (AllocPtr IO BCOPtr
_ Word -> Assembler a
k) = InspectState -> Assembler a -> (Word, LabelEnvMap)
go (InspectState
s { ptrCount = n + 1 }) (Word -> Assembler a
k Word
n)
where n :: Word
n = InspectState -> Word
ptrCount InspectState
s
go InspectState
s (AllocLit [BCONPtr]
ls Word -> Assembler a
k) = InspectState -> Assembler a -> (Word, LabelEnvMap)
go (InspectState
s { litCount = n + genericLength ls }) (Word -> Assembler a
k Word
n)
where n :: Word
n = InspectState -> Word
litCount InspectState
s
go InspectState
s (AllocLabel LocalLabel
lbl Assembler a
k) = InspectState -> Assembler a -> (Word, LabelEnvMap)
go InspectState
s' Assembler a
k
where s' :: InspectState
s' = InspectState
s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
go InspectState
s (Emit Word16
_ [Operand]
ops Assembler a
k) = InspectState -> Assembler a -> (Word, LabelEnvMap)
go InspectState
s' Assembler a
k
where
s' :: InspectState
s' = InspectState
s { instrCount = instrCount s + size }
size :: Word
size = [Word] -> Word
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Operand -> Word) -> [Operand] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map Operand -> Word
count [Operand]
ops) Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1
largeOps :: Bool
largeOps = (Operand -> Bool) -> [Operand] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Operand -> Bool
largeOp Bool
long_jumps) [Operand]
ops
count :: Operand -> Word
count (SmallOp Word16
_) = Word
1
count (LabelOp LocalLabel
_) = Operand -> Word
count (Word -> Operand
Op Word
0)
count (Op Word
_) = if Bool
largeOps then Platform -> Word
largeArg16s Platform
platform else Word
1
count (IOp Int
_) = if Bool
largeOps then Platform -> Word
largeArg16s Platform
platform else Word
1
#include "Bytecodes.h"
largeArgInstr :: Word16 -> Word16
largeArgInstr :: Word16 -> Word16
largeArgInstr Word16
bci = bci_FLAG_LARGE_ARGS .|. bci
largeArg :: Platform -> Word64 -> [Word16]
largeArg :: Platform -> Word64 -> [Word16]
largeArg Platform
platform Word64
w = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW8 -> [Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
48),
Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32),
Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w]
PlatformWordSize
PW4 -> Bool -> SDoc -> [Word16] -> [Word16]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Word64
w Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32))
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"largeArg too big:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Word64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word64
w) ([Word16] -> [Word16]) -> [Word16] -> [Word16]
forall a b. (a -> b) -> a -> b
$
[Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w]
largeArg16s :: Platform -> Word
largeArg16s :: Platform -> Word
largeArg16s Platform
platform = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW8 -> Word
4
PlatformWordSize
PW4 -> Word
2
assembleI :: Platform
-> BCInstr
-> Assembler ()
assembleI :: Platform -> BCInstr -> Assembler ()
assembleI Platform
platform BCInstr
i = case BCInstr
i of
STKCHECK Word
n -> Word16 -> [Operand] -> Assembler ()
emit bci_STKCHECK [Op n]
PUSH_L WordOff
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_L [wOp o1]
PUSH_LL WordOff
o1 WordOff
o2 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_LL [wOp o1, wOp o2]
PUSH_LLL WordOff
o1 WordOff
o2 WordOff
o3 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]
PUSH8 ByteOff
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH8 [bOp o1]
PUSH16 ByteOff
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH16 [bOp o1]
PUSH32 ByteOff
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH32 [bOp o1]
PUSH8_W ByteOff
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH8_W [bOp o1]
PUSH16_W ByteOff
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH16_W [bOp o1]
PUSH32_W ByteOff
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH32_W [bOp o1]
PUSH_G Name
nm -> do p <- BCOPtr -> Assembler Word
ptr (Name -> BCOPtr
BCOPtrName Name
nm)
emit bci_PUSH_G [Op p]
PUSH_PRIMOP PrimOp
op -> do p <- BCOPtr -> Assembler Word
ptr (PrimOp -> BCOPtr
BCOPtrPrimOp PrimOp
op)
emit bci_PUSH_G [Op p]
PUSH_BCO ProtoBCO Name
proto -> do let ul_bco :: IO UnlinkedBCO
ul_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO Platform
platform ProtoBCO Name
proto
p <- IO BCOPtr -> Assembler Word
ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
ul_bco)
emit bci_PUSH_G [Op p]
PUSH_ALTS ProtoBCO Name
proto ArgRep
pk
-> do let ul_bco :: IO UnlinkedBCO
ul_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO Platform
platform ProtoBCO Name
proto
p <- IO BCOPtr -> Assembler Word
ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
ul_bco)
emit (push_alts pk) [Op p]
PUSH_ALTS_TUPLE ProtoBCO Name
proto NativeCallInfo
call_info ProtoBCO Name
tuple_proto
-> do let ul_bco :: IO UnlinkedBCO
ul_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO Platform
platform ProtoBCO Name
proto
ul_tuple_bco :: IO UnlinkedBCO
ul_tuple_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO Platform
platform
ProtoBCO Name
tuple_proto
p <- IO BCOPtr -> Assembler Word
ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
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]
BCInstr
PUSH_PAD8 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_PAD8 []
BCInstr
PUSH_PAD16 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_PAD16 []
BCInstr
PUSH_PAD32 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_PAD32 []
PUSH_UBX8 Literal
lit -> do np <- Literal -> Assembler Word
literal Literal
lit
emit bci_PUSH_UBX8 [Op np]
PUSH_UBX16 Literal
lit -> do np <- Literal -> Assembler Word
literal Literal
lit
emit bci_PUSH_UBX16 [Op np]
PUSH_UBX32 Literal
lit -> do np <- Literal -> Assembler Word
literal Literal
lit
emit bci_PUSH_UBX32 [Op np]
PUSH_UBX Literal
lit WordOff
nws -> do np <- Literal -> Assembler Word
literal Literal
lit
emit bci_PUSH_UBX [Op np, wOp nws]
PUSH_ADDR Name
nm -> do np <- [BCONPtr] -> Assembler Word
lit [Name -> BCONPtr
BCONPtrAddr Name
nm]
emit bci_PUSH_UBX [Op np, SmallOp 1]
BCInstr
PUSH_APPLY_N -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_N []
BCInstr
PUSH_APPLY_V -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_V []
BCInstr
PUSH_APPLY_F -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_F []
BCInstr
PUSH_APPLY_D -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_D []
BCInstr
PUSH_APPLY_L -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_L []
BCInstr
PUSH_APPLY_P -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_P []
BCInstr
PUSH_APPLY_PP -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_PP []
BCInstr
PUSH_APPLY_PPP -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_PPP []
BCInstr
PUSH_APPLY_PPPP -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_PPPP []
BCInstr
PUSH_APPLY_PPPPP -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_PPPPP []
BCInstr
PUSH_APPLY_PPPPPP -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_APPLY_PPPPPP []
SLIDE WordOff
n WordOff
by -> Word16 -> [Operand] -> Assembler ()
emit bci_SLIDE [wOp n, wOp by]
ALLOC_AP HalfWord
n -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_AP [truncHalfWord platform n]
ALLOC_AP_NOUPD HalfWord
n -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_AP_NOUPD [truncHalfWord platform n]
ALLOC_PAP HalfWord
arity HalfWord
n -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]
MKAP WordOff
off HalfWord
sz -> Word16 -> [Operand] -> Assembler ()
emit bci_MKAP [wOp off, truncHalfWord platform sz]
MKPAP WordOff
off HalfWord
sz -> Word16 -> [Operand] -> Assembler ()
emit bci_MKPAP [wOp off, truncHalfWord platform sz]
UNPACK WordOff
n -> Word16 -> [Operand] -> Assembler ()
emit bci_UNPACK [wOp n]
PACK DataCon
dcon WordOff
sz -> do itbl_no <- [BCONPtr] -> Assembler Word
lit [Name -> BCONPtr
BCONPtrItbl (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dcon)]
emit bci_PACK [Op itbl_no, wOp sz]
LABEL LocalLabel
lbl -> LocalLabel -> Assembler ()
label LocalLabel
lbl
TESTLT_I Int
i LocalLabel
l -> do np <- Int -> Assembler Word
int Int
i
emit bci_TESTLT_I [Op np, LabelOp l]
TESTEQ_I Int
i LocalLabel
l -> do np <- Int -> Assembler Word
int Int
i
emit bci_TESTEQ_I [Op np, LabelOp l]
TESTLT_W Word
w LocalLabel
l -> do np <- Word -> Assembler Word
word Word
w
emit bci_TESTLT_W [Op np, LabelOp l]
TESTEQ_W Word
w LocalLabel
l -> do np <- Word -> Assembler Word
word Word
w
emit bci_TESTEQ_W [Op np, LabelOp l]
TESTLT_I64 Int64
i LocalLabel
l -> do np <- Word64 -> Assembler Word
word64 (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
emit bci_TESTLT_I64 [Op np, LabelOp l]
TESTEQ_I64 Int64
i LocalLabel
l -> do np <- Word64 -> Assembler Word
word64 (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
emit bci_TESTEQ_I64 [Op np, LabelOp l]
TESTLT_I32 Int32
i LocalLabel
l -> do np <- Word -> Assembler Word
word (Int32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
emit bci_TESTLT_I32 [Op np, LabelOp l]
TESTEQ_I32 Int32
i LocalLabel
l -> do np <- Word -> Assembler Word
word (Int32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
emit bci_TESTEQ_I32 [Op np, LabelOp l]
TESTLT_I16 Int16
i LocalLabel
l -> do np <- Word -> Assembler Word
word (Int16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
emit bci_TESTLT_I16 [Op np, LabelOp l]
TESTEQ_I16 Int16
i LocalLabel
l -> do np <- Word -> Assembler Word
word (Int16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
emit bci_TESTEQ_I16 [Op np, LabelOp l]
TESTLT_I8 Int8
i LocalLabel
l -> do np <- Word -> Assembler Word
word (Int8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
i)
emit bci_TESTLT_I8 [Op np, LabelOp l]
TESTEQ_I8 Int16
i LocalLabel
l -> do np <- Word -> Assembler Word
word (Int16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
emit bci_TESTEQ_I8 [Op np, LabelOp l]
TESTLT_W64 Word64
w LocalLabel
l -> do np <- Word64 -> Assembler Word
word64 Word64
w
emit bci_TESTLT_W64 [Op np, LabelOp l]
TESTEQ_W64 Word64
w LocalLabel
l -> do np <- Word64 -> Assembler Word
word64 Word64
w
emit bci_TESTEQ_W64 [Op np, LabelOp l]
TESTLT_W32 Word32
w LocalLabel
l -> do np <- Word -> Assembler Word
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
emit bci_TESTLT_W32 [Op np, LabelOp l]
TESTEQ_W32 Word32
w LocalLabel
l -> do np <- Word -> Assembler Word
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
emit bci_TESTEQ_W32 [Op np, LabelOp l]
TESTLT_W16 Word16
w LocalLabel
l -> do np <- Word -> Assembler Word
word (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w)
emit bci_TESTLT_W16 [Op np, LabelOp l]
TESTEQ_W16 Word16
w LocalLabel
l -> do np <- Word -> Assembler Word
word (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w)
emit bci_TESTEQ_W16 [Op np, LabelOp l]
TESTLT_W8 Word8
w LocalLabel
l -> do np <- Word -> Assembler Word
word (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w)
emit bci_TESTLT_W8 [Op np, LabelOp l]
TESTEQ_W8 Word8
w LocalLabel
l -> do np <- Word -> Assembler Word
word (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w)
emit bci_TESTEQ_W8 [Op np, LabelOp l]
TESTLT_F Float
f LocalLabel
l -> do np <- Float -> Assembler Word
float Float
f
emit bci_TESTLT_F [Op np, LabelOp l]
TESTEQ_F Float
f LocalLabel
l -> do np <- Float -> Assembler Word
float Float
f
emit bci_TESTEQ_F [Op np, LabelOp l]
TESTLT_D Double
d LocalLabel
l -> do np <- Double -> Assembler Word
double Double
d
emit bci_TESTLT_D [Op np, LabelOp l]
TESTEQ_D Double
d LocalLabel
l -> do np <- Double -> Assembler Word
double Double
d
emit bci_TESTEQ_D [Op np, LabelOp l]
TESTLT_P Word16
i LocalLabel
l -> Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_P [SmallOp i, LabelOp l]
TESTEQ_P Word16
i LocalLabel
l -> Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_P [SmallOp i, LabelOp l]
BCInstr
CASEFAIL -> Word16 -> [Operand] -> Assembler ()
emit bci_CASEFAIL []
SWIZZLE WordOff
stkoff Int
n -> Word16 -> [Operand] -> Assembler ()
emit bci_SWIZZLE [wOp stkoff, IOp n]
JMP LocalLabel
l -> Word16 -> [Operand] -> Assembler ()
emit bci_JMP [LabelOp l]
BCInstr
ENTER -> Word16 -> [Operand] -> Assembler ()
emit bci_ENTER []
RETURN ArgRep
rep -> Word16 -> [Operand] -> Assembler ()
emit (ArgRep -> Word16
return_non_tuple ArgRep
rep) []
BCInstr
RETURN_TUPLE -> Word16 -> [Operand] -> Assembler ()
emit bci_RETURN_T []
CCALL WordOff
off RemotePtr C_ffi_cif
m_addr Word16
i -> do np <- RemotePtr C_ffi_cif -> Assembler Word
forall {a}. RemotePtr a -> Assembler Word
addr RemotePtr C_ffi_cif
m_addr
emit bci_CCALL [wOp off, Op np, SmallOp i]
BCInstr
PRIMCALL -> Word16 -> [Operand] -> Assembler ()
emit bci_PRIMCALL []
BRK_FUN ForeignRef BreakArray
arr RemotePtr ModuleName
tick_mod Word16
tickx RemotePtr ModuleName
info_mod Word16
infox RemotePtr CostCentre
cc ->
do p1 <- BCOPtr -> Assembler Word
ptr (ForeignRef BreakArray -> BCOPtr
BCOPtrBreakArray ForeignRef BreakArray
arr)
tick_addr <- addr tick_mod
info_addr <- addr info_mod
np <- addr cc
emit bci_BRK_FUN [ Op p1
, Op tick_addr, Op info_addr
, SmallOp tickx, SmallOp infox
, Op np
]
where
literal :: Literal -> Assembler Word
literal (LitLabel FastString
fs FunctionOrData
_) = FastString -> Assembler Word
litlabel FastString
fs
literal Literal
LitNullAddr = Word -> Assembler Word
word Word
0
literal (LitFloat Rational
r) = Float -> Assembler Word
float (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r)
literal (LitDouble Rational
r) = Double -> Assembler Word
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)
literal (LitChar Char
c) = Int -> Assembler Word
int (Char -> Int
ord Char
c)
literal (LitString ByteString
bs) = [BCONPtr] -> Assembler Word
lit [ByteString -> BCONPtr
BCONPtrStr ByteString
bs]
literal (LitNumber LitNumType
nt Integer
i) = case LitNumType
nt of
LitNumType
LitNumInt -> Word -> Assembler Word
word (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord -> Word -> Assembler Word
word (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt8 -> Word8 -> Assembler Word
word8 (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord8 -> Word8 -> Assembler Word
word8 (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt16 -> Word16 -> Assembler Word
word16 (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord16 -> Word16 -> Assembler Word
word16 (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt32 -> Word32 -> Assembler Word
word32 (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord32 -> Word32 -> Assembler Word
word32 (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt64 -> Word64 -> Assembler Word
word64 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord64 -> Word64 -> Assembler Word
word64 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumBigNat -> String -> Assembler Word
forall a. HasCallStack => String -> a
panic String
"GHC.ByteCode.Asm.literal: LitNumBigNat"
literal (LitRubbish {}) = Word -> Assembler Word
word Word
0
litlabel :: FastString -> Assembler Word
litlabel FastString
fs = [BCONPtr] -> Assembler Word
lit [FastString -> BCONPtr
BCONPtrLbl FastString
fs]
addr :: RemotePtr a -> Assembler Word
addr (RemotePtr Word64
a) = [Word] -> Assembler Word
words [Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a]
words :: [Word] -> Assembler Word
words [Word]
ws = [BCONPtr] -> Assembler Word
lit ((Word -> BCONPtr) -> [Word] -> [BCONPtr]
forall a b. (a -> b) -> [a] -> [b]
map Word -> BCONPtr
BCONPtrWord [Word]
ws)
word :: Word -> Assembler Word
word Word
w = [Word] -> Assembler Word
words [Word
w]
word_size :: PlatformWordSize
word_size = Platform -> PlatformWordSize
platformWordSize Platform
platform
word_size_bits :: Int
word_size_bits = Platform -> Int
platformWordSizeInBits Platform
platform
int :: Int -> Assembler Word
int :: Int -> Assembler Word
int Int
i = Word -> Assembler Word
word (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
float :: Float -> Assembler Word
float :: Float -> Assembler Word
float Float
f = Word32 -> Assembler Word
word32 (Float -> Word32
castFloatToWord32 Float
f)
double :: Double -> Assembler Word
double :: Double -> Assembler Word
double Double
d = Word64 -> Assembler Word
word64 (Double -> Word64
castDoubleToWord64 Double
d)
word64 :: Word64 -> Assembler Word
word64 :: Word64 -> Assembler Word
word64 Word64
ww = case PlatformWordSize
word_size of
PlatformWordSize
PW4 ->
let !wl :: Word
wl = Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ww
!wh :: Word
wh = Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
ww Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
32)
in case Platform -> ByteOrder
platformByteOrder Platform
platform of
ByteOrder
LittleEndian -> [Word] -> Assembler Word
words [Word
wl,Word
wh]
ByteOrder
BigEndian -> [Word] -> Assembler Word
words [Word
wh,Word
wl]
PlatformWordSize
PW8 -> Word -> Assembler Word
word (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ww)
word8 :: Word8 -> Assembler Word
word8 :: Word8 -> Assembler Word
word8 Word8
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
ByteOrder
LittleEndian -> Word -> Assembler Word
word (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x)
ByteOrder
BigEndian -> Word -> Assembler Word
word (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
word_size_bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8))
word16 :: Word16 -> Assembler Word
word16 :: Word16 -> Assembler Word
word16 Word16
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
ByteOrder
LittleEndian -> Word -> Assembler Word
word (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x)
ByteOrder
BigEndian -> Word -> Assembler Word
word (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
word_size_bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16))
word32 :: Word32 -> Assembler Word
word32 :: Word32 -> Assembler Word
word32 Word32
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
ByteOrder
LittleEndian -> Word -> Assembler Word
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x)
ByteOrder
BigEndian -> case PlatformWordSize
word_size of
PlatformWordSize
PW4 -> Word -> Assembler Word
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x)
PlatformWordSize
PW8 -> Word -> Assembler Word
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
32)
isLargeW :: Word -> Bool
isLargeW :: Word -> Bool
isLargeW Word
n = Word
n Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
65535
isLargeI :: Int -> Bool
isLargeI :: Int -> Bool
isLargeI Int
n = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
32767 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< -Int
32768
push_alts :: ArgRep -> Word16
push_alts :: ArgRep -> Word16
push_alts ArgRep
V = bci_PUSH_ALTS_V
push_alts ArgRep
P = bci_PUSH_ALTS_P
push_alts ArgRep
N = bci_PUSH_ALTS_N
push_alts ArgRep
L = bci_PUSH_ALTS_L
push_alts ArgRep
F = bci_PUSH_ALTS_F
push_alts ArgRep
D = bci_PUSH_ALTS_D
push_alts ArgRep
V16 = String -> Word16
forall a. HasCallStack => String -> a
error String
"push_alts: vector"
push_alts ArgRep
V32 = String -> Word16
forall a. HasCallStack => String -> a
error String
"push_alts: vector"
push_alts ArgRep
V64 = String -> Word16
forall a. HasCallStack => String -> a
error String
"push_alts: vector"
return_non_tuple :: ArgRep -> Word16
return_non_tuple :: ArgRep -> Word16
return_non_tuple ArgRep
V = bci_RETURN_V
return_non_tuple ArgRep
P = bci_RETURN_P
return_non_tuple ArgRep
N = bci_RETURN_N
return_non_tuple ArgRep
L = bci_RETURN_L
return_non_tuple ArgRep
F = bci_RETURN_F
return_non_tuple ArgRep
D = bci_RETURN_D
return_non_tuple ArgRep
V16 = String -> Word16
forall a. HasCallStack => String -> a
error String
"return_non_tuple: vector"
return_non_tuple ArgRep
V32 = String -> Word16
forall a. HasCallStack => String -> a
error String
"return_non_tuple: vector"
return_non_tuple ArgRep
V64 = String -> Word16
forall a. HasCallStack => String -> a
error String
"return_non_tuple: vector"
maxTupleReturnNativeStackSize :: WordOff
maxTupleReturnNativeStackSize :: WordOff
maxTupleReturnNativeStackSize = WordOff
62
mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32
mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32
mkNativeCallInfoSig Platform
platform NativeCallInfo{GlobalRegSet
NativeCallType
WordOff
nativeCallType :: NativeCallType
nativeCallSize :: WordOff
nativeCallRegs :: GlobalRegSet
nativeCallStackSpillSize :: WordOff
nativeCallStackSpillSize :: NativeCallInfo -> WordOff
nativeCallRegs :: NativeCallInfo -> GlobalRegSet
nativeCallSize :: NativeCallInfo -> WordOff
nativeCallType :: NativeCallInfo -> NativeCallType
..}
| NativeCallType
nativeCallType NativeCallType -> NativeCallType -> Bool
forall a. Eq a => a -> a -> Bool
== NativeCallType
NativeTupleReturn Bool -> Bool -> Bool
&& WordOff
nativeCallStackSpillSize WordOff -> WordOff -> Bool
forall a. Ord a => a -> a -> Bool
> WordOff
maxTupleReturnNativeStackSize
= String -> SDoc -> Word32
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkNativeCallInfoSig: tuple too big for the bytecode compiler"
(WordOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr WordOff
nativeCallStackSpillSize SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stack words." SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Use -fobject-code to get around this limit"
)
| Bool
otherwise
=
Bool
-> SDoc
-> (Bool
-> SDoc
-> (Bool -> SDoc -> Word32 -> Word32)
-> Bool
-> SDoc
-> Word32
-> Word32)
-> Bool
-> SDoc
-> (Bool -> SDoc -> Word32 -> Word32)
-> Bool
-> SDoc
-> Word32
-> Word32
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([(GlobalReg, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(GlobalReg, Int)]
argRegs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
24) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"too many registers for bitmap:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([(GlobalReg, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(GlobalReg, Int)]
argRegs))
Bool
-> SDoc
-> (Bool -> SDoc -> Word32 -> Word32)
-> Bool
-> SDoc
-> Word32
-> Word32
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Word32
cont_offset Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
255) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"continuation offset too large:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word32
cont_offset)
Bool -> SDoc -> Word32 -> Word32
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ((GlobalReg -> Bool) -> [GlobalReg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (GlobalReg -> [GlobalReg] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((GlobalReg, Int) -> GlobalReg)
-> [(GlobalReg, Int)] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalReg, Int) -> GlobalReg
forall a b. (a, b) -> a
fst [(GlobalReg, Int)]
argRegs)) (GlobalRegSet -> [GlobalReg]
forall r. RegSet r -> [r]
regSetToList GlobalRegSet
nativeCallRegs))
( [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"not all registers accounted for"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"argRegs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(GlobalReg, Int)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(GlobalReg, Int)]
argRegs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"nativeCallRegs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GlobalRegSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalRegSet
nativeCallRegs
] ) (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
(Word32 -> (GlobalReg, Int) -> Word32)
-> Word32 -> [(GlobalReg, Int)] -> Word32
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word32 -> (GlobalReg, Int) -> Word32
reg_bit Word32
0 [(GlobalReg, Int)]
argRegs Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
cont_offset Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
where
cont_offset :: Word32
cont_offset :: Word32
cont_offset
| NativeCallType
nativeCallType NativeCallType -> NativeCallType -> Bool
forall a. Eq a => a -> a -> Bool
== NativeCallType
NativeTupleReturn = WordOff -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
nativeCallStackSpillSize
| Bool
otherwise = Word32
0
reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
reg_bit Word32
x (GlobalReg
r, Int
n)
| GlobalReg
r GlobalReg -> GlobalRegSet -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` GlobalRegSet
nativeCallRegs = Word32
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
n
| Bool
otherwise = Word32
x
argRegs :: [(GlobalReg, Int)]
argRegs = [GlobalReg] -> [Int] -> [(GlobalReg, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Platform -> GlobalArgRegs -> [GlobalReg]
allArgRegsCover Platform
platform GlobalArgRegs
SCALAR_ARG_REGS) [Int
0..]
mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal
mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal
mkNativeCallInfoLit Platform
platform NativeCallInfo
call_info =
Platform -> Integer -> Literal
mkLitWord Platform
platform (Integer -> Literal) -> (Word32 -> Integer) -> Word32 -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Literal) -> Word32 -> Literal
forall a b. (a -> b) -> a -> b
$ Platform -> NativeCallInfo -> Word32
mkNativeCallInfoSig Platform
platform NativeCallInfo
call_info
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH