{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.ByteCode.Instr
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
import GHC.Cmm.CallConv
import GHC.Cmm.Expr
import GHC.Cmm.Node
import GHC.Cmm.Utils
import GHC.Platform
import GHC.Platform.Profile
import GHC.Runtime.Interpreter
import GHCi.FFI
import GHCi.RemoteTypes
import GHC.Types.Basic
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.ForeignCall
import GHC.Core
import GHC.Types.Literal
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Types.Var.Set
import GHC.Builtin.Types.Prim
import GHC.Core.TyCo.Ppr ( pprType )
import GHC.Utils.Error
import GHC.Types.Unique
import GHC.Builtin.Uniques
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Exception (evaluate)
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds, argPrimRep )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
import Data.List ( genericReplicate, genericLength, intersperse
, partition, scanl', sortBy, zip4, zip6 )
import Foreign hiding (shiftL, shiftR)
import Control.Monad
import Data.Char
import GHC.Unit.Module
import Data.Array
import Data.Coerce (coerce)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.IntMap (IntMap)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified GHC.Data.FiniteMap as Map
import Data.Ord
import GHC.Stack.CCS
import Data.Either ( partitionEithers )
import GHC.Stg.Syntax
import qualified Data.IntSet as IntSet
import GHC.CoreToIface
byteCodeGen :: HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen :: HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod [CgStgTopBinding]
binds [TyCon]
tycs Maybe ModBreaks
mb_modBreaks
= forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(String -> SDoc
text String
"GHC.StgToByteCode"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ do
let ([(Id, ByteString)]
strings, [GenStgBinding 'CodeGen]
lifted_binds) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ do
CgStgTopBinding
bnd <- [CgStgTopBinding]
binds
case CgStgTopBinding
bnd of
StgTopLifted GenStgBinding 'CodeGen
bnd -> [forall a b. b -> Either a b
Right GenStgBinding 'CodeGen
bnd]
StgTopStringLit Id
b ByteString
str -> [forall a b. a -> Either a b
Left (Id
b, ByteString
str)]
flattenBind :: GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
flattenBind (StgNonRec BinderP pass
b GenStgRhs pass
e) = [(BinderP pass
b,GenStgRhs pass
e)]
flattenBind (StgRec [(BinderP pass, GenStgRhs pass)]
bs) = [(BinderP pass, GenStgRhs pass)]
bs
AddrEnv
stringPtrs <- Interp -> [(Id, ByteString)] -> IO AddrEnv
allocateTopStrings Interp
interp [(Id, ByteString)]
strings
(BcM_State{[FFIInfo]
Maybe ModBreaks
Word32
IntMap CgBreakInfo
HscEnv
Module
breakInfo :: BcM_State -> IntMap CgBreakInfo
modBreaks :: BcM_State -> Maybe ModBreaks
ffis :: BcM_State -> [FFIInfo]
nextlabel :: BcM_State -> Word32
thisModule :: BcM_State -> Module
bcm_hsc_env :: BcM_State -> HscEnv
breakInfo :: IntMap CgBreakInfo
modBreaks :: Maybe ModBreaks
ffis :: [FFIInfo]
nextlabel :: Word32
thisModule :: Module
bcm_hsc_env :: HscEnv
..}, [ProtoBCO Name]
proto_bcos) <-
forall r.
HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (BcM_State, r)
runBc HscEnv
hsc_env Module
this_mod Maybe ModBreaks
mb_modBreaks forall a b. (a -> b) -> a -> b
$ do
let flattened_binds :: [(Id, CgStgRhs)]
flattened_binds = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {pass :: StgPass}.
GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
flattenBind (forall a. [a] -> [a]
reverse [GenStgBinding 'CodeGen]
lifted_binds)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind [(Id, CgStgRhs)]
flattened_binds
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [FFIInfo]
ffis)
(forall a. String -> a
panic String
"GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_BCOs
String
"Proto-BCOs" DumpFormat
FormatByteCode
([SDoc] -> SDoc
vcat (forall a. a -> [a] -> [a]
intersperse (Char -> SDoc
char Char
' ') (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [ProtoBCO Name]
proto_bcos)))
CompiledByteCode
cbc <- Interp
-> Profile
-> [ProtoBCO Name]
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs Interp
interp Profile
profile [ProtoBCO Name]
proto_bcos [TyCon]
tycs AddrEnv
stringPtrs
(case Maybe ModBreaks
modBreaks of
Maybe ModBreaks
Nothing -> forall a. Maybe a
Nothing
Just ModBreaks
mb -> forall a. a -> Maybe a
Just ModBreaks
mb{ modBreaks_breakInfo :: IntMap CgBreakInfo
modBreaks_breakInfo = IntMap CgBreakInfo
breakInfo })
forall a. a -> IO a
evaluate (CompiledByteCode -> ()
seqCompiledByteCode CompiledByteCode
cbc)
forall (m :: * -> *) a. Monad m => a -> m a
return CompiledByteCode
cbc
where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
allocateTopStrings
:: Interp
-> [(Id, ByteString)]
-> IO AddrEnv
allocateTopStrings :: Interp -> [(Id, ByteString)] -> IO AddrEnv
allocateTopStrings Interp
interp [(Id, ByteString)]
topStrings = do
let !([Id]
bndrs, [ByteString]
strings) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, ByteString)]
topStrings
[RemotePtr ()]
ptrs <- forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp forall a b. (a -> b) -> a -> b
$ [ByteString] -> Message [RemotePtr ()]
MallocStrings [ByteString]
strings
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [(Name, a)] -> NameEnv a
mkNameEnv (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}.
NamedThing a =>
a -> RemotePtr () -> (Name, (Name, AddrPtr))
mk_entry [Id]
bndrs [RemotePtr ()]
ptrs)
where
mk_entry :: a -> RemotePtr () -> (Name, (Name, AddrPtr))
mk_entry a
bndr RemotePtr ()
ptr = let nm :: Name
nm = forall a. NamedThing a => a -> Name
getName a
bndr
in (Name
nm, (Name
nm, RemotePtr () -> AddrPtr
AddrPtr RemotePtr ()
ptr))
type BCInstrList = OrdList BCInstr
wordsToBytes :: Platform -> WordOff -> ByteOff
wordsToBytes :: Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Platform -> Int
platformWordSizeInBytes Platform
platform) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
bytesToWords :: Platform -> ByteOff -> WordOff
bytesToWords :: Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff Int
bytes) =
let (Int
q, Int
r) = Int
bytes forall a. Integral a => a -> a -> (a, a)
`quotRem` (Platform -> Int
platformWordSizeInBytes Platform
platform)
in if Int
r forall a. Eq a => a -> a -> Bool
== Int
0
then forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
q
else forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToByteCode.bytesToWords"
(String -> SDoc
text String
"bytes=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Int
bytes)
wordSize :: Platform -> ByteOff
wordSize :: Platform -> ByteOff
wordSize Platform
platform = Int -> ByteOff
ByteOff (Platform -> Int
platformWordSizeInBytes Platform
platform)
type Sequel = ByteOff
type StackDepth = ByteOff
type BCEnv = Map Id StackDepth
mkProtoBCO
:: Platform
-> name
-> BCInstrList
-> Either [CgStgAlt] (CgStgRhs)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO :: forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform name
nm OrdList BCInstr
instrs_ordlist Either [CgStgAlt] CgStgRhs
origin Int
arity Word16
bitmap_size [StgWord]
bitmap Bool
is_ret [FFIInfo]
ffis
= ProtoBCO {
protoBCOName :: name
protoBCOName = name
nm,
protoBCOInstrs :: [BCInstr]
protoBCOInstrs = [BCInstr]
maybe_with_stack_check,
protoBCOBitmap :: [StgWord]
protoBCOBitmap = [StgWord]
bitmap,
protoBCOBitmapSize :: Word16
protoBCOBitmapSize = Word16
bitmap_size,
protoBCOArity :: Int
protoBCOArity = Int
arity,
protoBCOExpr :: Either [CgStgAlt] CgStgRhs
protoBCOExpr = Either [CgStgAlt] CgStgRhs
origin,
protoBCOFFIs :: [FFIInfo]
protoBCOFFIs = [FFIInfo]
ffis
}
where
maybe_with_stack_check :: [BCInstr]
maybe_with_stack_check
| Bool
is_ret Bool -> Bool -> Bool
&& Word
stack_usage forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_AP_STACK_SPLIM (Platform -> PlatformConstants
platformConstants Platform
platform)) = [BCInstr]
peep_d
| Word
stack_usage forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
iNTERP_STACK_CHECK_THRESH
= Word -> BCInstr
STKCHECK Word
stack_usage forall a. a -> [a] -> [a]
: [BCInstr]
peep_d
| Bool
otherwise
= [BCInstr]
peep_d
stack_usage :: Word
stack_usage = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map BCInstr -> Word
bciStackUse [BCInstr]
peep_d)
peep_d :: [BCInstr]
peep_d = [BCInstr] -> [BCInstr]
peep (forall a. OrdList a -> [a]
fromOL OrdList BCInstr
instrs_ordlist)
peep :: [BCInstr] -> [BCInstr]
peep (PUSH_L Word16
off1 : PUSH_L Word16
off2 : PUSH_L Word16
off3 : [BCInstr]
rest)
= Word16 -> Word16 -> Word16 -> BCInstr
PUSH_LLL Word16
off1 (Word16
off2forall a. Num a => a -> a -> a
-Word16
1) (Word16
off3forall a. Num a => a -> a -> a
-Word16
2) forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
peep (PUSH_L Word16
off1 : PUSH_L Word16
off2 : [BCInstr]
rest)
= Word16 -> Word16 -> BCInstr
PUSH_LL Word16
off1 (Word16
off2forall a. Num a => a -> a -> a
-Word16
1) forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
peep (BCInstr
i:[BCInstr]
rest)
= BCInstr
i forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
peep []
= []
argBits :: Platform -> [ArgRep] -> [Bool]
argBits :: Platform -> [ArgRep] -> [Bool]
argBits Platform
_ [] = []
argBits Platform
platform (ArgRep
rep : [ArgRep]
args)
| ArgRep -> Bool
isFollowableArg ArgRep
rep = Bool
False forall a. a -> [a] -> [a]
: Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
| Bool
otherwise = forall a. Int -> [a] -> [a]
take (Platform -> ArgRep -> Int
argRepSizeW Platform
platform ArgRep
rep) (forall a. a -> [a]
repeat Bool
True) forall a. [a] -> [a] -> [a]
++ Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
non_void :: [ArgRep] -> [ArgRep]
non_void :: [ArgRep] -> [ArgRep]
non_void = forall a. (a -> Bool) -> [a] -> [a]
filter ArgRep -> Bool
nv
where nv :: ArgRep -> Bool
nv ArgRep
V = Bool
False
nv ArgRep
_ = Bool
True
schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind (Id
id, CgStgRhs
rhs)
| Just DataCon
data_con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
id,
DataCon -> Bool
isNullaryRepDataCon DataCon
data_con = do
Platform
platform <- Profile -> Platform
profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform (forall a. NamedThing a => a -> Name
getName Id
id) (forall a. [a] -> OrdList a
toOL [DataCon -> Word16 -> BCInstr
PACK DataCon
data_con Word16
0, ArgRep -> BCInstr
RETURN ArgRep
P])
(forall a b. b -> Either a b
Right CgStgRhs
rhs) Int
0 Word16
0 [] Bool
False)
| Bool
otherwise
= [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [] (forall a. NamedThing a => a -> Name
getName Id
id, CgStgRhs
rhs)
schemeR :: [Id]
-> (Name, CgStgRhs)
-> BcM (ProtoBCO Name)
schemeR :: [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [Id]
fvs (Name
nm, CgStgRhs
rhs)
= [Id]
-> Name -> CgStgRhs -> ([Id], CgStgExpr) -> BcM (ProtoBCO Name)
schemeR_wrk [Id]
fvs Name
nm CgStgRhs
rhs (CgStgRhs -> ([Id], CgStgExpr)
collect CgStgRhs
rhs)
collect :: CgStgRhs -> ([Var], CgStgExpr)
collect :: CgStgRhs -> ([Id], CgStgExpr)
collect (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
args CgStgExpr
body) = ([BinderP 'CodeGen]
args, CgStgExpr
body)
collect (StgRhsCon CostCentreStack
_cc DataCon
dc ConstructorNumber
cnum [StgTickish]
_ticks [StgArg]
args) = ([], forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Kind] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
cnum [StgArg]
args [])
schemeR_wrk
:: [Id]
-> Name
-> CgStgRhs
-> ([Var], CgStgExpr)
-> BcM (ProtoBCO Name)
schemeR_wrk :: [Id]
-> Name -> CgStgRhs -> ([Id], CgStgExpr) -> BcM (ProtoBCO Name)
schemeR_wrk [Id]
fvs Name
nm CgStgRhs
original_body ([Id]
args, CgStgExpr
body)
= do
Profile
profile <- BcM Profile
getProfile
let
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
all_args :: [Id]
all_args = forall a. [a] -> [a]
reverse [Id]
args forall a. [a] -> [a] -> [a]
++ [Id]
fvs
arity :: Int
arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
all_args
szsb_args :: [ByteOff]
szsb_args = forall a b. (a -> b) -> [a] -> [b]
map (Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> WordOff
idSizeW Platform
platform) [Id]
all_args
sum_szsb_args :: ByteOff
sum_szsb_args = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ByteOff]
szsb_args
p_init :: Map Id ByteOff
p_init = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
all_args (ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
0 [ByteOff]
szsb_args))
bits :: [Bool]
bits = Platform -> [ArgRep] -> [Bool]
argBits Platform
platform (forall a. [a] -> [a]
reverse (forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Id -> ArgRep
bcIdArgRep Platform
platform) [Id]
all_args))
bitmap_size :: Word16
bitmap_size = forall i a. Num i => [a] -> i
genericLength [Bool]
bits
bitmap :: [StgWord]
bitmap = Platform -> [Bool] -> [StgWord]
mkBitmap Platform
platform [Bool]
bits
OrdList BCInstr
body_code <- ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeER_wrk ByteOff
sum_szsb_args Map Id ByteOff
p_init CgStgExpr
body
([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
nm OrdList BCInstr
body_code (forall a b. b -> Either a b
Right CgStgRhs
original_body)
Int
arity Word16
bitmap_size [StgWord]
bitmap Bool
False)
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeER_wrk :: ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeER_wrk ByteOff
d Map Id ByteOff
p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
tick_ty Int
tick_no [XTickishId 'TickishPassStg]
fvs) CgStgExpr
rhs)
= do OrdList BCInstr
code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p CgStgExpr
rhs
Array Int (RemotePtr CostCentre)
cc_arr <- BcM (Array Int (RemotePtr CostCentre))
getCCArray
ModuleName
this_mod <- forall unit. GenModule unit -> ModuleName
moduleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Module
getCurrentModule
Platform
platform <- Profile -> Platform
profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
let idOffSets :: [Maybe (Id, Word16)]
idOffSets = Platform
-> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets Platform
platform ByteOff
d Map Id ByteOff
p [XTickishId 'TickishPassStg]
fvs
ty_vars :: [Id]
ty_vars = [Kind] -> [Id]
tyCoVarsOfTypesWellScoped (XBreakpoint 'TickishPassStg
tick_tyforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [XTickishId 'TickishPassStg]
fvs)
let breakInfo :: CgBreakInfo
breakInfo = [Id] -> [Maybe (Id, Word16)] -> Kind -> CgBreakInfo
dehydrateCgBreakInfo [Id]
ty_vars [Maybe (Id, Word16)]
idOffSets XBreakpoint 'TickishPassStg
tick_ty
Int -> CgBreakInfo -> BcM ()
newBreakInfo Int
tick_no CgBreakInfo
breakInfo
HscEnv
hsc_env <- BcM HscEnv
getHscEnv
let cc :: RemotePtr CostCentre
cc | Just Interp
interp <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
, Interp -> Bool
interpreterProfiled Interp
interp
= Array Int (RemotePtr CostCentre)
cc_arr forall i e. Ix i => Array i e -> i -> e
! Int
tick_no
| Bool
otherwise = forall a. Ptr a -> RemotePtr a
toRemotePtr forall a. Ptr a
nullPtr
let breakInstr :: BCInstr
breakInstr = Word16 -> Unique -> RemotePtr CostCentre -> BCInstr
BRK_FUN (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tick_no) (forall a. Uniquable a => a -> Unique
getUnique ModuleName
this_mod) RemotePtr CostCentre
cc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BCInstr
breakInstr forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
code
schemeER_wrk ByteOff
d Map Id ByteOff
p CgStgExpr
rhs = ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p CgStgExpr
rhs
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets :: Platform
-> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets Platform
platform ByteOff
depth Map Id ByteOff
env = forall a b. (a -> b) -> [a] -> [b]
map Id -> Maybe (Id, Word16)
getOffSet
where
getOffSet :: Id -> Maybe (Id, Word16)
getOffSet Id
id = case Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
id Map Id ByteOff
env of
Maybe ByteOff
Nothing -> forall a. Maybe a
Nothing
Just ByteOff
offset ->
let !var_depth_ws :: Word16
var_depth_ws =
WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
depth forall a. Num a => a -> a -> a
- ByteOff
offset) forall a. Num a => a -> a -> a
+ WordOff
2
in forall a. a -> Maybe a
Just (Id
id, Word16
var_depth_ws)
truncIntegral16 :: Integral a => a -> Word16
truncIntegral16 :: forall a. Integral a => a -> Word16
truncIntegral16 a
w
| a
w forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word16)
= forall a. String -> a
panic String
"stack depth overflow"
| Bool
otherwise
= forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w
trunc16B :: ByteOff -> Word16
trunc16B :: ByteOff -> Word16
trunc16B = forall a. Integral a => a -> Word16
truncIntegral16
trunc16W :: WordOff -> Word16
trunc16W :: WordOff -> Word16
trunc16W = forall a. Integral a => a -> Word16
truncIntegral16
fvsToEnv :: BCEnv -> CgStgRhs -> [Id]
fvsToEnv :: Map Id ByteOff -> CgStgRhs -> [Id]
fvsToEnv Map Id ByteOff
p CgStgRhs
rhs = [Id
v | Id
v <- DIdSet -> [Id]
dVarSetElems forall a b. (a -> b) -> a -> b
$ forall (pass :: StgPass).
(XRhsClosure pass ~ DIdSet) =>
GenStgRhs pass -> DIdSet
freeVarsOfRhs CgStgRhs
rhs,
Id
v forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Id ByteOff
p]
returnUnliftedAtom
:: StackDepth
-> Sequel
-> BCEnv
-> StgArg
-> BcM BCInstrList
returnUnliftedAtom :: ByteOff
-> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
returnUnliftedAtom ByteOff
d ByteOff
s Map Id ByteOff
p StgArg
e = do
let reps :: [PrimRep]
reps = case StgArg
e of
StgLitArg Literal
lit -> HasDebugCallStack => Kind -> [PrimRep]
typePrimRepArgs (Literal -> Kind
literalType Literal
lit)
StgVarArg Id
i -> Id -> [PrimRep]
bcIdPrimReps Id
i
(OrdList BCInstr
push, ByteOff
szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
e
OrdList BCInstr
ret <- ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
returnUnliftedReps ByteOff
d ByteOff
s ByteOff
szb [PrimRep]
reps
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
ret)
returnUnliftedReps
:: StackDepth
-> Sequel
-> ByteOff
-> [PrimRep]
-> BcM BCInstrList
returnUnliftedReps :: ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
returnUnliftedReps ByteOff
d ByteOff
s ByteOff
szb [PrimRep]
reps = do
Profile
profile <- BcM Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
non_void :: PrimRep -> Bool
non_void PrimRep
VoidRep = Bool
False
non_void PrimRep
_ = Bool
True
OrdList BCInstr
ret <- case forall a. (a -> Bool) -> [a] -> [a]
filter PrimRep -> Bool
non_void [PrimRep]
reps of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ ArgRep -> BCInstr
RETURN ArgRep
V)
[PrimRep
rep] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ ArgRep -> BCInstr
RETURN (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep))
[PrimRep]
nv_reps -> do
let (NativeCallInfo
call_info, [(PrimRep, ByteOff)]
args_offsets) = forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile NativeCallType
NativeTupleReturn ByteOff
0 (Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform) [PrimRep]
nv_reps
ProtoBCO Name
tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> [FFIInfo]
-> ProtoBCO Name
tupleBCO Platform
platform NativeCallInfo
call_info [(PrimRep, ByteOff)]
args_offsets)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Literal -> Word16 -> BCInstr
PUSH_UBX (Platform -> NativeCallInfo -> Literal
mkNativeCallInfoLit Platform
platform NativeCallInfo
call_info) Word16
1 forall a. a -> OrdList a -> OrdList a
`consOL`
ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
tuple_bco forall a. a -> OrdList a -> OrdList a
`consOL`
forall a. a -> OrdList a
unitOL BCInstr
RETURN_TUPLE
forall (m :: * -> *) a. Monad m => a -> m a
return ( Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB Platform
platform ByteOff
szb (ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
s)
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
ret)
returnUnboxedTuple
:: StackDepth
-> Sequel
-> BCEnv
-> [StgArg]
-> BcM BCInstrList
returnUnboxedTuple :: ByteOff
-> ByteOff -> Map Id ByteOff -> [StgArg] -> BcM (OrdList BCInstr)
returnUnboxedTuple ByteOff
d ByteOff
s Map Id ByteOff
p [StgArg]
es = do
Profile
profile <- BcM Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
arg_ty :: StgArg -> CmmType
arg_ty StgArg
e = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform (StgArg -> PrimRep
atomPrimRep StgArg
e)
(NativeCallInfo
call_info, [(StgArg, ByteOff)]
tuple_components) = forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile
NativeCallType
NativeTupleReturn
ByteOff
d
StgArg -> CmmType
arg_ty
[StgArg]
es
go :: ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go ByteOff
_ [OrdList BCInstr]
pushes [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [OrdList BCInstr]
pushes)
go !ByteOff
dd [OrdList BCInstr]
pushes ((StgArg
a, ByteOff
off):[(StgArg, ByteOff)]
cs) = do (OrdList BCInstr
push, ByteOff
szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p StgArg
a
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (ByteOff
off forall a. Eq a => a -> a -> Bool
== ByteOff
dd forall a. Num a => a -> a -> a
+ ByteOff
szb)
ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go (ByteOff
dd forall a. Num a => a -> a -> a
+ ByteOff
szb) (OrdList BCInstr
pushforall a. a -> [a] -> [a]
:[OrdList BCInstr]
pushes) [(StgArg, ByteOff)]
cs
[OrdList BCInstr]
pushes <- ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go ByteOff
d [] [(StgArg, ByteOff)]
tuple_components
OrdList BCInstr
ret <- ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
returnUnliftedReps ByteOff
d
ByteOff
s
(Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform forall a b. (a -> b) -> a -> b
$ NativeCallInfo -> WordOff
nativeCallSize NativeCallInfo
call_info)
(forall a b. (a -> b) -> [a] -> [b]
map StgArg -> PrimRep
atomPrimRep [StgArg]
es)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => [a] -> a
mconcat [OrdList BCInstr]
pushes forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
ret)
schemeE
:: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeE :: ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLit Literal
lit) = ByteOff
-> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
returnUnliftedAtom ByteOff
d ByteOff
s Map Id ByteOff
p (Literal -> StgArg
StgLitArg Literal
lit)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgApp Id
x [])
| HasDebugCallStack => Kind -> Bool
isUnliftedType (Id -> Kind
idType Id
x) = ByteOff
-> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
returnUnliftedAtom ByteOff
d ByteOff
s Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
x)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: CgStgExpr
e@(StgApp {}) = ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p CgStgExpr
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: CgStgExpr
e@(StgConApp {}) = ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p CgStgExpr
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: CgStgExpr
e@(StgOpApp {}) = ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p CgStgExpr
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLetNoEscape XLetNoEscape 'CodeGen
xlet GenStgBinding 'CodeGen
bnd CgStgExpr
body)
= ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLetNoEscape 'CodeGen
xlet GenStgBinding 'CodeGen
bnd CgStgExpr
body)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLet XLet 'CodeGen
_xlet
(StgNonRec BinderP 'CodeGen
x (StgRhsCon CostCentreStack
_cc DataCon
data_con ConstructorNumber
_cnum [StgTickish]
_ticks [StgArg]
args))
CgStgExpr
body)
= do
OrdList BCInstr
alloc_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM (OrdList BCInstr)
mkConAppCode ByteOff
d ByteOff
s Map Id ByteOff
p DataCon
data_con [StgArg]
args
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let !d2 :: ByteOff
d2 = ByteOff
d forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform
OrdList BCInstr
body_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d2 ByteOff
s (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BinderP 'CodeGen
x ByteOff
d2 Map Id ByteOff
p) CgStgExpr
body
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
alloc_code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
body_code)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLet XLet 'CodeGen
_ext GenStgBinding 'CodeGen
binds CgStgExpr
body) = do
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let ([Id]
xs,[CgStgRhs]
rhss) = case GenStgBinding 'CodeGen
binds of StgNonRec BinderP 'CodeGen
x CgStgRhs
rhs -> ([BinderP 'CodeGen
x],[CgStgRhs
rhs])
StgRec [(BinderP 'CodeGen, CgStgRhs)]
xs_n_rhss -> forall a b. [(a, b)] -> ([a], [b])
unzip [(BinderP 'CodeGen, CgStgRhs)]
xs_n_rhss
n_binds :: WordOff
n_binds = forall i a. Num i => [a] -> i
genericLength [Id]
xs
fvss :: [[Id]]
fvss = forall a b. (a -> b) -> [a] -> [b]
map (Map Id ByteOff -> CgStgRhs -> [Id]
fvsToEnv Map Id ByteOff
p') [CgStgRhs]
rhss
size_w :: Id -> Word16
size_w = WordOff -> Word16
trunc16W forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> WordOff
idSizeW Platform
platform
sizes :: [Word16]
sizes = forall a b. (a -> b) -> [a] -> [b]
map (\[Id]
rhs_fvs -> forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map Id -> Word16
size_w [Id]
rhs_fvs)) [[Id]]
fvss
arities :: [Word16]
arities = forall a b. (a -> b) -> [a] -> [b]
map (forall i a. Num i => [a] -> i
genericLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. CgStgRhs -> ([Id], CgStgExpr)
collect) [CgStgRhs]
rhss
offsets :: [ByteOff]
offsets = ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
d (forall i a. Integral i => i -> a -> [a]
genericReplicate WordOff
n_binds (Platform -> ByteOff
wordSize Platform
platform))
p' :: Map Id ByteOff
p' = forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList (forall a b. [a] -> [b] -> [(a, b)]
zipE [Id]
xs [ByteOff]
offsets) Map Id ByteOff
p
d' :: ByteOff
d' = ByteOff
d forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
n_binds
zipE :: [a] -> [b] -> [(a, b)]
zipE = forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"schemeE"
build_thunk
:: StackDepth
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
build_thunk :: ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
build_thunk ByteOff
_ [] Word16
size ProtoBCO Name
bco Word16
off Word16
arity
= forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
bco forall a. a -> OrdList a -> OrdList a
`consOL` forall a. a -> OrdList a
unitOL (Word16 -> Word16 -> BCInstr
mkap (Word16
offforall a. Num a => a -> a -> a
+Word16
size) Word16
size))
where
mkap :: Word16 -> Word16 -> BCInstr
mkap | Word16
arity forall a. Eq a => a -> a -> Bool
== Word16
0 = Word16 -> Word16 -> BCInstr
MKAP
| Bool
otherwise = Word16 -> Word16 -> BCInstr
MKPAP
build_thunk ByteOff
dd (Id
fv:[Id]
fvs) Word16
size ProtoBCO Name
bco Word16
off Word16
arity = do
(OrdList BCInstr
push_code, ByteOff
pushed_szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p' (Id -> StgArg
StgVarArg Id
fv)
OrdList BCInstr
more_push_code <-
ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
build_thunk (ByteOff
dd forall a. Num a => a -> a -> a
+ ByteOff
pushed_szb) [Id]
fvs Word16
size ProtoBCO Name
bco Word16
off Word16
arity
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push_code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
more_push_code)
alloc_code :: OrdList BCInstr
alloc_code = forall a. [a] -> OrdList a
toOL (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word16 -> Word16 -> BCInstr
mkAlloc [Word16]
sizes [Word16]
arities)
where mkAlloc :: Word16 -> Word16 -> BCInstr
mkAlloc Word16
sz Word16
0
| Bool
is_tick = Word16 -> BCInstr
ALLOC_AP_NOUPD Word16
sz
| Bool
otherwise = Word16 -> BCInstr
ALLOC_AP Word16
sz
mkAlloc Word16
sz Word16
arity = Word16 -> Word16 -> BCInstr
ALLOC_PAP Word16
arity Word16
sz
is_tick :: Bool
is_tick = case GenStgBinding 'CodeGen
binds of
StgNonRec BinderP 'CodeGen
id CgStgRhs
_ -> OccName -> FastString
occNameFS (forall a. NamedThing a => a -> OccName
getOccName BinderP 'CodeGen
id) forall a. Eq a => a -> a -> Bool
== FastString
tickFS
GenStgBinding 'CodeGen
_other -> Bool
False
compile_bind :: ByteOff
-> [Id]
-> a
-> CgStgRhs
-> Word16
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
compile_bind ByteOff
d' [Id]
fvs a
x (CgStgRhs
rhs::CgStgRhs) Word16
size Word16
arity Word16
off = do
ProtoBCO Name
bco <- [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [Id]
fvs (forall a. NamedThing a => a -> Name
getName a
x,CgStgRhs
rhs)
ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
build_thunk ByteOff
d' [Id]
fvs Word16
size ProtoBCO Name
bco Word16
off Word16
arity
compile_binds :: [BcM (OrdList BCInstr)]
compile_binds =
[ forall {a}.
NamedThing a =>
ByteOff
-> [Id]
-> a
-> CgStgRhs
-> Word16
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
compile_bind ByteOff
d' [Id]
fvs Id
x CgStgRhs
rhs Word16
size Word16
arity (WordOff -> Word16
trunc16W WordOff
n)
| ([Id]
fvs, Id
x, CgStgRhs
rhs, Word16
size, Word16
arity, WordOff
n) <-
forall a b c d e f.
[a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]
zip6 [[Id]]
fvss [Id]
xs [CgStgRhs]
rhss [Word16]
sizes [Word16]
arities [WordOff
n_binds, WordOff
n_bindsforall a. Num a => a -> a -> a
-WordOff
1 .. WordOff
1]
]
OrdList BCInstr
body_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d' ByteOff
s Map Id ByteOff
p' CgStgExpr
body
[OrdList BCInstr]
thunk_codes <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [BcM (OrdList BCInstr)]
compile_binds
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
alloc_code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. [OrdList a] -> OrdList a
concatOL [OrdList BCInstr]
thunk_codes forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
body_code)
schemeE ByteOff
_d ByteOff
_s Map Id ByteOff
_p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
_ Int
bp_id [XTickishId 'TickishPassStg]
_) CgStgExpr
_rhs)
= forall a. String -> a
panic (String
"schemeE: Breakpoint without let binding: " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show Int
bp_id forall a. [a] -> [a] -> [a]
++
String
" forgot to run bcPrep?")
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgTick StgTickish
_ CgStgExpr
rhs) = ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p CgStgExpr
rhs
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgCase CgStgExpr
scrut BinderP 'CodeGen
_ AltType
_ []) = ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p CgStgExpr
scrut
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgCase CgStgExpr
scrut BinderP 'CodeGen
bndr AltType
_ [CgStgAlt]
alts)
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM (OrdList BCInstr)
doCase ByteOff
d ByteOff
s Map Id ByteOff
p CgStgExpr
scrut BinderP 'CodeGen
bndr [CgStgAlt]
alts
schemeT :: StackDepth
-> Sequel
-> BCEnv
-> CgStgExpr
-> BcM BCInstrList
schemeT :: ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p CgStgExpr
app
| Just (Id
arg, [Name]
constr_names) <- CgStgExpr -> Maybe (Id, [Name])
maybe_is_tagToEnum_call CgStgExpr
app
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [Name]
-> BcM (OrdList BCInstr)
implement_tagToId ByteOff
d ByteOff
s Map Id ByteOff
p Id
arg [Name]
constr_names
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgOpApp (StgFCallOp (CCall CCallSpec
ccall_spec) Kind
_ty) [StgArg]
args Kind
result_ty)
= if CCallSpec -> Bool
isSupportedCConv CCallSpec
ccall_spec
then ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Kind
-> [StgArg]
-> BcM (OrdList BCInstr)
generateCCall ByteOff
d ByteOff
s Map Id ByteOff
p CCallSpec
ccall_spec Kind
result_ty [StgArg]
args
else forall a. a
unsupportedCConvException
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgOpApp (StgPrimOp PrimOp
op) [StgArg]
args Kind
_ty)
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [StgArg]
-> BcM (OrdList BCInstr)
doTailCall ByteOff
d ByteOff
s Map Id ByteOff
p (PrimOp -> Id
primOpId PrimOp
op) (forall a. [a] -> [a]
reverse [StgArg]
args)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgOpApp (StgPrimCallOp (PrimCall FastString
label Unit
unit)) [StgArg]
args Kind
result_ty)
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> FastString
-> Maybe Unit
-> Kind
-> [StgArg]
-> BcM (OrdList BCInstr)
generatePrimCall ByteOff
d ByteOff
s Map Id ByteOff
p FastString
label (forall a. a -> Maybe a
Just Unit
unit) Kind
result_ty [StgArg]
args
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgConApp DataCon
con ConstructorNumber
_cn [StgArg]
args [Kind]
_tys)
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con
= ByteOff
-> ByteOff -> Map Id ByteOff -> [StgArg] -> BcM (OrdList BCInstr)
returnUnboxedTuple ByteOff
d ByteOff
s Map Id ByteOff
p [StgArg]
args
| Bool
otherwise
= do OrdList BCInstr
alloc_con <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM (OrdList BCInstr)
mkConAppCode ByteOff
d ByteOff
s Map Id ByteOff
p DataCon
con [StgArg]
args
Platform
platform <- Profile -> Platform
profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
alloc_con forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
1 (Platform -> ByteOff -> WordOff
bytesToWords Platform
platform forall a b. (a -> b) -> a -> b
$ ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
s) forall a. OrdList a -> a -> OrdList a
`snocOL` ArgRep -> BCInstr
RETURN ArgRep
P)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgApp Id
fn [StgArg]
args)
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [StgArg]
-> BcM (OrdList BCInstr)
doTailCall ByteOff
d ByteOff
s Map Id ByteOff
p Id
fn (forall a. [a] -> [a]
reverse [StgArg]
args)
schemeT ByteOff
_ ByteOff
_ Map Id ByteOff
_ CgStgExpr
e = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToByteCode.schemeT"
(forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
shortStgPprOpts CgStgExpr
e)
mkConAppCode
:: StackDepth
-> Sequel
-> BCEnv
-> DataCon
-> [StgArg]
-> BcM BCInstrList
mkConAppCode :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM (OrdList BCInstr)
mkConAppCode ByteOff
orig_d ByteOff
_ Map Id ByteOff
p DataCon
con [StgArg]
args = BcM (OrdList BCInstr)
app_code
where
app_code :: BcM (OrdList BCInstr)
app_code = do
Profile
profile <- BcM Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
non_voids :: [NonVoid (PrimRep, StgArg)]
non_voids =
[ forall a. a -> NonVoid a
NonVoid (PrimRep
prim_rep, StgArg
arg)
| StgArg
arg <- [StgArg]
args
, let prim_rep :: PrimRep
prim_rep = StgArg -> PrimRep
atomPrimRep StgArg
arg
, Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prim_rep)
]
(Int
_, Int
_, [FieldOffOrPadding StgArg]
args_offsets) =
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
StdHeader [NonVoid (PrimRep, StgArg)]
non_voids
do_pushery :: ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
do_pushery !ByteOff
d (FieldOffOrPadding StgArg
arg : [FieldOffOrPadding StgArg]
args) = do
(OrdList BCInstr
push, ByteOff
arg_bytes) <- case FieldOffOrPadding StgArg
arg of
(Padding Int
l Int
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteOff -> (OrdList BCInstr, ByteOff)
pushPadding (Int -> ByteOff
ByteOff Int
l)
(FieldOff NonVoid StgArg
a Int
_) -> ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushConstrAtom ByteOff
d Map Id ByteOff
p (forall a. NonVoid a -> a
fromNonVoid NonVoid StgArg
a)
OrdList BCInstr
more_push_code <- ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
do_pushery (ByteOff
d forall a. Num a => a -> a -> a
+ ByteOff
arg_bytes) [FieldOffOrPadding StgArg]
args
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
more_push_code)
do_pushery !ByteOff
d [] = do
let !n_arg_words :: Word16
n_arg_words = WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
orig_d)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (DataCon -> Word16 -> BCInstr
PACK DataCon
con Word16
n_arg_words))
ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
do_pushery ByteOff
orig_d (forall a. [a] -> [a]
reverse [FieldOffOrPadding StgArg]
args_offsets)
doTailCall
:: StackDepth
-> Sequel
-> BCEnv
-> Id
-> [StgArg]
-> BcM BCInstrList
doTailCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [StgArg]
-> BcM (OrdList BCInstr)
doTailCall ByteOff
init_d ByteOff
s Map Id ByteOff
p Id
fn [StgArg]
args = do
Platform
platform <- Profile -> Platform
profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
do_pushes ByteOff
init_d [StgArg]
args (forall a b. (a -> b) -> [a] -> [b]
map (Platform -> StgArg -> ArgRep
atomRep Platform
platform) [StgArg]
args)
where
do_pushes :: ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
do_pushes !ByteOff
d [] [ArgRep]
reps = do
forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ArgRep]
reps) forall (m :: * -> *) a. Monad m => a -> m a
return ()
(OrdList BCInstr
push_fn, ByteOff
sz) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
fn)
Platform
platform <- Profile -> Platform
profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
forall a. HasCallStack => Bool -> a -> a
assert (ByteOff
sz forall a. Eq a => a -> a -> Bool
== Platform -> ByteOff
wordSize Platform
platform) forall (m :: * -> *) a. Monad m => a -> m a
return ()
let slide :: OrdList BCInstr
slide = Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB Platform
platform (ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
init_d forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform) (ByteOff
init_d forall a. Num a => a -> a -> a
- ByteOff
s)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push_fn forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (OrdList BCInstr
slide forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. a -> OrdList a
unitOL BCInstr
ENTER))
do_pushes !ByteOff
d [StgArg]
args [ArgRep]
reps = do
let (BCInstr
push_apply, Int
n, [ArgRep]
rest_of_reps) = [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq [ArgRep]
reps
([StgArg]
these_args, [StgArg]
rest_of_args) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [StgArg]
args
(ByteOff
next_d, OrdList BCInstr
push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
push_seq ByteOff
d [StgArg]
these_args
Platform
platform <- Profile -> Platform
profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
OrdList BCInstr
instrs <- ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
do_pushes (ByteOff
next_d forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform) [StgArg]
rest_of_args [ArgRep]
rest_of_reps
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push_code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (BCInstr
push_apply forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
instrs))
push_seq :: ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
push_seq ByteOff
d [] = forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
d, forall a. OrdList a
nilOL)
push_seq ByteOff
d (StgArg
arg:[StgArg]
args) = do
(OrdList BCInstr
push_code, ByteOff
sz) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
arg
(ByteOff
final_d, OrdList BCInstr
more_push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
push_seq (ByteOff
d forall a. Num a => a -> a -> a
+ ByteOff
sz) [StgArg]
args
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
final_d, OrdList BCInstr
push_code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
more_push_code)
findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq (ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_PPPPPP, Int
6, [ArgRep]
rest)
findPushSeq (ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_PPPPP, Int
5, [ArgRep]
rest)
findPushSeq (ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_PPPP, Int
4, [ArgRep]
rest)
findPushSeq (ArgRep
P: ArgRep
P: ArgRep
P: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_PPP, Int
3, [ArgRep]
rest)
findPushSeq (ArgRep
P: ArgRep
P: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_PP, Int
2, [ArgRep]
rest)
findPushSeq (ArgRep
P: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_P, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
V: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_V, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
N: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_N, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
F: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_F, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
D: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_D, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
L: [ArgRep]
rest)
= (BCInstr
PUSH_APPLY_L, Int
1, [ArgRep]
rest)
findPushSeq [ArgRep]
argReps
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ArgRep
V16, ArgRep
V32, ArgRep
V64]) [ArgRep]
argReps
= forall a. String -> a
sorry String
"SIMD vector operations are not available in GHCi"
findPushSeq [ArgRep]
_
= forall a. String -> a
panic String
"GHC.StgToByteCode.findPushSeq"
doCase
:: StackDepth
-> Sequel
-> BCEnv
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
doCase :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM (OrdList BCInstr)
doCase ByteOff
d ByteOff
s Map Id ByteOff
p CgStgExpr
scrut Id
bndr [CgStgAlt]
alts
= do
Profile
profile <- BcM Profile
getProfile
HscEnv
hsc_env <- BcM HscEnv
getHscEnv
let
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
non_void_arg_reps :: [ArgRep]
non_void_arg_reps = [ArgRep] -> [ArgRep]
non_void (Platform -> Kind -> [ArgRep]
typeArgReps Platform
platform Kind
bndr_ty)
ubx_tuple_frame :: Bool
ubx_tuple_frame =
(Kind -> Bool
isUnboxedTupleType Kind
bndr_ty Bool -> Bool -> Bool
|| Kind -> Bool
isUnboxedSumType Kind
bndr_ty) Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ArgRep]
non_void_arg_reps forall a. Ord a => a -> a -> Bool
> Int
1
profiling :: Bool
profiling
| Just Interp
interp <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
= Interp -> Bool
interpreterProfiled Interp
interp
| Bool
otherwise = Bool
False
ret_frame_size_b :: StackDepth
ret_frame_size_b :: ByteOff
ret_frame_size_b | Bool
ubx_tuple_frame =
(if Bool
profiling then ByteOff
5 else ByteOff
4) forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
| Bool
otherwise = ByteOff
2 forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
save_ccs_size_b :: ByteOff
save_ccs_size_b | Bool
profiling Bool -> Bool -> Bool
&&
Bool -> Bool
not Bool
ubx_tuple_frame = ByteOff
2 forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
| Bool
otherwise = ByteOff
0
unlifted_itbl_size_b :: StackDepth
unlifted_itbl_size_b :: ByteOff
unlifted_itbl_size_b | Bool
ubx_tuple_frame = Platform -> ByteOff
wordSize Platform
platform
| Bool
otherwise = ByteOff
0
(ByteOff
bndr_size, NativeCallInfo
call_info, [(PrimRep, ByteOff)]
args_offsets)
| Bool
ubx_tuple_frame =
let bndr_ty :: PrimRep -> CmmType
bndr_ty = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform
bndr_reps :: [PrimRep]
bndr_reps = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.PrimRep -> Bool
isVoidRep) (Id -> [PrimRep]
bcIdPrimReps Id
bndr)
(NativeCallInfo
call_info, [(PrimRep, ByteOff)]
args_offsets) =
forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile NativeCallType
NativeTupleReturn ByteOff
0 PrimRep -> CmmType
bndr_ty [PrimRep]
bndr_reps
in ( Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (NativeCallInfo -> WordOff
nativeCallSize NativeCallInfo
call_info)
, NativeCallInfo
call_info
, [(PrimRep, ByteOff)]
args_offsets
)
| Bool
otherwise = ( Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (Platform -> Id -> WordOff
idSizeW Platform
platform Id
bndr)
, NativeCallInfo
voidTupleReturnInfo
, []
)
d_bndr :: ByteOff
d_bndr =
ByteOff
d forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b forall a. Num a => a -> a -> a
+ ByteOff
bndr_size
d_alts :: ByteOff
d_alts = ByteOff
d forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b forall a. Num a => a -> a -> a
+ ByteOff
bndr_size forall a. Num a => a -> a -> a
+ ByteOff
unlifted_itbl_size_b
p_alts :: Map Id ByteOff
p_alts = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
bndr ByteOff
d_bndr Map Id ByteOff
p
bndr_ty :: Kind
bndr_ty = Id -> Kind
idType Id
bndr
isAlgCase :: Bool
isAlgCase = Kind -> Bool
isAlgType Kind
bndr_ty
codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)
codeAlt :: CgStgAlt -> BcM (Discr, OrdList BCInstr)
codeAlt GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
DEFAULT,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'CodeGen]
_,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=CgStgExpr
rhs}
= do OrdList BCInstr
rhs_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts CgStgExpr
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr
NoDiscr, OrdList BCInstr
rhs_code)
codeAlt alt :: CgStgAlt
alt@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
_, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'CodeGen]
bndrs, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=CgStgExpr
rhs}
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
real_bndrs = do
OrdList BCInstr
rhs_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts CgStgExpr
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {pass :: StgPass}. GenStgAlt pass -> Discr
my_discr CgStgAlt
alt, OrdList BCInstr
rhs_code)
| Kind -> Bool
isUnboxedTupleType Kind
bndr_ty Bool -> Bool -> Bool
|| Kind -> Bool
isUnboxedSumType Kind
bndr_ty =
let bndr_ty :: Id -> CmmType
bndr_ty = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
bcIdPrimRep
tuple_start :: ByteOff
tuple_start = ByteOff
d_bndr
(NativeCallInfo
call_info, [(Id, ByteOff)]
args_offsets) =
forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile
NativeCallType
NativeTupleReturn
ByteOff
0
Id -> CmmType
bndr_ty
[BinderP 'CodeGen]
bndrs
stack_bot :: ByteOff
stack_bot = ByteOff
d_alts
p' :: Map Id ByteOff
p' = forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList
[ (Id
arg, ByteOff
tuple_start forall a. Num a => a -> a -> a
-
Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (NativeCallInfo -> WordOff
nativeCallSize NativeCallInfo
call_info) forall a. Num a => a -> a -> a
+
ByteOff
offset)
| (Id
arg, ByteOff
offset) <- [(Id, ByteOff)]
args_offsets
, Bool -> Bool
not (PrimRep -> Bool
isVoidRep forall a b. (a -> b) -> a -> b
$ Id -> PrimRep
bcIdPrimRep Id
arg)]
Map Id ByteOff
p_alts
in do
OrdList BCInstr
rhs_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' CgStgExpr
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr
NoDiscr, OrdList BCInstr
rhs_code)
| Bool
otherwise =
let (Int
tot_wds, Int
_ptrs_wds, [(NonVoid Id, Int)]
args_offsets) =
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets Profile
profile ClosureHeader
NoHeader
[ forall a. a -> NonVoid a
NonVoid (Id -> PrimRep
bcIdPrimRep Id
id, Id
id)
| NonVoid Id
id <- [Id] -> [NonVoid Id]
nonVoidIds [Id]
real_bndrs
]
size :: WordOff
size = Int -> WordOff
WordOff Int
tot_wds
stack_bot :: ByteOff
stack_bot = ByteOff
d_alts forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
size
p' :: Map Id ByteOff
p' = forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList
[ (Id
arg, ByteOff
stack_bot forall a. Num a => a -> a -> a
- Int -> ByteOff
ByteOff Int
offset)
| (NonVoid Id
arg, Int
offset) <- [(NonVoid Id, Int)]
args_offsets ]
Map Id ByteOff
p_alts
in do
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert Bool
isAlgCase
OrdList BCInstr
rhs_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' CgStgExpr
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {pass :: StgPass}. GenStgAlt pass -> Discr
my_discr CgStgAlt
alt,
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
UNPACK (WordOff -> Word16
trunc16W WordOff
size)) forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
rhs_code)
where
real_bndrs :: [Id]
real_bndrs = forall a. (a -> Bool) -> [a] -> [a]
filterOut Id -> Bool
isTyVar [BinderP 'CodeGen]
bndrs
my_discr :: GenStgAlt pass -> Discr
my_discr GenStgAlt pass
alt = case forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt pass
alt of
AltCon
DEFAULT -> Discr
NoDiscr
DataAlt DataCon
dc
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
dc
-> Discr
NoDiscr
| Bool
otherwise
-> Word16 -> Discr
DiscrP (forall a b. (Integral a, Num b) => a -> b
fromIntegral (DataCon -> Int
dataConTag DataCon
dc forall a. Num a => a -> a -> a
- Int
fIRST_TAG))
LitAlt Literal
l -> case Literal
l of
LitNumber LitNumType
LitNumInt Integer
i -> Int -> Discr
DiscrI (forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumInt8 Integer
i -> Int8 -> Discr
DiscrI8 (forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumInt16 Integer
i -> Int16 -> Discr
DiscrI16 (forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumInt32 Integer
i -> Int32 -> Discr
DiscrI32 (forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumInt64 Integer
i -> Int64 -> Discr
DiscrI64 (forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumWord Integer
w -> Word -> Discr
DiscrW (forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumWord8 Integer
w -> Word8 -> Discr
DiscrW8 (forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumWord16 Integer
w -> Word16 -> Discr
DiscrW16 (forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumWord32 Integer
w -> Word32 -> Discr
DiscrW32 (forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumWord64 Integer
w -> Word64 -> Discr
DiscrW64 (forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumBigNat Integer
_ -> Discr
unsupported
LitFloat Rational
r -> Float -> Discr
DiscrF (forall a. Fractional a => Rational -> a
fromRational Rational
r)
LitDouble Rational
r -> Double -> Discr
DiscrD (forall a. Fractional a => Rational -> a
fromRational Rational
r)
LitChar Char
i -> Int -> Discr
DiscrI (Char -> Int
ord Char
i)
LitString {} -> Discr
unsupported
LitRubbish {} -> Discr
unsupported
LitNullAddr {} -> Discr
unsupported
LitLabel {} -> Discr
unsupported
where
unsupported :: Discr
unsupported = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"schemeE(StgCase).my_discr:" (forall a. Outputable a => a -> SDoc
ppr Literal
l)
maybe_ncons :: Maybe Int
maybe_ncons
| Bool -> Bool
not Bool
isAlgCase = forall a. Maybe a
Nothing
| Bool
otherwise
= case [DataCon
dc | DataAlt DataCon
dc <- forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CgStgAlt]
alts] of
[] -> forall a. Maybe a
Nothing
(DataCon
dc:[DataCon]
_) -> forall a. a -> Maybe a
Just (TyCon -> Int
tyConFamilySize (DataCon -> TyCon
dataConTyCon DataCon
dc))
([Int]
extra_pointers, Int
extra_slots)
| Bool
ubx_tuple_frame Bool -> Bool -> Bool
&& Bool
profiling = ([Int
1], Int
3)
| Bool
ubx_tuple_frame = ([Int
1], Int
2)
| Bool
otherwise = ([], Int
0)
bitmap_size :: Word16
bitmap_size = WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
extra_slots forall a. Num a => a -> a -> a
+
Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
s)
bitmap_size' :: Int
bitmap_size' :: Int
bitmap_size' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bitmap_size
pointers :: [Int]
pointers =
[Int]
extra_pointers forall a. [a] -> [a] -> [a]
++
forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
< Int
bitmap_size') (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+Int
extra_slots) [Int]
rel_slots)
where
rel_slots :: [Int]
rel_slots = IntSet -> [Int]
IntSet.toAscList forall a b. (a -> b) -> a -> b
$ [Int] -> IntSet
IntSet.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey Id -> ByteOff -> Maybe Int
spread Map Id ByteOff
p
spread :: Id -> ByteOff -> Maybe Int
spread Id
id ByteOff
offset | Kind -> Bool
isUnboxedTupleType (Id -> Kind
idType Id
id) Bool -> Bool -> Bool
||
Kind -> Bool
isUnboxedSumType (Id -> Kind
idType Id
id) = forall a. Maybe a
Nothing
| ArgRep -> Bool
isFollowableArg (Platform -> Id -> ArgRep
bcIdArgRep Platform
platform Id
id) = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
rel_offset)
| Bool
otherwise = forall a. Maybe a
Nothing
where rel_offset :: Word16
rel_offset = WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
offset)
bitmap :: [StgWord]
bitmap = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform Int
bitmap_size' [Int]
pointers
[(Discr, OrdList BCInstr)]
alt_stuff <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CgStgAlt -> BcM (Discr, OrdList BCInstr)
codeAlt [CgStgAlt]
alts
OrdList BCInstr
alt_final0 <- Maybe Int -> [(Discr, OrdList BCInstr)] -> BcM (OrdList BCInstr)
mkMultiBranch Maybe Int
maybe_ncons [(Discr, OrdList BCInstr)]
alt_stuff
let alt_final :: OrdList BCInstr
alt_final
| Bool
ubx_tuple_frame = Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
0 WordOff
2 forall a. Monoid a => a -> a -> a
`mappend` OrdList BCInstr
alt_final0
| Bool
otherwise = OrdList BCInstr
alt_final0
let
alt_bco_name :: Name
alt_bco_name = forall a. NamedThing a => a -> Name
getName Id
bndr
alt_bco :: [FFIInfo] -> ProtoBCO Name
alt_bco = forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
alt_bco_name OrdList BCInstr
alt_final (forall a b. a -> Either a b
Left [CgStgAlt]
alts)
Int
0 Word16
bitmap_size [StgWord]
bitmap Bool
True
OrdList BCInstr
scrut_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE (ByteOff
d forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b forall a. Num a => a -> a -> a
+ ByteOff
save_ccs_size_b)
(ByteOff
d forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b forall a. Num a => a -> a -> a
+ ByteOff
save_ccs_size_b)
Map Id ByteOff
p CgStgExpr
scrut
ProtoBCO Name
alt_bco' <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc [FFIInfo] -> ProtoBCO Name
alt_bco
if Bool
ubx_tuple_frame
then do ProtoBCO Name
tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> [FFIInfo]
-> ProtoBCO Name
tupleBCO Platform
platform NativeCallInfo
call_info [(PrimRep, ByteOff)]
args_offsets)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> NativeCallInfo -> ProtoBCO Name -> BCInstr
PUSH_ALTS_TUPLE ProtoBCO Name
alt_bco' NativeCallInfo
call_info ProtoBCO Name
tuple_bco
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
scrut_code)
else let scrut_rep :: ArgRep
scrut_rep = case [ArgRep]
non_void_arg_reps of
[] -> ArgRep
V
[ArgRep
rep] -> ArgRep
rep
[ArgRep]
_ -> forall a. String -> a
panic String
"schemeE(StgCase).push_alts"
in forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> ArgRep -> BCInstr
PUSH_ALTS ProtoBCO Name
alt_bco' ArgRep
scrut_rep forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
scrut_code)
layoutNativeCall :: Profile
-> NativeCallType
-> ByteOff
-> (a -> CmmType)
-> [a]
-> ( NativeCallInfo
, [(a, ByteOff)]
)
layoutNativeCall :: forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile NativeCallType
call_type ByteOff
start_off a -> CmmType
arg_ty [a]
reps =
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
(Int
orig_stk_bytes, [(a, ParamLocation)]
pos) = forall a.
Profile
-> Int
-> Convention
-> (a -> CmmType)
-> [a]
-> (Int, [(a, ParamLocation)])
assignArgumentsPos Profile
profile
Int
0
Convention
NativeReturn
a -> CmmType
arg_ty
[a]
reps
orig_stk_params :: [(a, ByteOff)]
orig_stk_params = [(a
x, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) | (a
x, StackParam Int
off) <- [(a, ParamLocation)]
pos]
regs_order :: Map.Map GlobalReg Int
regs_order :: Map GlobalReg Int
regs_order = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (Platform -> [GlobalReg]
allArgRegsCover Platform
platform) [Int
0..]
reg_order :: GlobalReg -> (Int, GlobalReg)
reg_order :: GlobalReg -> (Int, GlobalReg)
reg_order GlobalReg
reg | Just Int
n <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalReg
reg Map GlobalReg Int
regs_order = (Int
n, GlobalReg
reg)
reg_order (VanillaReg Int
n VGcPtr
VNonGcPtr) = GlobalReg -> (Int, GlobalReg)
reg_order (Int -> VGcPtr -> GlobalReg
VanillaReg Int
n VGcPtr
VGcPtr)
reg_order (FloatReg Int
n) = GlobalReg -> (Int, GlobalReg)
reg_order (Int -> GlobalReg
DoubleReg Int
n)
reg_order GlobalReg
reg = (Int
0, GlobalReg
reg)
([(Int, GlobalReg)]
regs, [a]
reg_params)
= forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)
[(GlobalReg -> (Int, GlobalReg)
reg_order GlobalReg
reg, a
x) | (a
x, RegisterParam GlobalReg
reg) <- [(a, ParamLocation)]
pos]
(Int
new_stk_bytes, [(a, ParamLocation)]
new_stk_params) = forall a.
Platform
-> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
assignStack Platform
platform
Int
orig_stk_bytes
a -> CmmType
arg_ty
[a]
reg_params
regs_set :: RegSet GlobalReg
regs_set = forall r. Ord r => [r] -> RegSet r
mkRegSet (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Int, GlobalReg)]
regs)
get_byte_off :: (a, ParamLocation) -> (a, b)
get_byte_off (a
x, StackParam Int
y) = (a
x, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
get_byte_off (a, ParamLocation)
_ =
forall a. String -> a
panic String
"GHC.StgToByteCode.layoutTuple get_byte_off"
in ( NativeCallInfo
{ nativeCallType :: NativeCallType
nativeCallType = NativeCallType
call_type
, nativeCallSize :: WordOff
nativeCallSize = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (Int -> ByteOff
ByteOff Int
new_stk_bytes)
, nativeCallRegs :: RegSet GlobalReg
nativeCallRegs = RegSet GlobalReg
regs_set
, nativeCallStackSpillSize :: WordOff
nativeCallStackSpillSize = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform
(Int -> ByteOff
ByteOff Int
orig_stk_bytes)
}
, forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(a
x, ByteOff
o) -> (a
x, ByteOff
o forall a. Num a => a -> a -> a
+ ByteOff
start_off))
([(a, ByteOff)]
orig_stk_params forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. Num b => (a, ParamLocation) -> (a, b)
get_byte_off [(a, ParamLocation)]
new_stk_params)
)
tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO :: Platform
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> [FFIInfo]
-> ProtoBCO Name
tupleBCO Platform
platform NativeCallInfo
args_info [(PrimRep, ByteOff)]
args =
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
invented_name OrdList BCInstr
body_code (forall a b. a -> Either a b
Left [])
Int
0 Word16
bitmap_size [StgWord]
bitmap Bool
False
where
invented_name :: Name
invented_name = Unique -> FastString -> Name
mkSystemVarName (Int -> Unique
mkPseudoUniqueE Int
0) (String -> FastString
fsLit String
"tuple")
nptrs_prefix :: WordOff
nptrs_prefix = WordOff
1
(Word16
bitmap_size, [StgWord]
bitmap) = Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (Word16, [StgWord])
mkStackBitmap Platform
platform WordOff
nptrs_prefix NativeCallInfo
args_info [(PrimRep, ByteOff)]
args
body_code :: OrdList BCInstr
body_code = Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
0 WordOff
1
forall a. OrdList a -> a -> OrdList a
`snocOL` BCInstr
RETURN_TUPLE
primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
primCallBCO :: Platform
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> [FFIInfo]
-> ProtoBCO Name
primCallBCO Platform
platform NativeCallInfo
args_info [(PrimRep, ByteOff)]
args =
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
invented_name OrdList BCInstr
body_code (forall a b. a -> Either a b
Left [])
Int
0 Word16
bitmap_size [StgWord]
bitmap Bool
False
where
invented_name :: Name
invented_name = Unique -> FastString -> Name
mkSystemVarName (Int -> Unique
mkPseudoUniqueE Int
0) (String -> FastString
fsLit String
"primcall")
nptrs_prefix :: WordOff
nptrs_prefix = WordOff
2
(Word16
bitmap_size, [StgWord]
bitmap) = Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (Word16, [StgWord])
mkStackBitmap Platform
platform WordOff
nptrs_prefix NativeCallInfo
args_info [(PrimRep, ByteOff)]
args
body_code :: OrdList BCInstr
body_code = forall a. a -> OrdList a
unitOL BCInstr
CASEFAIL
mkStackBitmap
:: Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (Word16, [StgWord])
mkStackBitmap :: Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (Word16, [StgWord])
mkStackBitmap Platform
platform WordOff
nptrs_prefix NativeCallInfo
args_info [(PrimRep, ByteOff)]
args
= (Word16
bitmap_size, [StgWord]
bitmap)
where
bitmap_size :: Word16
bitmap_size = WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ WordOff
nptrs_prefix forall a. Num a => a -> a -> a
+ WordOff
arg_bottom
bitmap :: [StgWord]
bitmap = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bitmap_size) [Int]
ptr_offsets
arg_bottom :: WordOff
arg_bottom = NativeCallInfo -> WordOff
nativeCallSize NativeCallInfo
args_info
ptr_offsets :: [Int]
ptr_offsets = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteOff -> WordOff
convert_arg_offset)
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PrimRep, ByteOff) -> Maybe ByteOff
get_ptr_offset [(PrimRep, ByteOff)]
args
get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff
get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff
get_ptr_offset (PrimRep
rep, ByteOff
byte_offset)
| ArgRep -> Bool
isFollowableArg (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep) = forall a. a -> Maybe a
Just ByteOff
byte_offset
| Bool
otherwise = forall a. Maybe a
Nothing
convert_arg_offset :: ByteOff -> WordOff
convert_arg_offset :: ByteOff -> WordOff
convert_arg_offset ByteOff
arg_offset =
WordOff
nptrs_prefix forall a. Num a => a -> a -> a
+ (WordOff
arg_bottom forall a. Num a => a -> a -> a
- Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
arg_offset)
generatePrimCall
:: StackDepth
-> Sequel
-> BCEnv
-> CLabelString
-> Maybe Unit
-> Type
-> [StgArg]
-> BcM BCInstrList
generatePrimCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> FastString
-> Maybe Unit
-> Kind
-> [StgArg]
-> BcM (OrdList BCInstr)
generatePrimCall ByteOff
d ByteOff
s Map Id ByteOff
p FastString
target Maybe Unit
_mb_unit Kind
_result_ty [StgArg]
args
= do
Profile
profile <- BcM Profile
getProfile
let
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
non_void :: PrimRep -> Bool
non_void PrimRep
VoidRep = Bool
False
non_void PrimRep
_ = Bool
True
nv_args :: [StgArg]
nv_args :: [StgArg]
nv_args = forall a. (a -> Bool) -> [a] -> [a]
filter (PrimRep -> Bool
non_void forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> PrimRep
argPrimRep) [StgArg]
args
(NativeCallInfo
args_info, [(StgArg, ByteOff)]
args_offsets) =
forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile
NativeCallType
NativePrimCall
ByteOff
0
(Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> PrimRep
argPrimRep)
[StgArg]
nv_args
prim_args_offsets :: [(PrimRep, ByteOff)]
prim_args_offsets = forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst StgArg -> PrimRep
argPrimRep [(StgArg, ByteOff)]
args_offsets
shifted_args_offsets :: [(StgArg, ByteOff)]
shifted_args_offsets = forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (forall a. Num a => a -> a -> a
+ ByteOff
d) [(StgArg, ByteOff)]
args_offsets
push_target :: BCInstr
push_target = Literal -> Word16 -> BCInstr
PUSH_UBX (FastString -> Maybe Int -> FunctionOrData -> Literal
LitLabel FastString
target forall a. Maybe a
Nothing FunctionOrData
IsFunction) Word16
1
push_info :: BCInstr
push_info = Literal -> Word16 -> BCInstr
PUSH_UBX (Platform -> NativeCallInfo -> Literal
mkNativeCallInfoLit Platform
platform NativeCallInfo
args_info) Word16
1
szb :: ByteOff
szb = Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (NativeCallInfo -> WordOff
nativeCallSize NativeCallInfo
args_info forall a. Num a => a -> a -> a
+ WordOff
3)
go :: ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go ByteOff
_ [OrdList BCInstr]
pushes [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [OrdList BCInstr]
pushes)
go !ByteOff
dd [OrdList BCInstr]
pushes ((StgArg
a, ByteOff
off):[(StgArg, ByteOff)]
cs) = do (OrdList BCInstr
push, ByteOff
szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p StgArg
a
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (ByteOff
off forall a. Eq a => a -> a -> Bool
== ByteOff
dd forall a. Num a => a -> a -> a
+ ByteOff
szb)
ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go (ByteOff
dd forall a. Num a => a -> a -> a
+ ByteOff
szb) (OrdList BCInstr
pushforall a. a -> [a] -> [a]
:[OrdList BCInstr]
pushes) [(StgArg, ByteOff)]
cs
[OrdList BCInstr]
push_args <- ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go ByteOff
d [] [(StgArg, ByteOff)]
shifted_args_offsets
ProtoBCO Name
args_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> [FFIInfo]
-> ProtoBCO Name
primCallBCO Platform
platform NativeCallInfo
args_info [(PrimRep, ByteOff)]
prim_args_offsets)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [OrdList BCInstr]
push_args forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
(BCInstr
push_target forall a. a -> OrdList a -> OrdList a
`consOL`
BCInstr
push_info forall a. a -> OrdList a -> OrdList a
`consOL`
ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
args_bco forall a. a -> OrdList a -> OrdList a
`consOL`
(Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB Platform
platform ByteOff
szb (ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
s) forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. a -> OrdList a
unitOL BCInstr
PRIMCALL))
generateCCall
:: StackDepth
-> Sequel
-> BCEnv
-> CCallSpec
-> Type
-> [StgArg]
-> BcM BCInstrList
generateCCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Kind
-> [StgArg]
-> BcM (OrdList BCInstr)
generateCCall ByteOff
d0 ByteOff
s Map Id ByteOff
p (CCallSpec CCallTarget
target CCallConv
PrimCallConv Safety
_) Kind
result_ty [StgArg]
args
| (StaticTarget SourceText
_ FastString
label Maybe Unit
mb_unit Bool
_) <- CCallTarget
target
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> FastString
-> Maybe Unit
-> Kind
-> [StgArg]
-> BcM (OrdList BCInstr)
generatePrimCall ByteOff
d0 ByteOff
s Map Id ByteOff
p FastString
label Maybe Unit
mb_unit Kind
result_ty [StgArg]
args
| Bool
otherwise
= forall a. String -> a
panic String
"GHC.StgToByteCode.generateCCall: primcall convention only supports static targets"
generateCCall ByteOff
d0 ByteOff
s Map Id ByteOff
p (CCallSpec CCallTarget
target CCallConv
cconv Safety
safety) Kind
result_ty [StgArg]
args
= do
Profile
profile <- BcM Profile
getProfile
let
args_r_to_l :: [StgArg]
args_r_to_l = forall a. [a] -> [a]
reverse [StgArg]
args
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
addr_size_b :: ByteOff
addr_size_b :: ByteOff
addr_size_b = Platform -> ByteOff
wordSize Platform
platform
arrayish_rep_hdr_size :: TyCon -> Maybe Int
arrayish_rep_hdr_size :: TyCon -> Maybe Int
arrayish_rep_hdr_size TyCon
t
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon
= forall a. a -> Maybe a
Just (Profile -> Int
arrPtrsHdrSize Profile
profile)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon
= forall a. a -> Maybe a
Just (Profile -> Int
smallArrPtrsHdrSize Profile
profile)
| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon
= forall a. a -> Maybe a
Just (Profile -> Int
arrWordsHdrSize Profile
profile)
| Bool
otherwise
= forall a. Maybe a
Nothing
pargs
:: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
pargs :: ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
pargs ByteOff
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
pargs ByteOff
d (aa :: StgArg
aa@(StgVarArg Id
a):[StgArg]
az)
| Just TyCon
t <- Kind -> Maybe TyCon
tyConAppTyCon_maybe (Id -> Kind
idType Id
a)
, Just Int
hdr_sz <- TyCon -> Maybe Int
arrayish_rep_hdr_size TyCon
t
= do [(OrdList BCInstr, PrimRep)]
rest <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
pargs (ByteOff
d forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [StgArg]
az
(OrdList BCInstr
push_fo, ByteOff
_) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
aa
let code :: OrdList BCInstr
code = OrdList BCInstr
push_fo forall a. OrdList a -> a -> OrdList a
`snocOL` Word16 -> Word16 -> BCInstr
SWIZZLE Word16
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hdr_sz)
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList BCInstr
code, PrimRep
AddrRep) forall a. a -> [a] -> [a]
: [(OrdList BCInstr, PrimRep)]
rest)
pargs ByteOff
d (StgArg
aa:[StgArg]
az) = do (OrdList BCInstr
code_a, ByteOff
sz_a) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
aa
[(OrdList BCInstr, PrimRep)]
rest <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
pargs (ByteOff
d forall a. Num a => a -> a -> a
+ ByteOff
sz_a) [StgArg]
az
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList BCInstr
code_a, StgArg -> PrimRep
atomPrimRep StgArg
aa) forall a. a -> [a] -> [a]
: [(OrdList BCInstr, PrimRep)]
rest)
[(OrdList BCInstr, PrimRep)]
code_n_reps <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
pargs ByteOff
d0 [StgArg]
args_r_to_l
let
([OrdList BCInstr]
pushs_arg, [PrimRep]
a_reps_pushed_r_to_l) = forall a b. [(a, b)] -> ([a], [b])
unzip [(OrdList BCInstr, PrimRep)]
code_n_reps
a_reps_sizeW :: WordOff
a_reps_sizeW = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> WordOff
repSizeWords Platform
platform) [PrimRep]
a_reps_pushed_r_to_l)
push_args :: OrdList BCInstr
push_args = forall a. [OrdList a] -> OrdList a
concatOL [OrdList BCInstr]
pushs_arg
!d_after_args :: ByteOff
d_after_args = ByteOff
d0 forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
a_reps_sizeW
a_reps_pushed_RAW :: [PrimRep]
a_reps_pushed_RAW
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
a_reps_pushed_r_to_l Bool -> Bool -> Bool
|| Bool -> Bool
not (PrimRep -> Bool
isVoidRep (forall a. [a] -> a
head [PrimRep]
a_reps_pushed_r_to_l))
= forall a. String -> a
panic String
"GHC.StgToByteCode.generateCCall: missing or invalid World token?"
| Bool
otherwise
= forall a. [a] -> [a]
reverse (forall a. [a] -> [a]
tail [PrimRep]
a_reps_pushed_r_to_l)
(Bool
returns_void, PrimRep
r_rep)
= case Kind -> Maybe PrimRep
maybe_getCCallReturnRep Kind
result_ty of
Maybe PrimRep
Nothing -> (Bool
True, PrimRep
VoidRep)
Just PrimRep
rr -> (Bool
False, PrimRep
rr)
maybe_static_target :: Maybe Literal
maybe_static_target :: Maybe Literal
maybe_static_target =
case CCallTarget
target of
CCallTarget
DynamicTarget -> forall a. Maybe a
Nothing
StaticTarget SourceText
_ FastString
_ Maybe Unit
_ Bool
False ->
forall a. String -> a
panic String
"generateCCall: unexpected FFI value import"
StaticTarget SourceText
_ FastString
target Maybe Unit
_ Bool
True ->
forall a. a -> Maybe a
Just (FastString -> Maybe Int -> FunctionOrData -> Literal
LitLabel FastString
target Maybe Int
mb_size FunctionOrData
IsFunction)
where
mb_size :: Maybe Int
mb_size
| OS
OSMinGW32 <- Platform -> OS
platformOS Platform
platform
, CCallConv
StdCallConv <- CCallConv
cconv
= forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
a_reps_sizeW forall a. Num a => a -> a -> a
* Platform -> Int
platformWordSizeInBytes Platform
platform)
| Bool
otherwise
= forall a. Maybe a
Nothing
let
is_static :: Bool
is_static = forall a. Maybe a -> Bool
isJust Maybe Literal
maybe_static_target
a_reps :: [PrimRep]
a_reps
| Bool
is_static = [PrimRep]
a_reps_pushed_RAW
| Bool
otherwise = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
a_reps_pushed_RAW
then forall a. String -> a
panic String
"GHC.StgToByteCode.generateCCall: dyn with no args"
else forall a. [a] -> [a]
tail [PrimRep]
a_reps_pushed_RAW
(OrdList BCInstr
push_Addr, ByteOff
d_after_Addr)
| Just Literal
machlabel <- Maybe Literal
maybe_static_target
= (forall a. [a] -> OrdList a
toOL [Literal -> Word16 -> BCInstr
PUSH_UBX Literal
machlabel Word16
1], ByteOff
d_after_args forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b)
| Bool
otherwise
= (forall a. OrdList a
nilOL, ByteOff
d_after_args)
r_sizeW :: WordOff
r_sizeW = Platform -> PrimRep -> WordOff
repSizeWords Platform
platform PrimRep
r_rep
d_after_r :: ByteOff
d_after_r = ByteOff
d_after_Addr forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
r_sizeW
push_r :: OrdList BCInstr
push_r =
if Bool
returns_void
then forall a. OrdList a
nilOL
else forall a. a -> OrdList a
unitOL (Literal -> Word16 -> BCInstr
PUSH_UBX (Platform -> PrimRep -> Literal
mkDummyLiteral Platform
platform PrimRep
r_rep) (WordOff -> Word16
trunc16W WordOff
r_sizeW))
stk_offset :: Word16
stk_offset = WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d_after_r forall a. Num a => a -> a -> a
- ByteOff
s)
conv :: FFIConv
conv = case CCallConv
cconv of
CCallConv
CCallConv -> FFIConv
FFICCall
CCallConv
CApiConv -> FFIConv
FFICCall
CCallConv
StdCallConv -> FFIConv
FFIStdCall
CCallConv
_ -> forall a. String -> a
panic String
"GHC.StgToByteCode: unexpected calling convention"
let ffires :: FFIType
ffires = Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform PrimRep
r_rep
ffiargs :: [FFIType]
ffiargs = forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform) [PrimRep]
a_reps
Interp
interp <- HscEnv -> Interp
hscInterp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM HscEnv
getHscEnv
RemotePtr C_ffi_cif
token <- forall a. IO a -> BcM a
ioToBc forall a b. (a -> b) -> a -> b
$ forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
PrepFFI FFIConv
conv [FFIType]
ffiargs FFIType
ffires)
RemotePtr C_ffi_cif -> BcM ()
recordFFIBc RemotePtr C_ffi_cif
token
let
do_call :: OrdList BCInstr
do_call = forall a. a -> OrdList a
unitOL (Word16 -> RemotePtr C_ffi_cif -> Word16 -> BCInstr
CCALL Word16
stk_offset RemotePtr C_ffi_cif
token Word16
flags)
where flags :: Word16
flags = case Safety
safety of
Safety
PlaySafe -> Word16
0x0
Safety
PlayInterruptible -> Word16
0x1
Safety
PlayRisky -> Word16
0x2
d_after_r_min_s :: WordOff
d_after_r_min_s = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d_after_r forall a. Num a => a -> a -> a
- ByteOff
s)
wrapup :: OrdList BCInstr
wrapup = Word16 -> WordOff -> OrdList BCInstr
mkSlideW (WordOff -> Word16
trunc16W WordOff
r_sizeW) (WordOff
d_after_r_min_s forall a. Num a => a -> a -> a
- WordOff
r_sizeW)
forall a. OrdList a -> a -> OrdList a
`snocOL` ArgRep -> BCInstr
RETURN (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
r_rep)
forall (m :: * -> *) a. Monad m => a -> m a
return (
OrdList BCInstr
push_args forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList BCInstr
push_Addr forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
push_r forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
do_call forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
wrapup
)
primRepToFFIType :: Platform -> PrimRep -> FFIType
primRepToFFIType :: Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform PrimRep
r
= case PrimRep
r of
PrimRep
VoidRep -> FFIType
FFIVoid
PrimRep
IntRep -> FFIType
signed_word
PrimRep
WordRep -> FFIType
unsigned_word
PrimRep
Int8Rep -> FFIType
FFISInt8
PrimRep
Word8Rep -> FFIType
FFIUInt8
PrimRep
Int16Rep -> FFIType
FFISInt16
PrimRep
Word16Rep -> FFIType
FFIUInt16
PrimRep
Int32Rep -> FFIType
FFISInt32
PrimRep
Word32Rep -> FFIType
FFIUInt32
PrimRep
Int64Rep -> FFIType
FFISInt64
PrimRep
Word64Rep -> FFIType
FFIUInt64
PrimRep
AddrRep -> FFIType
FFIPointer
PrimRep
FloatRep -> FFIType
FFIFloat
PrimRep
DoubleRep -> FFIType
FFIDouble
PrimRep
LiftedRep -> FFIType
FFIPointer
PrimRep
UnliftedRep -> FFIType
FFIPointer
PrimRep
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primRepToFFIType" (forall a. Outputable a => a -> SDoc
ppr PrimRep
r)
where
(FFIType
signed_word, FFIType
unsigned_word) = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> (FFIType
FFISInt32, FFIType
FFIUInt32)
PlatformWordSize
PW8 -> (FFIType
FFISInt64, FFIType
FFIUInt64)
mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral Platform
platform PrimRep
pr
= case PrimRep
pr of
PrimRep
IntRep -> Platform -> Integer -> Literal
mkLitInt Platform
platform Integer
0
PrimRep
WordRep -> Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
0
PrimRep
Int8Rep -> Integer -> Literal
mkLitInt8 Integer
0
PrimRep
Word8Rep -> Integer -> Literal
mkLitWord8 Integer
0
PrimRep
Int16Rep -> Integer -> Literal
mkLitInt16 Integer
0
PrimRep
Word16Rep -> Integer -> Literal
mkLitWord16 Integer
0
PrimRep
Int32Rep -> Integer -> Literal
mkLitInt32 Integer
0
PrimRep
Word32Rep -> Integer -> Literal
mkLitWord32 Integer
0
PrimRep
Int64Rep -> Integer -> Literal
mkLitInt64 Integer
0
PrimRep
Word64Rep -> Integer -> Literal
mkLitWord64 Integer
0
PrimRep
AddrRep -> Literal
LitNullAddr
PrimRep
DoubleRep -> Rational -> Literal
LitDouble Rational
0
PrimRep
FloatRep -> Rational -> Literal
LitFloat Rational
0
PrimRep
LiftedRep -> Literal
LitNullAddr
PrimRep
UnliftedRep -> Literal
LitNullAddr
PrimRep
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkDummyLiteral" (forall a. Outputable a => a -> SDoc
ppr PrimRep
pr)
maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep :: Kind -> Maybe PrimRep
maybe_getCCallReturnRep Kind
fn_ty
= let
([Scaled Kind]
_a_tys, Kind
r_ty) = Kind -> ([Scaled Kind], Kind)
splitFunTys (Kind -> Kind
dropForAlls Kind
fn_ty)
r_reps :: [PrimRep]
r_reps = HasDebugCallStack => Kind -> [PrimRep]
typePrimRepArgs Kind
r_ty
blargh :: a
blargh :: forall a. a
blargh = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"maybe_getCCallReturn: can't handle:"
(Kind -> SDoc
pprType Kind
fn_ty)
in
case [PrimRep]
r_reps of
[] -> forall a. String -> a
panic String
"empty typePrimRepArgs"
[PrimRep
VoidRep] -> forall a. Maybe a
Nothing
[PrimRep
rep] -> forall a. a -> Maybe a
Just PrimRep
rep
[PrimRep]
_ -> forall a. a
blargh
maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
maybe_is_tagToEnum_call (StgOpApp (StgPrimOp PrimOp
TagToEnumOp) [StgVarArg Id
v] Kind
t)
= forall a. a -> Maybe a
Just (Id
v, Kind -> [Name]
extract_constr_Names Kind
t)
where
extract_constr_Names :: Kind -> [Name]
extract_constr_Names Kind
ty
| Kind
rep_ty <- Kind -> Kind
unwrapType Kind
ty
, Just TyCon
tyc <- Kind -> Maybe TyCon
tyConAppTyCon_maybe Kind
rep_ty
, TyCon -> Bool
isDataTyCon TyCon
tyc
= forall a b. (a -> b) -> [a] -> [b]
map (forall a. NamedThing a => a -> Name
getName forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Id
dataConWorkId) (TyCon -> [DataCon]
tyConDataCons TyCon
tyc)
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"maybe_is_tagToEnum_call.extract_constr_Ids" (forall a. Outputable a => a -> SDoc
ppr Kind
ty)
maybe_is_tagToEnum_call CgStgExpr
_ = forall a. Maybe a
Nothing
implement_tagToId
:: StackDepth
-> Sequel
-> BCEnv
-> Id
-> [Name]
-> BcM BCInstrList
implement_tagToId :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [Name]
-> BcM (OrdList BCInstr)
implement_tagToId ByteOff
d ByteOff
s Map Id ByteOff
p Id
arg [Name]
names
= forall a. HasCallStack => Bool -> a -> a
assert (forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Name]
names) forall a b. (a -> b) -> a -> b
$
do (OrdList BCInstr
push_arg, ByteOff
arg_bytes) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
arg)
[LocalLabel]
labels <- Word32 -> BcM [LocalLabel]
getLabelsBc (forall i a. Num i => [a] -> i
genericLength [Name]
names)
LocalLabel
label_fail <- BcM LocalLabel
getLabelBc
LocalLabel
label_exit <- BcM LocalLabel
getLabelBc
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let infos :: [(LocalLabel, LocalLabel, Int, Name)]
infos = forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [LocalLabel]
labels (forall a. [a] -> [a]
tail [LocalLabel]
labels forall a. [a] -> [a] -> [a]
++ [LocalLabel
label_fail])
[Int
0 ..] [Name]
names
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
steps :: [OrdList BCInstr]
steps = forall a b. (a -> b) -> [a] -> [b]
map (LocalLabel
-> (LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr
mkStep LocalLabel
label_exit) [(LocalLabel, LocalLabel, Int, Name)]
infos
slide_ws :: WordOff
slide_ws = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
s forall a. Num a => a -> a -> a
+ ByteOff
arg_bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push_arg
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. [OrdList a] -> OrdList a
concatOL [OrdList BCInstr]
steps
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. [a] -> OrdList a
toOL [ LocalLabel -> BCInstr
LABEL LocalLabel
label_fail, BCInstr
CASEFAIL,
LocalLabel -> BCInstr
LABEL LocalLabel
label_exit ]
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
1 WordOff
slide_ws
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. a -> OrdList a
unitOL BCInstr
ENTER)
where
mkStep :: LocalLabel
-> (LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr
mkStep LocalLabel
l_exit (LocalLabel
my_label, LocalLabel
next_label, Int
n, Name
name_for_n)
= forall a. [a] -> OrdList a
toOL [LocalLabel -> BCInstr
LABEL LocalLabel
my_label,
Int -> LocalLabel -> BCInstr
TESTEQ_I Int
n LocalLabel
next_label,
Name -> BCInstr
PUSH_G Name
name_for_n,
LocalLabel -> BCInstr
JMP LocalLabel
l_exit]
pushAtom
:: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom :: ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (StgVarArg Id
var)
| [] <- HasDebugCallStack => Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
var)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. OrdList a
nilOL, ByteOff
0)
| Id -> Bool
isFCallId Id
var
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pushAtom: shouldn't get an FCallId here" (forall a. Outputable a => a -> SDoc
ppr Id
var)
| Just PrimOp
primop <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
var
= do
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (PrimOp -> BCInstr
PUSH_PRIMOP PrimOp
primop), Platform -> ByteOff
wordSize Platform
platform)
| Just ByteOff
d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
var Map Id ByteOff
p
= do Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let !szb :: ByteOff
szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
with_instr :: (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr Word16 -> BCInstr
instr = do
let !off_b :: Word16
off_b = ByteOff -> Word16
trunc16B forall a b. (a -> b) -> a -> b
$ ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
d_v
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
instr Word16
off_b), Platform -> ByteOff
wordSize Platform
platform)
case ByteOff
szb of
ByteOff
1 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr Word16 -> BCInstr
PUSH8_W
ByteOff
2 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr Word16 -> BCInstr
PUSH16_W
ByteOff
4 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr Word16 -> BCInstr
PUSH32_W
ByteOff
_ -> do
let !szw :: WordOff
szw = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
szb
!off_w :: Word16
off_w = WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
d_v) forall a. Num a => a -> a -> a
+ WordOff
szw forall a. Num a => a -> a -> a
- WordOff
1
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> OrdList a
toOL (forall i a. Integral i => i -> a -> [a]
genericReplicate WordOff
szw (Word16 -> BCInstr
PUSH_L Word16
off_w)),
Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
szw)
| Bool
otherwise
= do Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let !szb :: ByteOff
szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (ByteOff
szb forall a. Eq a => a -> a -> Bool
== Platform -> ByteOff
wordSize Platform
platform)
case Id -> Maybe DataCon
isDataConWorkId_maybe Id
var of
Just DataCon
con -> do
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (DataCon -> Bool
isNullaryRepDataCon DataCon
con)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (DataCon -> Word16 -> BCInstr
PACK DataCon
con Word16
0), ByteOff
szb)
Maybe DataCon
Nothing
| HasDebugCallStack => Kind -> Bool
isUnliftedType (Id -> Kind
idType Id
var) -> do
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Id -> Kind
idType Id
var Kind -> Kind -> Bool
`eqType` Kind
addrPrimTy)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (Name -> BCInstr
PUSH_ADDR (forall a. NamedThing a => a -> Name
getName Id
var)), ByteOff
szb)
| Bool
otherwise -> do
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (Name -> BCInstr
PUSH_G (forall a. NamedThing a => a -> Name
getName Id
var)), ByteOff
szb)
pushAtom ByteOff
_ Map Id ByteOff
_ (StgLitArg Literal
lit) = Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
pushLiteral Bool
True Literal
lit
pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)
pushLiteral :: Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
pushLiteral Bool
padded Literal
lit =
do
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let code :: PrimRep -> BcM (BCInstrList, ByteOff)
code :: PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
rep =
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
padding_instr forall a. OrdList a -> a -> OrdList a
`snocOL` BCInstr
instr, ByteOff
size_bytes forall a. Num a => a -> a -> a
+ ByteOff
padding_bytes)
where
size_bytes :: ByteOff
size_bytes = Int -> ByteOff
ByteOff forall a b. (a -> b) -> a -> b
$ Platform -> PrimRep -> Int
primRepSizeB Platform
platform PrimRep
rep
round_to_words :: ByteOff -> ByteOff
round_to_words (ByteOff Int
bytes) =
Int -> ByteOff
ByteOff (Platform -> Int -> Int
roundUpToWords Platform
platform Int
bytes)
padding_bytes :: ByteOff
padding_bytes
| Bool
padded = ByteOff -> ByteOff
round_to_words ByteOff
size_bytes forall a. Num a => a -> a -> a
- ByteOff
size_bytes
| Bool
otherwise = ByteOff
0
(OrdList BCInstr
padding_instr, ByteOff
_) = ByteOff -> (OrdList BCInstr, ByteOff)
pushPadding ByteOff
padding_bytes
instr :: BCInstr
instr =
case ByteOff
size_bytes of
ByteOff
1 -> Literal -> BCInstr
PUSH_UBX8 Literal
lit
ByteOff
2 -> Literal -> BCInstr
PUSH_UBX16 Literal
lit
ByteOff
4 -> Literal -> BCInstr
PUSH_UBX32 Literal
lit
ByteOff
_ -> Literal -> Word16 -> BCInstr
PUSH_UBX Literal
lit (WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
size_bytes)
case Literal
lit of
LitLabel {} -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
AddrRep
LitFloat {} -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
FloatRep
LitDouble {} -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
DoubleRep
LitChar {} -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
WordRep
Literal
LitNullAddr -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
AddrRep
LitString {} -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
AddrRep
LitRubbish {} -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
WordRep
LitNumber LitNumType
nt Integer
_ -> case LitNumType
nt of
LitNumType
LitNumInt -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
IntRep
LitNumType
LitNumWord -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
WordRep
LitNumType
LitNumInt8 -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Int8Rep
LitNumType
LitNumWord8 -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Word8Rep
LitNumType
LitNumInt16 -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Int16Rep
LitNumType
LitNumWord16 -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Word16Rep
LitNumType
LitNumInt32 -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Int32Rep
LitNumType
LitNumWord32 -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Word32Rep
LitNumType
LitNumInt64 -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Int64Rep
LitNumType
LitNumWord64 -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Word64Rep
LitNumType
LitNumBigNat -> forall a. String -> a
panic String
"pushAtom: LitNumBigNat"
pushConstrAtom
:: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
pushConstrAtom :: ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushConstrAtom ByteOff
_ Map Id ByteOff
_ (StgLitArg Literal
lit) = Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
pushLiteral Bool
False Literal
lit
pushConstrAtom ByteOff
d Map Id ByteOff
p va :: StgArg
va@(StgVarArg Id
v)
| Just ByteOff
d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
v Map Id ByteOff
p = do
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let !szb :: ByteOff
szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
v
done :: (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done Word16 -> BCInstr
instr = do
let !off :: Word16
off = ByteOff -> Word16
trunc16B forall a b. (a -> b) -> a -> b
$ ByteOff
d forall a. Num a => a -> a -> a
- ByteOff
d_v
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
instr Word16
off), ByteOff
szb)
case ByteOff
szb of
ByteOff
1 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done Word16 -> BCInstr
PUSH8
ByteOff
2 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done Word16 -> BCInstr
PUSH16
ByteOff
4 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done Word16 -> BCInstr
PUSH32
ByteOff
_ -> ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
va
pushConstrAtom ByteOff
d Map Id ByteOff
p StgArg
expr = ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
expr
pushPadding :: ByteOff -> (BCInstrList, ByteOff)
pushPadding :: ByteOff -> (OrdList BCInstr, ByteOff)
pushPadding (ByteOff Int
n) = forall {t} {b}.
(Eq t, Num t, Num b) =>
t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go Int
n (forall a. OrdList a
nilOL, ByteOff
0)
where
go :: t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go t
n acc :: (OrdList BCInstr, b)
acc@(!OrdList BCInstr
instrs, !b
off) = case t
n of
t
0 -> (OrdList BCInstr, b)
acc
t
1 -> (OrdList BCInstr
instrs forall a. Monoid a => a -> a -> a
`mappend` forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD8, b
off forall a. Num a => a -> a -> a
+ b
1)
t
2 -> (OrdList BCInstr
instrs forall a. Monoid a => a -> a -> a
`mappend` forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD16, b
off forall a. Num a => a -> a -> a
+ b
2)
t
3 -> t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go t
1 (t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go t
2 (OrdList BCInstr, b)
acc)
t
4 -> (OrdList BCInstr
instrs forall a. Monoid a => a -> a -> a
`mappend` forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD32, b
off forall a. Num a => a -> a -> a
+ b
4)
t
_ -> t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go (t
n forall a. Num a => a -> a -> a
- t
4) (t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go t
4 (OrdList BCInstr, b)
acc)
mkMultiBranch :: Maybe Int
-> [(Discr, BCInstrList)]
-> BcM BCInstrList
mkMultiBranch :: Maybe Int -> [(Discr, OrdList BCInstr)] -> BcM (OrdList BCInstr)
mkMultiBranch Maybe Int
maybe_ncons [(Discr, OrdList BCInstr)]
raw_ways = do
LocalLabel
lbl_default <- BcM LocalLabel
getLabelBc
let
mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree :: [(Discr, OrdList BCInstr)]
-> Discr -> Discr -> BcM (OrdList BCInstr)
mkTree [] Discr
_range_lo Discr
_range_hi = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (LocalLabel -> BCInstr
JMP LocalLabel
lbl_default))
mkTree [(Discr, OrdList BCInstr)
val] Discr
range_lo Discr
range_hi
| Discr
range_lo forall a. Eq a => a -> a -> Bool
== Discr
range_hi
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a, b) -> b
snd (Discr, OrdList BCInstr)
val)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, OrdList BCInstr)]
defaults
= do LocalLabel
lbl <- BcM LocalLabel
getLabelBc
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testEQ (forall a b. (a, b) -> a
fst (Discr, OrdList BCInstr)
val) LocalLabel
lbl
forall a. a -> OrdList a -> OrdList a
`consOL` (forall a b. (a, b) -> b
snd (Discr, OrdList BCInstr)
val
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (LocalLabel -> BCInstr
LABEL LocalLabel
lbl forall a. a -> OrdList a -> OrdList a
`consOL` forall a. a -> OrdList a
unitOL BCInstr
CASEFAIL)))
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testEQ (forall a b. (a, b) -> a
fst (Discr, OrdList BCInstr)
val) LocalLabel
lbl_default forall a. a -> OrdList a -> OrdList a
`consOL` forall a b. (a, b) -> b
snd (Discr, OrdList BCInstr)
val)
mkTree [(Discr, OrdList BCInstr)]
vals Discr
range_lo Discr
range_hi
= let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Discr, OrdList BCInstr)]
vals forall a. Integral a => a -> a -> a
`div` Int
2
vals_lo :: [(Discr, OrdList BCInstr)]
vals_lo = forall a. Int -> [a] -> [a]
take Int
n [(Discr, OrdList BCInstr)]
vals
vals_hi :: [(Discr, OrdList BCInstr)]
vals_hi = forall a. Int -> [a] -> [a]
drop Int
n [(Discr, OrdList BCInstr)]
vals
v_mid :: Discr
v_mid = forall a b. (a, b) -> a
fst (forall a. [a] -> a
head [(Discr, OrdList BCInstr)]
vals_hi)
in do
LocalLabel
label_geq <- BcM LocalLabel
getLabelBc
OrdList BCInstr
code_lo <- [(Discr, OrdList BCInstr)]
-> Discr -> Discr -> BcM (OrdList BCInstr)
mkTree [(Discr, OrdList BCInstr)]
vals_lo Discr
range_lo (Discr -> Discr
dec Discr
v_mid)
OrdList BCInstr
code_hi <- [(Discr, OrdList BCInstr)]
-> Discr -> Discr -> BcM (OrdList BCInstr)
mkTree [(Discr, OrdList BCInstr)]
vals_hi Discr
v_mid Discr
range_hi
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testLT Discr
v_mid LocalLabel
label_geq
forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList BCInstr
code_lo
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. a -> OrdList a
unitOL (LocalLabel -> BCInstr
LABEL LocalLabel
label_geq)
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
code_hi))
the_default :: OrdList BCInstr
the_default
= case [(Discr, OrdList BCInstr)]
defaults of
[] -> forall a. OrdList a
nilOL
[(Discr
_, OrdList BCInstr
def)] -> LocalLabel -> BCInstr
LABEL LocalLabel
lbl_default forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
def
[(Discr, OrdList BCInstr)]
_ -> forall a. String -> a
panic String
"mkMultiBranch/the_default"
OrdList BCInstr
instrs <- [(Discr, OrdList BCInstr)]
-> Discr -> Discr -> BcM (OrdList BCInstr)
mkTree [(Discr, OrdList BCInstr)]
notd_ways Discr
init_lo Discr
init_hi
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
instrs forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
the_default)
where
([(Discr, OrdList BCInstr)]
defaults, [(Discr, OrdList BCInstr)]
not_defaults) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Discr -> Bool
isNoDiscrforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) [(Discr, OrdList BCInstr)]
raw_ways
notd_ways :: [(Discr, OrdList BCInstr)]
notd_ways = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) [(Discr, OrdList BCInstr)]
not_defaults
testLT :: Discr -> LocalLabel -> BCInstr
testLT (DiscrI Int
i) LocalLabel
fail_label = Int -> LocalLabel -> BCInstr
TESTLT_I Int
i LocalLabel
fail_label
testLT (DiscrI8 Int8
i) LocalLabel
fail_label = Int8 -> LocalLabel -> BCInstr
TESTLT_I8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
i) LocalLabel
fail_label
testLT (DiscrI16 Int16
i) LocalLabel
fail_label = Int16 -> LocalLabel -> BCInstr
TESTLT_I16 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i) LocalLabel
fail_label
testLT (DiscrI32 Int32
i) LocalLabel
fail_label = Int32 -> LocalLabel -> BCInstr
TESTLT_I32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i) LocalLabel
fail_label
testLT (DiscrI64 Int64
i) LocalLabel
fail_label = Int64 -> LocalLabel -> BCInstr
TESTLT_I64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i) LocalLabel
fail_label
testLT (DiscrW Word
i) LocalLabel
fail_label = Word -> LocalLabel -> BCInstr
TESTLT_W Word
i LocalLabel
fail_label
testLT (DiscrW8 Word8
i) LocalLabel
fail_label = Word8 -> LocalLabel -> BCInstr
TESTLT_W8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i) LocalLabel
fail_label
testLT (DiscrW16 Word16
i) LocalLabel
fail_label = Word16 -> LocalLabel -> BCInstr
TESTLT_W16 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i) LocalLabel
fail_label
testLT (DiscrW32 Word32
i) LocalLabel
fail_label = Word32 -> LocalLabel -> BCInstr
TESTLT_W32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i) LocalLabel
fail_label
testLT (DiscrW64 Word64
i) LocalLabel
fail_label = Word64 -> LocalLabel -> BCInstr
TESTLT_W64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) LocalLabel
fail_label
testLT (DiscrF Float
i) LocalLabel
fail_label = Float -> LocalLabel -> BCInstr
TESTLT_F Float
i LocalLabel
fail_label
testLT (DiscrD Double
i) LocalLabel
fail_label = Double -> LocalLabel -> BCInstr
TESTLT_D Double
i LocalLabel
fail_label
testLT (DiscrP Word16
i) LocalLabel
fail_label = Word16 -> LocalLabel -> BCInstr
TESTLT_P Word16
i LocalLabel
fail_label
testLT Discr
NoDiscr LocalLabel
_ = forall a. String -> a
panic String
"mkMultiBranch NoDiscr"
testEQ :: Discr -> LocalLabel -> BCInstr
testEQ (DiscrI Int
i) LocalLabel
fail_label = Int -> LocalLabel -> BCInstr
TESTEQ_I Int
i LocalLabel
fail_label
testEQ (DiscrI8 Int8
i) LocalLabel
fail_label = Int16 -> LocalLabel -> BCInstr
TESTEQ_I8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
i) LocalLabel
fail_label
testEQ (DiscrI16 Int16
i) LocalLabel
fail_label = Int16 -> LocalLabel -> BCInstr
TESTEQ_I16 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i) LocalLabel
fail_label
testEQ (DiscrI32 Int32
i) LocalLabel
fail_label = Int32 -> LocalLabel -> BCInstr
TESTEQ_I32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i) LocalLabel
fail_label
testEQ (DiscrI64 Int64
i) LocalLabel
fail_label = Int64 -> LocalLabel -> BCInstr
TESTEQ_I64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i) LocalLabel
fail_label
testEQ (DiscrW Word
i) LocalLabel
fail_label = Word -> LocalLabel -> BCInstr
TESTEQ_W Word
i LocalLabel
fail_label
testEQ (DiscrW8 Word8
i) LocalLabel
fail_label = Word8 -> LocalLabel -> BCInstr
TESTEQ_W8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i) LocalLabel
fail_label
testEQ (DiscrW16 Word16
i) LocalLabel
fail_label = Word16 -> LocalLabel -> BCInstr
TESTEQ_W16 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i) LocalLabel
fail_label
testEQ (DiscrW32 Word32
i) LocalLabel
fail_label = Word32 -> LocalLabel -> BCInstr
TESTEQ_W32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i) LocalLabel
fail_label
testEQ (DiscrW64 Word64
i) LocalLabel
fail_label = Word64 -> LocalLabel -> BCInstr
TESTEQ_W64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) LocalLabel
fail_label
testEQ (DiscrF Float
i) LocalLabel
fail_label = Float -> LocalLabel -> BCInstr
TESTEQ_F Float
i LocalLabel
fail_label
testEQ (DiscrD Double
i) LocalLabel
fail_label = Double -> LocalLabel -> BCInstr
TESTEQ_D Double
i LocalLabel
fail_label
testEQ (DiscrP Word16
i) LocalLabel
fail_label = Word16 -> LocalLabel -> BCInstr
TESTEQ_P Word16
i LocalLabel
fail_label
testEQ Discr
NoDiscr LocalLabel
_ = forall a. String -> a
panic String
"mkMultiBranch NoDiscr"
(Discr
init_lo, Discr
init_hi)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, OrdList BCInstr)]
notd_ways
= forall a. String -> a
panic String
"mkMultiBranch: awesome foursome"
| Bool
otherwise
= case forall a b. (a, b) -> a
fst (forall a. [a] -> a
head [(Discr, OrdList BCInstr)]
notd_ways) of
DiscrI Int
_ -> ( Int -> Discr
DiscrI forall a. Bounded a => a
minBound, Int -> Discr
DiscrI forall a. Bounded a => a
maxBound )
DiscrI8 Int8
_ -> ( Int8 -> Discr
DiscrI8 forall a. Bounded a => a
minBound, Int8 -> Discr
DiscrI8 forall a. Bounded a => a
maxBound )
DiscrI16 Int16
_ -> ( Int16 -> Discr
DiscrI16 forall a. Bounded a => a
minBound, Int16 -> Discr
DiscrI16 forall a. Bounded a => a
maxBound )
DiscrI32 Int32
_ -> ( Int32 -> Discr
DiscrI32 forall a. Bounded a => a
minBound, Int32 -> Discr
DiscrI32 forall a. Bounded a => a
maxBound )
DiscrI64 Int64
_ -> ( Int64 -> Discr
DiscrI64 forall a. Bounded a => a
minBound, Int64 -> Discr
DiscrI64 forall a. Bounded a => a
maxBound )
DiscrW Word
_ -> ( Word -> Discr
DiscrW forall a. Bounded a => a
minBound, Word -> Discr
DiscrW forall a. Bounded a => a
maxBound )
DiscrW8 Word8
_ -> ( Word8 -> Discr
DiscrW8 forall a. Bounded a => a
minBound, Word8 -> Discr
DiscrW8 forall a. Bounded a => a
maxBound )
DiscrW16 Word16
_ -> ( Word16 -> Discr
DiscrW16 forall a. Bounded a => a
minBound, Word16 -> Discr
DiscrW16 forall a. Bounded a => a
maxBound )
DiscrW32 Word32
_ -> ( Word32 -> Discr
DiscrW32 forall a. Bounded a => a
minBound, Word32 -> Discr
DiscrW32 forall a. Bounded a => a
maxBound )
DiscrW64 Word64
_ -> ( Word64 -> Discr
DiscrW64 forall a. Bounded a => a
minBound, Word64 -> Discr
DiscrW64 forall a. Bounded a => a
maxBound )
DiscrF Float
_ -> ( Float -> Discr
DiscrF Float
minF, Float -> Discr
DiscrF Float
maxF )
DiscrD Double
_ -> ( Double -> Discr
DiscrD Double
minD, Double -> Discr
DiscrD Double
maxD )
DiscrP Word16
_ -> ( Word16 -> Discr
DiscrP Word16
algMinBound, Word16 -> Discr
DiscrP Word16
algMaxBound )
Discr
NoDiscr -> forall a. String -> a
panic String
"mkMultiBranch NoDiscr"
(Word16
algMinBound, Word16
algMaxBound)
= case Maybe Int
maybe_ncons of
Just Int
n -> (Word16
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Num a => a -> a -> a
- Word16
1)
Maybe Int
Nothing -> (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound)
isNoDiscr :: Discr -> Bool
isNoDiscr Discr
NoDiscr = Bool
True
isNoDiscr Discr
_ = Bool
False
dec :: Discr -> Discr
dec (DiscrI Int
i) = Int -> Discr
DiscrI (Int
iforall a. Num a => a -> a -> a
-Int
1)
dec (DiscrW Word
w) = Word -> Discr
DiscrW (Word
wforall a. Num a => a -> a -> a
-Word
1)
dec (DiscrP Word16
i) = Word16 -> Discr
DiscrP (Word16
iforall a. Num a => a -> a -> a
-Word16
1)
dec Discr
other = Discr
other
minF, maxF :: Float
minD, maxD :: Double
minF :: Float
minF = -Float
1.0e37
maxF :: Float
maxF = Float
1.0e37
minD :: Double
minD = -Double
1.0e308
maxD :: Double
maxD = Double
1.0e308
data Discr
= DiscrI Int
| DiscrI8 Int8
| DiscrI16 Int16
| DiscrI32 Int32
| DiscrI64 Int64
| DiscrW Word
| DiscrW8 Word8
| DiscrW16 Word16
| DiscrW32 Word32
| DiscrW64 Word64
| DiscrF Float
| DiscrD Double
| DiscrP Word16
| NoDiscr
deriving (Discr -> Discr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Discr -> Discr -> Bool
$c/= :: Discr -> Discr -> Bool
== :: Discr -> Discr -> Bool
$c== :: Discr -> Discr -> Bool
Eq, Eq Discr
Discr -> Discr -> Bool
Discr -> Discr -> Ordering
Discr -> Discr -> Discr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Discr -> Discr -> Discr
$cmin :: Discr -> Discr -> Discr
max :: Discr -> Discr -> Discr
$cmax :: Discr -> Discr -> Discr
>= :: Discr -> Discr -> Bool
$c>= :: Discr -> Discr -> Bool
> :: Discr -> Discr -> Bool
$c> :: Discr -> Discr -> Bool
<= :: Discr -> Discr -> Bool
$c<= :: Discr -> Discr -> Bool
< :: Discr -> Discr -> Bool
$c< :: Discr -> Discr -> Bool
compare :: Discr -> Discr -> Ordering
$ccompare :: Discr -> Discr -> Ordering
Ord)
instance Outputable Discr where
ppr :: Discr -> SDoc
ppr (DiscrI Int
i) = Int -> SDoc
int Int
i
ppr (DiscrI8 Int8
i) = String -> SDoc
text (forall a. Show a => a -> String
show Int8
i)
ppr (DiscrI16 Int16
i) = String -> SDoc
text (forall a. Show a => a -> String
show Int16
i)
ppr (DiscrI32 Int32
i) = String -> SDoc
text (forall a. Show a => a -> String
show Int32
i)
ppr (DiscrI64 Int64
i) = String -> SDoc
text (forall a. Show a => a -> String
show Int64
i)
ppr (DiscrW Word
w) = String -> SDoc
text (forall a. Show a => a -> String
show Word
w)
ppr (DiscrW8 Word8
w) = String -> SDoc
text (forall a. Show a => a -> String
show Word8
w)
ppr (DiscrW16 Word16
w) = String -> SDoc
text (forall a. Show a => a -> String
show Word16
w)
ppr (DiscrW32 Word32
w) = String -> SDoc
text (forall a. Show a => a -> String
show Word32
w)
ppr (DiscrW64 Word64
w) = String -> SDoc
text (forall a. Show a => a -> String
show Word64
w)
ppr (DiscrF Float
f) = String -> SDoc
text (forall a. Show a => a -> String
show Float
f)
ppr (DiscrD Double
d) = String -> SDoc
text (forall a. Show a => a -> String
show Double
d)
ppr (DiscrP Word16
i) = forall a. Outputable a => a -> SDoc
ppr Word16
i
ppr Discr
NoDiscr = String -> SDoc
text String
"DEF"
lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe :: Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
idSizeW :: Platform -> Id -> WordOff
idSizeW :: Platform -> Id -> WordOff
idSizeW Platform
platform = Int -> WordOff
WordOff forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> ArgRep -> Int
argRepSizeW Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> ArgRep
bcIdArgRep Platform
platform
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
| Kind -> Bool
isUnboxedTupleType (Id -> Kind
idType Id
var) Bool -> Bool -> Bool
||
Kind -> Bool
isUnboxedSumType (Id -> Kind
idType Id
var) =
Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Int -> WordOff
WordOff forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Platform -> ArgRep -> Int
argRepSizeW Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> PrimRep -> ArgRep
toArgRep Platform
platform) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Id -> [PrimRep]
bcIdPrimReps forall a b. (a -> b) -> a -> b
$ Id
var
| Bool
otherwise = Int -> ByteOff
ByteOff (Platform -> PrimRep -> Int
primRepSizeB Platform
platform (Id -> PrimRep
bcIdPrimRep Id
var))
bcIdArgRep :: Platform -> Id -> ArgRep
bcIdArgRep :: Platform -> Id -> ArgRep
bcIdArgRep Platform
platform = Platform -> PrimRep -> ArgRep
toArgRep Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
bcIdPrimRep
bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep Id
id
| [PrimRep
rep] <- HasDebugCallStack => Kind -> [PrimRep]
typePrimRepArgs (Id -> Kind
idType Id
id)
= PrimRep
rep
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"bcIdPrimRep" (forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
id))
bcIdPrimReps :: Id -> [PrimRep]
bcIdPrimReps :: Id -> [PrimRep]
bcIdPrimReps Id
id = HasDebugCallStack => Kind -> [PrimRep]
typePrimRepArgs (Id -> Kind
idType Id
id)
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords Platform
platform PrimRep
rep = Int -> WordOff
WordOff forall a b. (a -> b) -> a -> b
$ Platform -> ArgRep -> Int
argRepSizeW Platform
platform (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep)
isFollowableArg :: ArgRep -> Bool
isFollowableArg :: ArgRep -> Bool
isFollowableArg ArgRep
P = Bool
True
isFollowableArg ArgRep
_ = Bool
False
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv (CCallSpec CCallTarget
_ CCallConv
cconv Safety
_) = case CCallConv
cconv of
CCallConv
CCallConv -> Bool
True
CCallConv
StdCallConv -> Bool
True
CCallConv
PrimCallConv -> Bool
True
CCallConv
JavaScriptCallConv -> Bool
False
CCallConv
CApiConv -> Bool
True
unsupportedCConvException :: a
unsupportedCConvException :: forall a. a
unsupportedCConvException = forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError
(String
"Error: bytecode compiler can't handle some foreign calling conventions\n"forall a. [a] -> [a] -> [a]
++
String
" Workaround: use -fobject-code, or compile this module to .o separately."))
mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB Platform
platform !ByteOff
nb !ByteOff
db = Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
n WordOff
d
where
!n :: Word16
n = WordOff -> Word16
trunc16W forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
nb
!d :: WordOff
d = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
db
mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
mkSlideW !Word16
n !WordOff
ws
| WordOff
ws forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
limit
= Word16 -> Word16 -> BCInstr
SLIDE Word16
n Word16
limit forall a. a -> OrdList a -> OrdList a
`consOL` Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
n (WordOff
ws forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
limit)
| WordOff
ws forall a. Eq a => a -> a -> Bool
== WordOff
0
= forall a. OrdList a
nilOL
| Bool
otherwise
= forall a. a -> OrdList a
unitOL (Word16 -> Word16 -> BCInstr
SLIDE Word16
n forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
ws)
where
limit :: Word16
limit :: Word16
limit = forall a. Bounded a => a
maxBound
atomPrimRep :: StgArg -> PrimRep
atomPrimRep :: StgArg -> PrimRep
atomPrimRep (StgVarArg Id
v) = Id -> PrimRep
bcIdPrimRep Id
v
atomPrimRep (StgLitArg Literal
l) = HasDebugCallStack => Kind -> PrimRep
typePrimRep1 (Literal -> Kind
literalType Literal
l)
atomRep :: Platform -> StgArg -> ArgRep
atomRep :: Platform -> StgArg -> ArgRep
atomRep Platform
platform StgArg
e = Platform -> PrimRep -> ArgRep
toArgRep Platform
platform (StgArg -> PrimRep
atomPrimRep StgArg
e)
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
original_depth [ByteOff]
szsb = forall a. [a] -> [a]
tail (forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl' forall a. Num a => a -> a -> a
(+) ByteOff
original_depth [ByteOff]
szsb)
typeArgReps :: Platform -> Type -> [ArgRep]
typeArgReps :: Platform -> Kind -> [ArgRep]
typeArgReps Platform
platform = forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Kind -> [PrimRep]
typePrimRepArgs
data BcM_State
= BcM_State
{ BcM_State -> HscEnv
bcm_hsc_env :: HscEnv
, BcM_State -> Module
thisModule :: Module
, BcM_State -> Word32
nextlabel :: Word32
, BcM_State -> [FFIInfo]
ffis :: [FFIInfo]
, BcM_State -> Maybe ModBreaks
modBreaks :: Maybe ModBreaks
, BcM_State -> IntMap CgBreakInfo
breakInfo :: IntMap CgBreakInfo
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (forall a b. a -> BcM b -> BcM a
forall a b. (a -> b) -> BcM a -> BcM 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 -> BcM b -> BcM a
$c<$ :: forall a b. a -> BcM b -> BcM a
fmap :: forall a b. (a -> b) -> BcM a -> BcM b
$cfmap :: forall a b. (a -> b) -> BcM a -> BcM b
Functor)
ioToBc :: IO a -> BcM a
ioToBc :: forall a. IO a -> BcM a
ioToBc IO a
io = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> do
a
x <- IO a
io
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, a
x)
runBc :: HscEnv -> Module -> Maybe ModBreaks
-> BcM r
-> IO (BcM_State, r)
runBc :: forall r.
HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (BcM_State, r)
runBc HscEnv
hsc_env Module
this_mod Maybe ModBreaks
modBreaks (BcM BcM_State -> IO (BcM_State, r)
m)
= BcM_State -> IO (BcM_State, r)
m (HscEnv
-> Module
-> Word32
-> [FFIInfo]
-> Maybe ModBreaks
-> IntMap CgBreakInfo
-> BcM_State
BcM_State HscEnv
hsc_env Module
this_mod Word32
0 [] Maybe ModBreaks
modBreaks forall a. IntMap a
IntMap.empty)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc :: forall a b. BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM BcM_State -> IO (BcM_State, a)
expr) a -> BcM b
cont = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st0 -> do
(BcM_State
st1, a
q) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
let BcM BcM_State -> IO (BcM_State, b)
k = a -> BcM b
cont a
q
(BcM_State
st2, b
r) <- BcM_State -> IO (BcM_State, b)
k BcM_State
st1
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st2, b
r)
thenBc_ :: BcM a -> BcM b -> BcM b
thenBc_ :: forall a b. BcM a -> BcM b -> BcM b
thenBc_ (BcM BcM_State -> IO (BcM_State, a)
expr) (BcM BcM_State -> IO (BcM_State, b)
cont) = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st0 -> do
(BcM_State
st1, a
_) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
(BcM_State
st2, b
r) <- BcM_State -> IO (BcM_State, b)
cont BcM_State
st1
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st2, b
r)
returnBc :: a -> BcM a
returnBc :: forall a. a -> BcM a
returnBc a
result = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, a
result))
instance Applicative BcM where
pure :: forall a. a -> BcM a
pure = forall a. a -> BcM a
returnBc
<*> :: forall a b. BcM (a -> b) -> BcM a -> BcM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
*> :: forall a b. BcM a -> BcM b -> BcM b
(*>) = forall a b. BcM a -> BcM b -> BcM b
thenBc_
instance Monad BcM where
>>= :: forall a b. BcM a -> (a -> BcM b) -> BcM b
(>>=) = forall a b. BcM a -> (a -> BcM b) -> BcM b
thenBc
>> :: forall a b. BcM a -> BcM b -> BcM b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
instance HasDynFlags BcM where
getDynFlags :: BcM DynFlags
getDynFlags = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, HscEnv -> DynFlags
hsc_dflags (BcM_State -> HscEnv
bcm_hsc_env BcM_State
st))
getHscEnv :: BcM HscEnv
getHscEnv :: BcM HscEnv
getHscEnv = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> HscEnv
bcm_hsc_env BcM_State
st)
getProfile :: BcM Profile
getProfile :: BcM Profile
getProfile = DynFlags -> Profile
targetProfile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc [FFIInfo] -> ProtoBCO Name
bco
= forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{ffis :: [FFIInfo]
ffis=[]}, [FFIInfo] -> ProtoBCO Name
bco (BcM_State -> [FFIInfo]
ffis BcM_State
st))
recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc RemotePtr C_ffi_cif
a
= forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{ffis :: [FFIInfo]
ffis = RemotePtr C_ffi_cif -> FFIInfo
FFIInfo RemotePtr C_ffi_cif
a forall a. a -> [a] -> [a]
: BcM_State -> [FFIInfo]
ffis BcM_State
st}, ())
getLabelBc :: BcM LocalLabel
getLabelBc :: BcM LocalLabel
getLabelBc
= forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> do let nl :: Word32
nl = BcM_State -> Word32
nextlabel BcM_State
st
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
nl forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound) forall a b. (a -> b) -> a -> b
$
forall a. String -> a
panic String
"getLabelBc: Ran out of labels"
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel :: Word32
nextlabel = Word32
nl forall a. Num a => a -> a -> a
+ Word32
1}, Word32 -> LocalLabel
LocalLabel Word32
nl)
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc Word32
n
= forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> let ctr :: Word32
ctr = BcM_State -> Word32
nextlabel BcM_State
st
in forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel :: Word32
nextlabel = Word32
ctrforall a. Num a => a -> a -> a
+Word32
n}, coerce :: forall a b. Coercible a b => a -> b
coerce [Word32
ctr .. Word32
ctrforall a. Num a => a -> a -> a
+Word32
nforall a. Num a => a -> a -> a
-Word32
1])
getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
getCCArray :: BcM (Array Int (RemotePtr CostCentre))
getCCArray = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st ->
let breaks :: ModBreaks
breaks = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"GHC.StgToByteCode.getCCArray" forall a b. (a -> b) -> a -> b
$ BcM_State -> Maybe ModBreaks
modBreaks BcM_State
st in
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, ModBreaks -> Array Int (RemotePtr CostCentre)
modBreaks_ccs ModBreaks
breaks)
newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
newBreakInfo :: Int -> CgBreakInfo -> BcM ()
newBreakInfo Int
ix CgBreakInfo
info = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st ->
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{breakInfo :: IntMap CgBreakInfo
breakInfo = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
ix CgBreakInfo
info (BcM_State -> IntMap CgBreakInfo
breakInfo BcM_State
st)}, ())
getCurrentModule :: BcM Module
getCurrentModule :: BcM Module
getCurrentModule = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> Module
thisModule BcM_State
st)
tickFS :: FastString
tickFS :: FastString
tickFS = String -> FastString
fsLit String
"ticked"