{-# 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,
mkTupleInfoLit
) where
#include "HsVersions.h"
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.Utils.Misc
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 ( tupleRegsCover )
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 forall a. UniqDSet a -> UniqSet a -> UniqDSet a
`uniqDSetMinusUniqSet` [Name] -> NameSet
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)
= forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets (
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet [ Name
n | BCOPtrName Name
n <- forall a. SizedSeq a -> [a]
ssElts SizedSeq BCOPtr
ptrs ] forall a. a -> [a] -> [a]
:
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet [ Name
n | BCONPtrItbl Name
n <- forall a. SizedSeq a -> [a]
ssElts SizedSeq BCONPtr
nonptrs ] forall a. a -> [a] -> [a]
:
forall a b. (a -> b) -> [a] -> [b]
map UnlinkedBCO -> UniqDSet Name
bco_refs [ UnlinkedBCO
bco | BCOPtrBCO UnlinkedBCO
bco <- forall a. SizedSeq a -> [a]
ssElts SizedSeq BCOPtr
ptrs ]
)
assembleBCOs
:: Interp
-> Profile
-> [ProtoBCO Name]
-> [TyCon]
-> [RemotePtr ()]
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs :: Interp
-> Profile
-> [ProtoBCO Name]
-> [TyCon]
-> [RemotePtr ()]
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs Interp
interp Profile
profile [ProtoBCO Name]
proto_bcos [TyCon]
tycons [RemotePtr ()]
top_strs Maybe ModBreaks
modbreaks = do
ItblEnv
itblenv <- Interp -> Profile -> [TyCon] -> IO ItblEnv
mkITbls Interp
interp Profile
profile [TyCon]
tycons
[UnlinkedBCO]
bcos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (Profile -> Platform
profilePlatform Profile
profile)) [ProtoBCO Name]
proto_bcos
([UnlinkedBCO]
bcos',[RemotePtr ()]
ptrs) <- Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
mallocStrings Interp
interp [UnlinkedBCO]
bcos
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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ProtoBCO a -> [FFIInfo]
protoBCOFFIs [ProtoBCO Name]
proto_bcos
, bc_strs :: [RemotePtr ()]
bc_strs = [RemotePtr ()]
top_strs forall a. [a] -> [a] -> [a]
++ [RemotePtr ()]
ptrs
, bc_breaks :: Maybe ModBreaks
bc_breaks = Maybe ModBreaks
modbreaks
}
mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
mallocStrings Interp
interp [UnlinkedBCO]
ulbcos = do
let bytestrings :: [ByteString]
bytestrings = forall a. [a] -> [a]
reverse (forall s a. State s a -> s -> s
execState (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}.
Monad m =>
UnlinkedBCO -> StateT [ByteString] m ()
collect [UnlinkedBCO]
ulbcos) [])
[RemotePtr ()]
ptrs <- forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp ([ByteString] -> Message [RemotePtr ()]
MallocStrings [ByteString]
bytestrings)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. State s a -> s -> a
evalState (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {a}.
Monad m =>
UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
splice [UnlinkedBCO]
ulbcos) [RemotePtr ()]
ptrs, [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
unlinkedBCOPtrs :: UnlinkedBCO -> SizedSeq BCOPtr
unlinkedBCOLits :: UnlinkedBCO -> SizedSeq BCONPtr
unlinkedBCOInstrs :: UnlinkedBCO -> UArray Int Word16
unlinkedBCOBitmap :: UnlinkedBCO -> UArray Int Word64
unlinkedBCOArity :: UnlinkedBCO -> Int
unlinkedBCOPtrs :: SizedSeq BCOPtr
unlinkedBCOLits :: SizedSeq BCONPtr
unlinkedBCOBitmap :: UArray Int Word64
unlinkedBCOInstrs :: UArray Int Word16
unlinkedBCOArity :: Int
unlinkedBCOName :: Name
unlinkedBCOName :: UnlinkedBCO -> Name
..} = do
SizedSeq BCONPtr
lits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {a}.
Monad m =>
BCONPtr -> StateT [RemotePtr a] m BCONPtr
spliceLit SizedSeq BCONPtr
unlinkedBCOLits
SizedSeq BCOPtr
ptrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BCOPtr -> StateT [RemotePtr a] m BCOPtr
splicePtr SizedSeq BCOPtr
unlinkedBCOPtrs
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 <- forall (m :: * -> *) s. Monad m => StateT s m s
get
case [RemotePtr a]
rptrs of
(RemotePtr Word64
p : [RemotePtr a]
rest) -> do
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [RemotePtr a]
rest
forall (m :: * -> *) a. Monad m => a -> m a
return (Word -> BCONPtr
BCONPtrWord (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p))
[RemotePtr a]
_ -> forall a. String -> a
panic String
"mallocStrings:spliceLit"
spliceLit BCONPtr
other = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
splice UnlinkedBCO
bco
splicePtr BCOPtr
other = 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
unlinkedBCOPtrs :: SizedSeq BCOPtr
unlinkedBCOLits :: SizedSeq BCONPtr
unlinkedBCOBitmap :: UArray Int Word64
unlinkedBCOInstrs :: UArray Int Word16
unlinkedBCOArity :: Int
unlinkedBCOName :: Name
unlinkedBCOPtrs :: UnlinkedBCO -> SizedSeq BCOPtr
unlinkedBCOLits :: UnlinkedBCO -> SizedSeq BCONPtr
unlinkedBCOInstrs :: UnlinkedBCO -> UArray Int Word16
unlinkedBCOBitmap :: UnlinkedBCO -> UArray Int Word64
unlinkedBCOArity :: UnlinkedBCO -> Int
unlinkedBCOName :: UnlinkedBCO -> Name
..} = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}.
Monad m =>
BCONPtr -> StateT [ByteString] m ()
collectLit SizedSeq BCONPtr
unlinkedBCOLits
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 <- forall (m :: * -> *) s. Monad m => StateT s m s
get
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ByteString
bsforall a. a -> [a] -> [a]
:[ByteString]
strs)
collectLit BCONPtr
_ = 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
_ = 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'], [RemotePtr ()]
_ptrs) <- Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
mallocStrings Interp
interp [UnlinkedBCO
ubco]
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 = 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) = 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Int
Map.size LabelEnvMap
lbl_map0)
Bool -> Bool -> Bool
|| Word -> Bool
isLarge Word
n_insns0
= (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 = forall a. a -> Maybe a -> a
fromMaybe
(forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"assembleBCO.findLabel" (forall a. Outputable a => a -> SDoc
ppr LocalLabel
lbl))
(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 = (forall a. SizedSeq a
emptySS, forall a. SizedSeq a
emptySS, forall a. SizedSeq a
emptySS)
(SizedSeq Word16
final_insns, SizedSeq BCONPtr
final_lits, SizedSeq BCOPtr
final_ptrs) <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT forall {a} {a} {a}. (SizedSeq a, SizedSeq a, SizedSeq a)
initial_state forall a b. (a -> b) -> a -> b
$ 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
ASSERT(n_insns == sizeSS final_insns) return ()
let asm_insns :: [Word16]
asm_insns = forall a. SizedSeq a -> [a]
ssElts SizedSeq Word16
final_insns
insns_arr :: UArray Int Word16
insns_arr = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
Array.listArray (Int
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n_insns 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
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
= forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
Array.listArray (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgWord]
bitmap) forall a b. (a -> b) -> a -> b
$
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bsize forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => Integer -> a
fromInteger 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 -> 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
<$ :: forall a b. a -> Assembler b -> Assembler a
$c<$ :: forall a b. a -> Assembler b -> Assembler a
fmap :: forall a b. (a -> b) -> Assembler a -> Assembler b
$cfmap :: forall a b. (a -> b) -> Assembler a -> Assembler b
Functor)
instance Applicative Assembler where
pure :: forall a. a -> Assembler a
pure = forall a. a -> Assembler a
NullAsm
<*> :: forall a 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 = forall a. IO BCOPtr -> (Word -> Assembler a) -> Assembler a
AllocPtr IO BCOPtr
p (Word -> Assembler a
k 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 = forall a. [BCONPtr] -> (Word -> Assembler a) -> Assembler a
AllocLit [BCONPtr]
l (Word -> Assembler a
k 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 = forall a. LocalLabel -> Assembler a -> Assembler a
AllocLabel LocalLabel
lbl (Assembler a
k 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 = forall a. Word16 -> [Operand] -> Assembler a -> Assembler a
Emit Word16
w [Operand]
ops (Assembler a
k 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 = forall a. IO BCOPtr -> (Word -> Assembler a) -> Assembler a
AllocPtr IO BCOPtr
p forall (m :: * -> *) a. Monad m => a -> m a
return
ptr :: BCOPtr -> Assembler Word
ptr :: BCOPtr -> Assembler Word
ptr = IO BCOPtr -> Assembler Word
ioptr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
lit :: [BCONPtr] -> Assembler Word
lit :: [BCONPtr] -> Assembler Word
lit [BCONPtr]
l = forall a. [BCONPtr] -> (Word -> Assembler a) -> Assembler a
AllocLit [BCONPtr]
l forall (m :: * -> *) a. Monad m => a -> m a
return
label :: LocalLabel -> Assembler ()
label :: LocalLabel -> Assembler ()
label LocalLabel
w = forall a. LocalLabel -> Assembler a -> Assembler a
AllocLabel LocalLabel
w (forall (m :: * -> *) a. Monad m => a -> m a
return ())
emit :: Word16 -> [Operand] -> Assembler ()
emit :: Word16 -> [Operand] -> Assembler ()
emit Word16
w [Operand]
ops = forall a. Word16 -> [Operand] -> Assembler a -> Assembler a
Emit Word16
w [Operand]
ops (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) = forall (m :: * -> *) a. Monad m => a -> m a
return a
x
go (AllocPtr IO BCOPtr
p_io Word -> Assembler a
k) = do
BCOPtr
p <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO BCOPtr
p_io
Word
w <- forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state 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 = forall a. SizedSeq a -> a -> SizedSeq a
addToSS SizedSeq BCOPtr
st_p0 BCOPtr
p
in (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 forall a b. (a -> b) -> a -> b
$ Word -> Assembler a
k Word
w
go (AllocLit [BCONPtr]
lits Word -> Assembler a
k) = do
Word
w <- forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state 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 = forall a. SizedSeq a -> [a] -> SizedSeq a
addListToSS SizedSeq BCONPtr
st_l0 [BCONPtr]
lits
in (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 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 = 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 = 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 [forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state 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 = forall a. SizedSeq a -> [a] -> SizedSeq a
addListToSS SizedSeq Word16
st_i0 (Word16
opcode 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 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 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 forall a. Num a => a -> a -> a
+ 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 = 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 forall a. Num a => a -> a -> a
+ Word
size }
size :: Word
size = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map Operand -> Word
count [Operand]
ops) forall a. Num a => a -> a -> a
+ Word
1
largeOps :: Bool
largeOps = 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 "rts/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 -> [forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w forall a. Bits a => a -> Int -> a
`shiftR` Int
48),
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w forall a. Bits a => a -> Int -> a
`shiftR` Int
32),
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]
PlatformWordSize
PW4 -> [forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
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 (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 -> 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 (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_ALTS [Op p]
PUSH_ALTS_UNLIFTED 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 (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 TupleInfo
tuple_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 (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 (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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$
Platform -> TupleInfo -> Word32
mkTupleInfoSig Platform
platform TupleInfo
tuple_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]
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 (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_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 []
BCInstr
RETURN -> Word16 -> [Operand] -> Assembler ()
emit bci_RETURN []
RETURN_UNLIFTED ArgRep
rep -> Word16 -> [Operand] -> Assembler ()
emit (ArgRep -> Word16
return_unlifted 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 <- 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]
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 <- 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 forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
= FastString -> Assembler Word
litlabel (FastString -> FastString -> FastString
appendFS FastString
fs (String -> FastString
mkFastString (Char
'@'forall a. a -> [a] -> [a]
: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 (forall a. Fractional a => Rational -> a
fromRational Rational
r)
literal (LitDouble Rational
r) = Double -> Assembler Word
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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord -> Int -> Assembler Word
int (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt8 -> Int64 -> Assembler Word
int8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord8 -> Int64 -> Assembler Word
int8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt16 -> Int64 -> Assembler Word
int16 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord16 -> Int64 -> Assembler Word
int16 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt32 -> Int64 -> Assembler Word
int32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord32 -> Int64 -> Assembler Word
int32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInt64 -> Int64 -> Assembler Word
int64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumWord64 -> Int64 -> Assembler Word
int64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
LitNumType
LitNumInteger -> forall a. String -> a
panic String
"GHC.ByteCode.Asm.literal: LitNumInteger"
LitNumType
LitNumNatural -> forall a. String -> a
panic String
"GHC.ByteCode.Asm.literal: LitNumNatural"
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 [forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a]
float :: Float -> Assembler Word
float = [Word] -> Assembler Word
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> [Word]
mkLitF
double :: Double -> Assembler Word
double = [Word] -> Assembler Word
words 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word]
mkLitI
int8 :: Int64 -> Assembler Word
int8 = [Word] -> Assembler Word
words 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 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
words :: [Word] -> Assembler Word
words [Word]
ws = [BCONPtr] -> Assembler Word
lit (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 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 = forall a. HasCallStack => String -> a
error String
"push_alts: vector"
push_alts ArgRep
V32 = forall a. HasCallStack => String -> a
error String
"push_alts: vector"
push_alts ArgRep
V64 = forall a. HasCallStack => String -> a
error String
"push_alts: vector"
return_unlifted :: ArgRep -> Word16
return_unlifted :: ArgRep -> Word16
return_unlifted ArgRep
V = bci_RETURN_V
return_unlifted ArgRep
P = bci_RETURN_P
return_unlifted ArgRep
N = bci_RETURN_N
return_unlifted ArgRep
L = bci_RETURN_L
return_unlifted ArgRep
F = bci_RETURN_F
return_unlifted ArgRep
D = bci_RETURN_D
return_unlifted ArgRep
V16 = forall a. HasCallStack => String -> a
error String
"return_unlifted: vector"
return_unlifted ArgRep
V32 = forall a. HasCallStack => String -> a
error String
"return_unlifted: vector"
return_unlifted ArgRep
V64 = forall a. HasCallStack => String -> a
error String
"return_unlifted: vector"
maxTupleNativeStackSize :: WordOff
maxTupleNativeStackSize :: WordOff
maxTupleNativeStackSize = WordOff
62
mkTupleInfoSig :: Platform -> TupleInfo -> Word32
mkTupleInfoSig :: Platform -> TupleInfo -> Word32
mkTupleInfoSig Platform
platform TupleInfo{GlobalRegSet
WordOff
tupleSize :: TupleInfo -> WordOff
tupleRegs :: TupleInfo -> GlobalRegSet
tupleNativeStackSize :: TupleInfo -> WordOff
tupleNativeStackSize :: WordOff
tupleRegs :: GlobalRegSet
tupleSize :: WordOff
..}
| WordOff
tupleNativeStackSize forall a. Ord a => a -> a -> Bool
> WordOff
maxTupleNativeStackSize
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTupleInfoSig: tuple too big for the bytecode compiler"
(forall a. Outputable a => a -> SDoc
ppr WordOff
tupleNativeStackSize 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
= ASSERT(length regs <= 24)
ASSERT(tupleNativeStackSize < 255)
ASSERT(all (`elem` regs) (regSetToList tupleRegs))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word32 -> (GlobalReg, Int) -> Word32
reg_bit Word32
0 (forall a b. [a] -> [b] -> [(a, b)]
zip [GlobalReg]
regs [Int
0..]) forall a. Bits a => a -> a -> a
.|.
(forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
tupleNativeStackSize forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
where
reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
reg_bit Word32
x (GlobalReg
r, Int
n)
| GlobalReg
r forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` GlobalRegSet
tupleRegs = Word32
x forall a. Bits a => a -> a -> a
.|. Word32
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
n
| Bool
otherwise = Word32
x
regs :: [GlobalReg]
regs = Platform -> [GlobalReg]
tupleRegsCover Platform
platform
mkTupleInfoLit :: Platform -> TupleInfo -> Literal
mkTupleInfoLit :: Platform -> TupleInfo -> Literal
mkTupleInfoLit Platform
platform TupleInfo
tuple_info =
Platform -> Integer -> Literal
mkLitWord Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Platform -> TupleInfo -> Word32
mkTupleInfoSig Platform
platform TupleInfo
tuple_info
mkLitI :: Int -> [Word]
mkLitF :: Float -> [Word]
mkLitD :: Platform -> Double -> [Word]
mkLitI64 :: Platform -> Int64 -> [Word]
mkLitF :: Float -> [Word]
mkLitF Float
f
= forall a. (forall s. ST s a) -> a
runST (do
STUArray s Int Float
arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
0)
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 <- forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Float
arr
Word
w0 <- 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
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 a. (forall s. ST s a) -> a
runST (do
STUArray s Int Double
arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
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 <- forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Double
arr
Word
w0 <- 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 <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word, Word
w1]
)
PlatformWordSize
PW8 -> forall a. (forall s. ST s a) -> a
runST (do
STUArray s Int Double
arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
0)
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 <- forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Double
arr
Word
w0 <- 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
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 a. (forall s. ST s a) -> a
runST (do
STUArray s Int Int64
arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
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 <- forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Int64
arr
Word
w0 <- 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 <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word,Word
w1]
)
PlatformWordSize
PW8 -> forall a. (forall s. ST s a) -> a
runST (do
STUArray s Int Int64
arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
0)
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 <- forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Int64
arr
Word
w0 <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word]
)
mkLitI :: Int -> [Word]
mkLitI Int
i = [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