{-# 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 hiding ( WordOff )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Literal
import GHC.Types.Unique
import GHC.Types.Unique.DSet
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.TyCon
import GHC.Data.FastString
import GHC.Data.SizedSeq
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Cmm.Expr
import GHC.Cmm.CallConv ( allArgRegsCover )
import GHC.Platform
import GHC.Platform.Profile
import Control.Monad
import Control.Monad.ST ( runST )
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Array.MArray
import qualified Data.Array.Unboxed as Array
import Data.Array.Base ( UArray(..) )
import Data.Array.Unsafe( castSTUArray )
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
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
_ UArray Int Word16
_ UArray Int Word64
_ SizedSeq BCONPtr
nonptrs SizedSeq 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 <- SizedSeq BCOPtr -> [BCOPtr]
forall a. SizedSeq a -> [a]
ssElts SizedSeq 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 <- SizedSeq BCONPtr -> [BCONPtr]
forall a. SizedSeq a -> [a]
ssElts SizedSeq 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 <- SizedSeq BCOPtr -> [BCOPtr]
forall a. SizedSeq a -> [a]
ssElts SizedSeq BCOPtr
ptrs ]
)
assembleBCOs
:: Interp
-> Profile
-> [ProtoBCO Name]
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs :: Interp
-> Profile
-> [ProtoBCO Name]
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs Interp
interp Profile
profile [ProtoBCO Name]
proto_bcos [TyCon]
tycons AddrEnv
top_strs Maybe ModBreaks
modbreaks = do
ItblEnv
itblenv <- Interp -> Profile -> [TyCon] -> IO ItblEnv
mkITbls Interp
interp Profile
profile [TyCon]
tycons
[UnlinkedBCO]
bcos <- (ProtoBCO Name -> IO UnlinkedBCO)
-> [ProtoBCO Name] -> IO [UnlinkedBCO]
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) -> [a] -> m [b]
mapM (Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (Profile -> Platform
profilePlatform Profile
profile)) [ProtoBCO Name]
proto_bcos
[UnlinkedBCO]
bcos' <- Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
mallocStrings Interp
interp [UnlinkedBCO]
bcos
CompiledByteCode -> IO CompiledByteCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CompiledByteCode
{ bc_bcos :: [UnlinkedBCO]
bc_bcos = [UnlinkedBCO]
bcos'
, bc_itbls :: ItblEnv
bc_itbls = ItblEnv
itblenv
, bc_ffis :: [FFIInfo]
bc_ffis = (ProtoBCO Name -> [FFIInfo]) -> [ProtoBCO Name] -> [FFIInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ProtoBCO Name -> [FFIInfo]
forall a. ProtoBCO a -> [FFIInfo]
protoBCOFFIs [ProtoBCO Name]
proto_bcos
, bc_strs :: AddrEnv
bc_strs = AddrEnv
top_strs
, bc_breaks :: Maybe ModBreaks
bc_breaks = Maybe ModBreaks
modbreaks
}
mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
mallocStrings Interp
interp [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] ())
-> [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 [UnlinkedBCO]
ulbcos) [])
[RemotePtr ()]
ptrs <- Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp ([ByteString] -> Message [RemotePtr ()]
MallocStrings [ByteString]
bytestrings)
[UnlinkedBCO] -> IO [UnlinkedBCO]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (State [RemotePtr ()] [UnlinkedBCO]
-> [RemotePtr ()] -> [UnlinkedBCO]
forall s a. State s a -> s -> a
evalState ((UnlinkedBCO -> StateT [RemotePtr ()] Identity UnlinkedBCO)
-> [UnlinkedBCO] -> State [RemotePtr ()] [UnlinkedBCO]
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) -> [a] -> m [b]
mapM UnlinkedBCO -> StateT [RemotePtr ()] Identity UnlinkedBCO
forall {m :: * -> *} {a}.
Monad m =>
UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
splice [UnlinkedBCO]
ulbcos) [RemotePtr ()]
ptrs)
where
splice :: UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
splice bco :: UnlinkedBCO
bco@UnlinkedBCO{Int
UArray Int Word16
UArray Int Word64
SizedSeq BCONPtr
SizedSeq BCOPtr
Name
unlinkedBCOName :: UnlinkedBCO -> Name
unlinkedBCOName :: Name
unlinkedBCOArity :: Int
unlinkedBCOInstrs :: UArray Int Word16
unlinkedBCOBitmap :: UArray Int Word64
unlinkedBCOLits :: SizedSeq BCONPtr
unlinkedBCOPtrs :: SizedSeq BCOPtr
unlinkedBCOArity :: UnlinkedBCO -> Int
unlinkedBCOInstrs :: UnlinkedBCO -> UArray Int Word16
unlinkedBCOBitmap :: UnlinkedBCO -> UArray Int Word64
unlinkedBCOLits :: UnlinkedBCO -> SizedSeq BCONPtr
unlinkedBCOPtrs :: UnlinkedBCO -> SizedSeq BCOPtr
..} = do
SizedSeq BCONPtr
lits <- (BCONPtr -> StateT [RemotePtr a] m BCONPtr)
-> SizedSeq BCONPtr -> StateT [RemotePtr a] m (SizedSeq 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) -> SizedSeq a -> m (SizedSeq b)
mapM BCONPtr -> StateT [RemotePtr a] m BCONPtr
forall {m :: * -> *} {a}.
Monad m =>
BCONPtr -> StateT [RemotePtr a] m BCONPtr
spliceLit SizedSeq BCONPtr
unlinkedBCOLits
SizedSeq BCOPtr
ptrs <- (BCOPtr -> StateT [RemotePtr a] m BCOPtr)
-> SizedSeq BCOPtr -> StateT [RemotePtr a] m (SizedSeq BCOPtr)
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) -> SizedSeq a -> m (SizedSeq b)
mapM BCOPtr -> StateT [RemotePtr a] m BCOPtr
splicePtr SizedSeq BCOPtr
unlinkedBCOPtrs
UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
forall a. a -> StateT [RemotePtr a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return UnlinkedBCO
bco { unlinkedBCOLits :: SizedSeq BCONPtr
unlinkedBCOLits = SizedSeq BCONPtr
lits, unlinkedBCOPtrs :: SizedSeq BCOPtr
unlinkedBCOPtrs = SizedSeq BCOPtr
ptrs }
spliceLit :: BCONPtr -> StateT [RemotePtr a] m BCONPtr
spliceLit (BCONPtrStr ByteString
_) = do
[RemotePtr a]
rptrs <- StateT [RemotePtr a] m [RemotePtr a]
forall (m :: * -> *) s. Monad m => StateT s m s
get
case [RemotePtr a]
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. 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
UArray Int Word16
UArray Int Word64
SizedSeq BCONPtr
SizedSeq BCOPtr
Name
unlinkedBCOName :: UnlinkedBCO -> Name
unlinkedBCOArity :: UnlinkedBCO -> Int
unlinkedBCOInstrs :: UnlinkedBCO -> UArray Int Word16
unlinkedBCOBitmap :: UnlinkedBCO -> UArray Int Word64
unlinkedBCOLits :: UnlinkedBCO -> SizedSeq BCONPtr
unlinkedBCOPtrs :: UnlinkedBCO -> SizedSeq BCOPtr
unlinkedBCOName :: Name
unlinkedBCOArity :: Int
unlinkedBCOInstrs :: UArray Int Word16
unlinkedBCOBitmap :: UArray Int Word64
unlinkedBCOLits :: SizedSeq BCONPtr
unlinkedBCOPtrs :: SizedSeq BCOPtr
..} = do
(BCONPtr -> StateT [ByteString] m ())
-> SizedSeq 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 SizedSeq BCONPtr
unlinkedBCOLits
(BCOPtr -> StateT [ByteString] m ())
-> SizedSeq 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 SizedSeq BCOPtr
unlinkedBCOPtrs
collectLit :: BCONPtr -> StateT [ByteString] m ()
collectLit (BCONPtrStr ByteString
bs) = do
[ByteString]
strs <- StateT [ByteString] m [ByteString]
forall (m :: * -> *) s. Monad m => StateT s m s
get
[ByteString] -> StateT [ByteString] m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
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
UnlinkedBCO
ubco <- Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (Profile -> Platform
profilePlatform Profile
profile) ProtoBCO Name
pbco
[UnlinkedBCO
ubco'] <- Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
mallocStrings Interp
interp [UnlinkedBCO
ubco]
UnlinkedBCO -> IO UnlinkedBCO
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UnlinkedBCO
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 -> Word16
protoBCOBitmapSize = Word16
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
isLarge (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
isLarge 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)
(SizedSeq Word16
final_insns, SizedSeq BCONPtr
final_lits, SizedSeq BCOPtr
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
Bool -> SDoc -> IO ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Word
n_insns Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== SizedSeq Word16 -> Word
forall a. SizedSeq a -> Word
sizeSS SizedSeq Word16
final_insns)
(String -> SDoc
text String
"bytecode instruction count mismatch")
let asm_insns :: [Word16]
asm_insns = SizedSeq Word16 -> [Word16]
forall a. SizedSeq a -> [a]
ssElts SizedSeq Word16
final_insns
insns_arr :: UArray Int Word16
insns_arr = (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, 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 Word64
bitmap_arr = Word16 -> [StgWord] -> UArray Int Word64
mkBitmapArray Word16
bsize [StgWord]
bitmap
ul_bco :: UnlinkedBCO
ul_bco = Name
-> Int
-> UArray Int Word16
-> UArray Int Word64
-> SizedSeq BCONPtr
-> SizedSeq BCOPtr
-> UnlinkedBCO
UnlinkedBCO Name
nm Int
arity UArray Int Word16
insns_arr UArray Int Word64
bitmap_arr SizedSeq BCONPtr
final_lits SizedSeq BCOPtr
final_ptrs
UnlinkedBCO -> IO UnlinkedBCO
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UnlinkedBCO
ul_bco
mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64
mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64
mkBitmapArray Word16
bsize [StgWord]
bitmap
= (Int, Int) -> [Word64] -> UArray Int Word64
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) ([Word64] -> UArray Int Word64) -> [Word64] -> UArray Int Word64
forall a b. (a -> b) -> a -> b
$
Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bsize Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: (StgWord -> Word64) -> [StgWord] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> (StgWord -> Integer) -> StgWord -> Word64
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
| SmallOp Word16
| LabelOp LocalLabel
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
isLarge Word
w
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
BCOPtr
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
Word
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_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))
Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
go (Assembler a
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a)
-> Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
forall a b. (a -> b) -> a -> b
$ Word -> Assembler a
k Word
w
go (AllocLit [BCONPtr]
lits Word -> Assembler a
k) = do
Word
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))
Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
go (Assembler a
-> StateT
(SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a)
-> Assembler a
-> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
forall a b. (a -> b) -> a -> b
$ Word -> Assembler a
k Word
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 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
opcode :: Word16
opcode
| Bool
largeOps = 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
largeOps then Platform -> Word -> [Word16]
largeArg Platform
platform Word
w else [Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]
((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 :: Word
ptrCount = Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
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 :: Word
litCount = Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ [BCONPtr] -> Word
forall i a. Num i => [a] -> i
genericLength [BCONPtr]
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 :: LabelEnvMap
lblEnv = LocalLabel -> Word -> LabelEnvMap -> LabelEnvMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert LocalLabel
lbl (InspectState -> Word
instrCount InspectState
s) (InspectState -> LabelEnvMap
lblEnv InspectState
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 :: Word
instrCount = InspectState -> Word
instrCount InspectState
s Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
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
#include "Bytecodes.h"
largeArgInstr :: Word16 -> Word16
largeArgInstr :: Word16 -> Word16
largeArgInstr Word16
bci = bci_FLAG_LARGE_ARGS .|. bci
largeArg :: Platform -> Word -> [Word16]
largeArg :: Platform -> Word -> [Word16]
largeArg Platform
platform Word
w = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW8 -> [Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
48),
Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
32),
Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]
PlatformWordSize
PW4 -> Bool -> SDoc -> [Word16] -> [Word16]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Word
w Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32))
(String -> SDoc
text String
"largeArg too big:" SDoc -> SDoc -> SDoc
<+> Word -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word
w) ([Word16] -> [Word16]) -> [Word16] -> [Word16]
forall a b. (a -> b) -> a -> b
$
[Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
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 Word16
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_L [SmallOp o1]
PUSH_LL Word16
o1 Word16
o2 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
PUSH_LLL Word16
o1 Word16
o2 Word16
o3 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
PUSH8 Word16
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH8 [SmallOp o1]
PUSH16 Word16
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH16 [SmallOp o1]
PUSH32 Word16
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH32 [SmallOp o1]
PUSH8_W Word16
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH8_W [SmallOp o1]
PUSH16_W Word16
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH16_W [SmallOp o1]
PUSH32_W Word16
o1 -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH32_W [SmallOp o1]
PUSH_G Name
nm -> do Word
p <- BCOPtr -> Assembler Word
ptr (Name -> BCOPtr
BCOPtrName Name
nm)
Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_G [Op p]
PUSH_PRIMOP PrimOp
op -> do Word
p <- BCOPtr -> Assembler Word
ptr (PrimOp -> BCOPtr
BCOPtrPrimOp PrimOp
op)
Word16 -> [Operand] -> Assembler ()
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
Word
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)
Word16 -> [Operand] -> Assembler ()
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
Word
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)
Word16 -> [Operand] -> Assembler ()
emit (ArgRep -> Word16
push_alts ArgRep
pk) [Word -> Operand
Op Word
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
Word
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)
Word
p_tup <- 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_tuple_bco)
Word
info <- Int -> Assembler Word
int (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$
Platform -> NativeCallInfo -> Word32
mkNativeCallInfoSig Platform
platform NativeCallInfo
call_info)
Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_ALTS_T
[Word -> Operand
Op Word
p, Word -> Operand
Op Word
info, Word -> Operand
Op Word
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 Word
np <- Literal -> Assembler Word
literal Literal
lit
Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_UBX8 [Op np]
PUSH_UBX16 Literal
lit -> do Word
np <- Literal -> Assembler Word
literal Literal
lit
Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_UBX16 [Op np]
PUSH_UBX32 Literal
lit -> do Word
np <- Literal -> Assembler Word
literal Literal
lit
Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_UBX32 [Op np]
PUSH_UBX Literal
lit Word16
nws -> do Word
np <- Literal -> Assembler Word
literal Literal
lit
Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_UBX [Op np, SmallOp nws]
PUSH_ADDR Name
nm -> do Word
np <- [BCONPtr] -> Assembler Word
lit [Name -> BCONPtr
BCONPtrAddr Name
nm]
Word16 -> [Operand] -> Assembler ()
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 Word16
n Word16
by -> Word16 -> [Operand] -> Assembler ()
emit bci_SLIDE [SmallOp n, SmallOp by]
ALLOC_AP Word16
n -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_AP [SmallOp n]
ALLOC_AP_NOUPD Word16
n -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_AP_NOUPD [SmallOp n]
ALLOC_PAP Word16
arity Word16
n -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
MKAP Word16
off Word16
sz -> Word16 -> [Operand] -> Assembler ()
emit bci_MKAP [SmallOp off, SmallOp sz]
MKPAP Word16
off Word16
sz -> Word16 -> [Operand] -> Assembler ()
emit bci_MKPAP [SmallOp off, SmallOp sz]
UNPACK Word16
n -> Word16 -> [Operand] -> Assembler ()
emit bci_UNPACK [SmallOp n]
PACK DataCon
dcon Word16
sz -> do Word
itbl_no <- [BCONPtr] -> Assembler Word
lit [Name -> BCONPtr
BCONPtrItbl (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dcon)]
Word16 -> [Operand] -> Assembler ()
emit bci_PACK [Op itbl_no, SmallOp sz]
LABEL LocalLabel
lbl -> LocalLabel -> Assembler ()
label LocalLabel
lbl
TESTLT_I Int
i LocalLabel
l -> do Word
np <- Int -> Assembler Word
int Int
i
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_I [Op np, LabelOp l]
TESTEQ_I Int
i LocalLabel
l -> do Word
np <- Int -> Assembler Word
int Int
i
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_I [Op np, LabelOp l]
TESTLT_W Word
w LocalLabel
l -> do Word
np <- Word -> Assembler Word
word Word
w
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_W [Op np, LabelOp l]
TESTEQ_W Word
w LocalLabel
l -> do Word
np <- Word -> Assembler Word
word Word
w
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_W [Op np, LabelOp l]
TESTLT_I64 Int64
i LocalLabel
l -> do Word
np <- Int64 -> Assembler Word
int64 Int64
i
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_I64 [Op np, LabelOp l]
TESTEQ_I64 Int64
i LocalLabel
l -> do Word
np <- Int64 -> Assembler Word
int64 Int64
i
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_I64 [Op np, LabelOp l]
TESTLT_I32 Int32
i LocalLabel
l -> do Word
np <- Int -> Assembler Word
int (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_I32 [Op np, LabelOp l]
TESTEQ_I32 Int32
i LocalLabel
l -> do Word
np <- Int -> Assembler Word
int (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_I32 [Op np, LabelOp l]
TESTLT_I16 Int16
i LocalLabel
l -> do Word
np <- Int -> Assembler Word
int (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_I16 [Op np, LabelOp l]
TESTEQ_I16 Int16
i LocalLabel
l -> do Word
np <- Int -> Assembler Word
int (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_I16 [Op np, LabelOp l]
TESTLT_I8 Int8
i LocalLabel
l -> do Word
np <- Int -> Assembler Word
int (Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
i)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_I8 [Op np, LabelOp l]
TESTEQ_I8 Int16
i LocalLabel
l -> do Word
np <- Int -> Assembler Word
int (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_I8 [Op np, LabelOp l]
TESTLT_W64 Word64
w LocalLabel
l -> do Word
np <- Word64 -> Assembler Word
word64 Word64
w
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_W64 [Op np, LabelOp l]
TESTEQ_W64 Word64
w LocalLabel
l -> do Word
np <- Word64 -> Assembler Word
word64 Word64
w
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_W64 [Op np, LabelOp l]
TESTLT_W32 Word32
w LocalLabel
l -> do Word
np <- Word -> Assembler Word
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_W32 [Op np, LabelOp l]
TESTEQ_W32 Word32
w LocalLabel
l -> do Word
np <- Word -> Assembler Word
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_W32 [Op np, LabelOp l]
TESTLT_W16 Word16
w LocalLabel
l -> do Word
np <- Word -> Assembler Word
word (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_W16 [Op np, LabelOp l]
TESTEQ_W16 Word16
w LocalLabel
l -> do Word
np <- Word -> Assembler Word
word (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_W16 [Op np, LabelOp l]
TESTLT_W8 Word8
w LocalLabel
l -> do Word
np <- Word -> Assembler Word
word (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_W8 [Op np, LabelOp l]
TESTEQ_W8 Word8
w LocalLabel
l -> do Word
np <- Word -> Assembler Word
word (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w)
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_W8 [Op np, LabelOp l]
TESTLT_F Float
f LocalLabel
l -> do Word
np <- Float -> Assembler Word
float Float
f
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_F [Op np, LabelOp l]
TESTEQ_F Float
f LocalLabel
l -> do Word
np <- Float -> Assembler Word
float Float
f
Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_F [Op np, LabelOp l]
TESTLT_D Double
d LocalLabel
l -> do Word
np <- Double -> Assembler Word
double Double
d
Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_D [Op np, LabelOp l]
TESTEQ_D Double
d LocalLabel
l -> do Word
np <- Double -> Assembler Word
double Double
d
Word16 -> [Operand] -> Assembler ()
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 Word16
stkoff Word16
n -> Word16 -> [Operand] -> Assembler ()
emit bci_SWIZZLE [SmallOp stkoff, SmallOp 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 Word16
off RemotePtr C_ffi_cif
m_addr Word16
i -> do Word
np <- RemotePtr C_ffi_cif -> Assembler Word
forall {a}. RemotePtr a -> Assembler Word
addr RemotePtr C_ffi_cif
m_addr
Word16 -> [Operand] -> Assembler ()
emit bci_CCALL [SmallOp off, Op np, SmallOp i]
BCInstr
PRIMCALL -> Word16 -> [Operand] -> Assembler ()
emit bci_PRIMCALL []
BRK_FUN Word16
index Unique
uniq RemotePtr CostCentre
cc -> do Word
p1 <- BCOPtr -> Assembler Word
ptr BCOPtr
BCOPtrBreakArray
Word
q <- Int -> Assembler Word
int (Unique -> Int
getKey Unique
uniq)
Word
np <- RemotePtr CostCentre -> Assembler Word
forall {a}. RemotePtr a -> Assembler Word
addr RemotePtr CostCentre
cc
Word16 -> [Operand] -> Assembler ()
emit bci_BRK_FUN [Op p1, SmallOp index,
Op q, Op np]
where
literal :: Literal -> Assembler Word
literal (LitLabel FastString
fs (Just Int
sz) FunctionOrData
_)
| Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
= FastString -> Assembler Word
litlabel (FastString -> FastString -> FastString
appendFS FastString
fs (String -> FastString
mkFastString (Char
'@'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
sz)))
literal (LitLabel FastString
fs Maybe Int
_ FunctionOrData
_) = FastString -> Assembler Word
litlabel FastString
fs
literal Literal
LitNullAddr = Int -> Assembler Word
int Int
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 -> Int -> Assembler Word
int (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord -> Int -> Assembler Word
int (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt8 -> Int64 -> Assembler Word
int8 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord8 -> Int64 -> Assembler Word
int8 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt16 -> Int64 -> Assembler Word
int16 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord16 -> Int64 -> Assembler Word
int16 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt32 -> Int64 -> Assembler Word
int32 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord32 -> Int64 -> Assembler Word
int32 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt64 -> Int64 -> Assembler Word
int64 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord64 -> Int64 -> Assembler Word
int64 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumBigNat -> String -> Assembler Word
forall a. String -> a
panic String
"GHC.ByteCode.Asm.literal: LitNumBigNat"
literal (LitRubbish {}) = Int -> Assembler Word
int Int
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]
float :: Float -> Assembler Word
float = [Word] -> Assembler Word
words ([Word] -> Assembler Word)
-> (Float -> [Word]) -> Float -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Float -> [Word]
mkLitF Platform
platform
double :: Double -> Assembler Word
double = [Word] -> Assembler Word
words ([Word] -> Assembler Word)
-> (Double -> [Word]) -> Double -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Double -> [Word]
mkLitD Platform
platform
int :: Int -> Assembler Word
int = [Word] -> Assembler Word
words ([Word] -> Assembler Word)
-> (Int -> [Word]) -> Int -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word]
mkLitI
int8 :: Int64 -> Assembler Word
int8 = [Word] -> Assembler Word
words ([Word] -> Assembler Word)
-> (Int64 -> [Word]) -> Int64 -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
int16 :: Int64 -> Assembler Word
int16 = [Word] -> Assembler Word
words ([Word] -> Assembler Word)
-> (Int64 -> [Word]) -> Int64 -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
int32 :: Int64 -> Assembler Word
int32 = [Word] -> Assembler Word
words ([Word] -> Assembler Word)
-> (Int64 -> [Word]) -> Int64 -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
int64 :: Int64 -> Assembler Word
int64 = [Word] -> Assembler Word
words ([Word] -> Assembler Word)
-> (Int64 -> [Word]) -> Int64 -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
word64 :: Word64 -> Assembler Word
word64 = [Word] -> Assembler Word
words ([Word] -> Assembler Word)
-> (Word64 -> [Word]) -> Word64 -> Assembler Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Word64 -> [Word]
mkLitW64 Platform
platform
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]
isLarge :: Word -> Bool
isLarge :: Word -> Bool
isLarge Word
n = Word
n Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
65535
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
nativeCallType :: NativeCallInfo -> NativeCallType
nativeCallSize :: NativeCallInfo -> WordOff
nativeCallRegs :: NativeCallInfo -> GlobalRegSet
nativeCallStackSpillSize :: NativeCallInfo -> WordOff
..}
| 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
<+> String -> SDoc
text String
"stack words." SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"Use -fobject-code to get around this limit"
)
| Bool
otherwise
= Bool
-> SDoc
-> (Bool
-> SDoc
-> (Bool
-> SDoc
-> ((Word32 -> (GlobalReg, Int) -> Word32)
-> Word32 -> [(GlobalReg, Int)] -> Word32)
-> (Word32 -> (GlobalReg, Int) -> Word32)
-> Word32
-> [(GlobalReg, Int)]
-> Word32)
-> Bool
-> SDoc
-> ((Word32 -> (GlobalReg, Int) -> Word32)
-> Word32 -> [(GlobalReg, Int)] -> Word32)
-> (Word32 -> (GlobalReg, Int) -> Word32)
-> Word32
-> [(GlobalReg, Int)]
-> Word32)
-> Bool
-> SDoc
-> (Bool
-> SDoc
-> ((Word32 -> (GlobalReg, Int) -> Word32)
-> Word32 -> [(GlobalReg, Int)] -> Word32)
-> (Word32 -> (GlobalReg, Int) -> Word32)
-> Word32
-> [(GlobalReg, Int)]
-> Word32)
-> Bool
-> SDoc
-> ((Word32 -> (GlobalReg, Int) -> Word32)
-> Word32 -> [(GlobalReg, Int)] -> Word32)
-> (Word32 -> (GlobalReg, Int) -> Word32)
-> Word32
-> [(GlobalReg, Int)]
-> Word32
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([GlobalReg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GlobalReg]
regs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
24) (String -> SDoc
text String
"too many registers for bitmap:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([GlobalReg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GlobalReg]
regs))
Bool
-> SDoc
-> (Bool
-> SDoc
-> ((Word32 -> (GlobalReg, Int) -> Word32)
-> Word32 -> [(GlobalReg, Int)] -> Word32)
-> (Word32 -> (GlobalReg, Int) -> Word32)
-> Word32
-> [(GlobalReg, Int)]
-> Word32)
-> Bool
-> SDoc
-> ((Word32 -> (GlobalReg, Int) -> Word32)
-> Word32 -> [(GlobalReg, Int)] -> Word32)
-> (Word32 -> (GlobalReg, Int) -> Word32)
-> Word32
-> [(GlobalReg, Int)]
-> 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
text String
"continuation offset too large:" SDoc -> SDoc -> SDoc
<+> Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word32
cont_offset)
Bool
-> SDoc
-> ((Word32 -> (GlobalReg, Int) -> Word32)
-> Word32 -> [(GlobalReg, Int)] -> Word32)
-> (Word32 -> (GlobalReg, Int) -> Word32)
-> Word32
-> [(GlobalReg, Int)]
-> 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]
regs) (GlobalRegSet -> [GlobalReg]
forall r. RegSet r -> [r]
regSetToList GlobalRegSet
nativeCallRegs)) (String -> SDoc
text String
"not all registers accounted for")
(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] -> [(GlobalReg, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [GlobalReg]
regs [Int
0..]) 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
regs :: [GlobalReg]
regs = Platform -> [GlobalReg]
allArgRegsCover Platform
platform
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
mkLitI :: Int -> [Word]
mkLitF :: Platform -> Float -> [Word]
mkLitD :: Platform -> Double -> [Word]
mkLitI64 :: Platform -> Int64 -> [Word]
mkLitW64 :: Platform -> Word64 -> [Word]
mkLitF :: Platform -> Float -> [Word]
mkLitF Platform
platform Float
f = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s [Word]) -> [Word])
-> (forall s. ST s [Word]) -> [Word]
forall a b. (a -> b) -> a -> b
$ do
STUArray s Int Float
arr <- (Int, Int) -> ST s (STUArray s Int Float)
forall i. Ix i => (i, i) -> ST s (STUArray s i Float)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
0)
STUArray s Int Float -> Int -> Float -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Float
arr Int
0 Float
f
STUArray s Int Word
f_arr <- STUArray s Int Float -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Float
arr
Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
f_arr Int
0
[Word] -> ST s [Word]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word]
PlatformWordSize
PW8 -> (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s [Word]) -> [Word])
-> (forall s. ST s [Word]) -> [Word]
forall a b. (a -> b) -> a -> b
$ do
STUArray s Int Float
arr <- (Int, Int) -> ST s (STUArray s Int Float)
forall i. Ix i => (i, i) -> ST s (STUArray s i Float)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
STUArray s Int Float -> Int -> Float -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Float
arr Int
0 Float
f
STUArray s Int Float -> Int -> Float -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Float
arr Int
1 Float
0.0
STUArray s Int Word
f_arr <- STUArray s Int Float -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Float
arr
Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
f_arr Int
0
[Word] -> ST s [Word]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word]
mkLitD :: Platform -> Double -> [Word]
mkLitD Platform
platform Double
d = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST (do
STUArray s Int Double
arr <- (Int, Int) -> ST s (STUArray s Int Double)
forall i. Ix i => (i, i) -> ST s (STUArray s i Double)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
STUArray s Int Double -> Int -> Double -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Double
arr Int
0 Double
d
STUArray s Int Word
d_arr <- STUArray s Int Double -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Double
arr
Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
0
Word
w1 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
1
[Word] -> ST s [Word]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word, Word
w1]
)
PlatformWordSize
PW8 -> (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST (do
STUArray s Int Double
arr <- (Int, Int) -> ST s (STUArray s Int Double)
forall i. Ix i => (i, i) -> ST s (STUArray s i Double)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
0)
STUArray s Int Double -> Int -> Double -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Double
arr Int
0 Double
d
STUArray s Int Word
d_arr <- STUArray s Int Double -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Double
arr
Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
0
[Word] -> ST s [Word]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word]
)
mkLitI64 :: Platform -> Int64 -> [Word]
mkLitI64 Platform
platform Int64
ii = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST (do
STUArray s Int Int64
arr <- (Int, Int) -> ST s (STUArray s Int Int64)
forall i. Ix i => (i, i) -> ST s (STUArray s i Int64)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
STUArray s Int Int64 -> Int -> Int64 -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int64
arr Int
0 Int64
ii
STUArray s Int Word
d_arr <- STUArray s Int Int64 -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Int64
arr
Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
0
Word
w1 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
1
[Word] -> ST s [Word]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word,Word
w1]
)
PlatformWordSize
PW8 -> [Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
ii :: Word]
mkLitW64 :: Platform -> Word64 -> [Word]
mkLitW64 Platform
platform Word64
ww = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST (do
STUArray s Word Word64
arr <- (Word, Word) -> ST s (STUArray s Word Word64)
forall i. Ix i => (i, i) -> ST s (STUArray s i Word64)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Word
0::Word),Word
1)
STUArray s Word Word64 -> Word -> Word64 -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Word Word64
arr Word
0 Word64
ww
STUArray s Word Word
d_arr <- STUArray s Word Word64 -> ST s (STUArray s Word Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Word Word64
arr
Word
w0 <- STUArray s Word Word -> Word -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Word Word
d_arr Word
0
Word
w1 <- STUArray s Word Word -> Word -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Word Word
d_arr Word
1
[Word] -> ST s [Word]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word,Word
w1]
)
PlatformWordSize
PW8 -> [Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ww :: Word]
mkLitI :: Int -> [Word]
mkLitI Int
i = [Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Word]
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH