{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
import GHC.Prelude
import GHC.Driver.DynFlags
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.Reg ( GlobalArgRegs(..) )
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.Core.TyCo.Compare (eqType)
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.Builtin.Uniques
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Exception (evaluate)
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
addIdReps, addArgReps,
assertNonVoidIds, assertNonVoidStgArgs )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
import GHC.Data.FlatBag as FlatBag
import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
import GHC.Types.SptEntry
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 GHC.Unit.Home.ModInfo (lookupHpt)
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 Data.Either ( partitionEithers )
import GHC.Stg.Syntax
import qualified Data.IntSet as IntSet
import GHC.CoreToIface
byteCodeGen :: HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> [SptEntry]
-> IO CompiledByteCode
byteCodeGen :: HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> [SptEntry]
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod [CgStgTopBinding]
binds [TyCon]
tycs Maybe ModBreaks
mb_modBreaks [SptEntry]
spt_entries
= Logger
-> SDoc
-> (CompiledByteCode -> ())
-> IO CompiledByteCode
-> IO CompiledByteCode
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GHC.StgToByteCode"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> CompiledByteCode -> ()
forall a b. a -> b -> a
const ()) (IO CompiledByteCode -> IO CompiledByteCode)
-> IO CompiledByteCode -> IO CompiledByteCode
forall a b. (a -> b) -> a -> b
$ do
let ([(Id, ByteString)]
strings, [GenStgBinding 'CodeGen]
lifted_binds) = [Either (Id, ByteString) (GenStgBinding 'CodeGen)]
-> ([(Id, ByteString)], [GenStgBinding 'CodeGen])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Id, ByteString) (GenStgBinding 'CodeGen)]
-> ([(Id, ByteString)], [GenStgBinding 'CodeGen]))
-> [Either (Id, ByteString) (GenStgBinding 'CodeGen)]
-> ([(Id, ByteString)], [GenStgBinding 'CodeGen])
forall a b. (a -> b) -> a -> b
$ do
bnd <- [CgStgTopBinding]
binds
case bnd of
StgTopLifted GenStgBinding 'CodeGen
bnd -> [GenStgBinding 'CodeGen
-> Either (Id, ByteString) (GenStgBinding 'CodeGen)
forall a b. b -> Either a b
Right GenStgBinding 'CodeGen
bnd]
StgTopStringLit Id
b ByteString
str -> [(Id, ByteString)
-> Either (Id, ByteString) (GenStgBinding 'CodeGen)
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
stringPtrs <- Interp -> [(Id, ByteString)] -> IO AddrEnv
allocateTopStrings Interp
interp [(Id, ByteString)]
strings
(BcM_State{..}, proto_bcos) <-
runBc hsc_env this_mod mb_modBreaks $ do
let flattened_binds = (GenStgBinding 'CodeGen -> [(Id, CgStgRhs)])
-> [GenStgBinding 'CodeGen] -> [(Id, CgStgRhs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenStgBinding 'CodeGen -> [(Id, CgStgRhs)]
GenStgBinding 'CodeGen -> [(BinderP 'CodeGen, CgStgRhs)]
forall {pass :: StgPass}.
GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
flattenBind ([GenStgBinding 'CodeGen] -> [GenStgBinding 'CodeGen]
forall a. [a] -> [a]
reverse [GenStgBinding 'CodeGen]
lifted_binds)
FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds
when (notNull ffis)
(panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
putDumpFileMaybe logger Opt_D_dump_BCOs
"Proto-BCOs" FormatByteCode
(vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
let mod_breaks = case Maybe ModBreaks
modBreaks of
Maybe ModBreaks
Nothing -> Maybe ModBreaks
forall a. Maybe a
Nothing
Just ModBreaks
mb -> ModBreaks -> Maybe ModBreaks
forall a. a -> Maybe a
Just ModBreaks
mb{ modBreaks_breakInfo = breakInfo }
cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs mod_breaks spt_entries
evaluate (seqCompiledByteCode cbc)
return 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) = [(Id, ByteString)] -> ([Id], [ByteString])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, ByteString)]
topStrings
ptrs <- Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (Message [RemotePtr ()] -> IO [RemotePtr ()])
-> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Message [RemotePtr ()]
MallocStrings [ByteString]
strings
return $ mkNameEnv (zipWith mk_entry bndrs ptrs)
where
mk_entry :: a -> RemotePtr () -> (Name, (Name, AddrPtr))
mk_entry a
bndr RemotePtr ()
ptr = let nm :: Name
nm = a -> Name
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 = Int -> ByteOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> ByteOff) -> (WordOff -> Int) -> WordOff -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Platform -> Int
platformWordSizeInBytes Platform
platform) (Int -> Int) -> (WordOff -> Int) -> WordOff -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordOff -> Int
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 Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` (Platform -> Int
platformWordSizeInBytes Platform
platform)
in if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Int -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
q
else String -> SDoc -> WordOff
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToByteCode.bytesToWords"
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bytes=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> 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
-> WordOff
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO :: forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> WordOff
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform name
nm OrdList BCInstr
instrs_ordlist Either [CgStgAlt] CgStgRhs
origin Int
arity WordOff
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 :: Word
protoBCOBitmapSize = WordOff -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
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 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Word
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 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
iNTERP_STACK_CHECK_THRESH
= Word -> BCInstr
STKCHECK Word
stack_usage BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr]
peep_d
| Bool
otherwise
= [BCInstr]
peep_d
stack_usage :: Word
stack_usage = [Word] -> Word
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BCInstr -> Word) -> [BCInstr] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map BCInstr -> Word
bciStackUse [BCInstr]
peep_d)
peep_d :: [BCInstr]
peep_d = [BCInstr] -> [BCInstr]
peep (OrdList BCInstr -> [BCInstr]
forall a. OrdList a -> [a]
fromOL OrdList BCInstr
instrs_ordlist)
peep :: [BCInstr] -> [BCInstr]
peep (PUSH_L WordOff
off1 : PUSH_L WordOff
off2 : PUSH_L WordOff
off3 : [BCInstr]
rest)
= WordOff -> WordOff -> WordOff -> BCInstr
PUSH_LLL WordOff
off1 (WordOff
off2WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-WordOff
1) (WordOff
off3WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-WordOff
2) BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
peep (PUSH_L WordOff
off1 : PUSH_L WordOff
off2 : [BCInstr]
rest)
= WordOff -> WordOff -> BCInstr
PUSH_LL WordOff
off1 (WordOff
off2WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-WordOff
1) BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
peep (BCInstr
i:[BCInstr]
rest)
= BCInstr
i BCInstr -> [BCInstr] -> [BCInstr]
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 Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
| Bool
otherwise = Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate (Platform -> ArgRep -> Int
argRepSizeW Platform
platform ArgRep
rep) Bool
True [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
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 <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])
(Right rhs) 0 0 [] False)
| Bool
otherwise
= [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [] (Id -> Name
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 Type
_) = ([Id]
[BinderP 'CodeGen]
args, CgStgExpr
body)
collect (StgRhsCon CostCentreStack
_cc DataCon
dc ConstructorNumber
cnum [StgTickish]
_ticks [StgArg]
args Type
_typ) = ([], DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> CgStgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> 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 <- BcM Profile
getProfile
let
platform = Profile -> Platform
profilePlatform Profile
profile
all_args = [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
fvs
arity = [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
all_args
szsb_args = (Id -> ByteOff) -> [Id] -> [ByteOff]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (WordOff -> ByteOff) -> (Id -> WordOff) -> Id -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> WordOff
idSizeW Platform
platform) [Id]
all_args
sum_szsb_args = [ByteOff] -> ByteOff
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ByteOff]
szsb_args
p_init = [(Id, ByteOff)] -> Map Id ByteOff
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Id] -> [ByteOff] -> [(Id, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
all_args (ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
0 [ByteOff]
szsb_args))
bits = Platform -> [ArgRep] -> [Bool]
argBits Platform
platform ([ArgRep] -> [ArgRep]
forall a. [a] -> [a]
reverse ((Id -> ArgRep) -> [Id] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Id -> ArgRep
idArgRep Platform
platform) [Id]
all_args))
bitmap_size = [Bool] -> WordOff
forall i a. Num i => [a] -> i
genericLength [Bool]
bits
bitmap = Platform -> [Bool] -> [StgWord]
mkBitmap Platform
platform [Bool]
bits
body_code <- schemeER_wrk sum_szsb_args p_init body
emitBc (mkProtoBCO platform nm body_code (Right original_body)
arity bitmap_size bitmap 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 Module
tick_mod) CgStgExpr
rhs) = do
code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p CgStgExpr
rhs
hsc_env <- getHscEnv
current_mod <- getCurrentModule
mb_current_mod_breaks <- getCurrentModBreaks
case mb_current_mod_breaks of
Maybe ModBreaks
Nothing -> OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList BCInstr
code
Just ModBreaks
current_mod_breaks -> case HscEnv -> Module -> Module -> Maybe ModBreaks -> Maybe ModBreaks
break_info HscEnv
hsc_env Module
tick_mod Module
current_mod Maybe ModBreaks
mb_current_mod_breaks of
Maybe ModBreaks
Nothing -> OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList BCInstr
code
Just ModBreaks {modBreaks_flags :: ModBreaks -> ForeignRef BreakArray
modBreaks_flags = ForeignRef BreakArray
breaks, modBreaks_module :: ModBreaks -> RemotePtr ModuleName
modBreaks_module = RemotePtr ModuleName
tick_mod_ptr, modBreaks_ccs :: ModBreaks -> Array Int (RemotePtr CostCentre)
modBreaks_ccs = Array Int (RemotePtr CostCentre)
cc_arr} -> do
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
let idOffSets = Platform
-> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, WordOff)]
getVarOffSets Platform
platform ByteOff
d Map Id ByteOff
p [Id]
[XTickishId 'TickishPassStg]
fvs
ty_vars = [Type] -> [Id]
tyCoVarsOfTypesWellScoped (Type
XBreakpoint 'TickishPassStg
tick_tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:(Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
[XTickishId 'TickishPassStg]
fvs)
toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
toWord = ((Id, WordOff) -> (Id, Word))
-> Maybe (Id, WordOff) -> Maybe (Id, Word)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Id
i, WordOff
wo) -> (Id
i, WordOff -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
wo))
breakInfo = [Id] -> [Maybe (Id, Word)] -> Type -> CgBreakInfo
dehydrateCgBreakInfo [Id]
ty_vars ((Maybe (Id, WordOff) -> Maybe (Id, Word))
-> [Maybe (Id, WordOff)] -> [Maybe (Id, Word)]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Id, WordOff) -> Maybe (Id, Word)
toWord [Maybe (Id, WordOff)]
idOffSets) Type
XBreakpoint 'TickishPassStg
tick_ty
let info_mod_ptr = ModBreaks -> RemotePtr ModuleName
modBreaks_module ModBreaks
current_mod_breaks
infox <- newBreakInfo breakInfo
let cc | Just Interp
interp <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
, Interp -> Bool
interpreterProfiled Interp
interp
= Array Int (RemotePtr CostCentre)
cc_arr Array Int (RemotePtr CostCentre) -> Int -> RemotePtr CostCentre
forall i e. Ix i => Array i e -> i -> e
! Int
tick_no
| Bool
otherwise = Ptr CostCentre -> RemotePtr CostCentre
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr CostCentre
forall a. Ptr a
nullPtr
let
toW16 a
x = let r :: Word16
r = a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Word16
in if Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
r a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x
then Word16
r
else String -> SDoc -> Word16
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"schemeER_wrk: breakpoint tick/info index too large!" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x)
breakInstr = ForeignRef BreakArray
-> RemotePtr ModuleName
-> Word16
-> RemotePtr ModuleName
-> Word16
-> RemotePtr CostCentre
-> BCInstr
BRK_FUN ForeignRef BreakArray
breaks RemotePtr ModuleName
tick_mod_ptr (Int -> Word16
forall {a}. (Integral a, Outputable a) => a -> Word16
toW16 Int
tick_no) RemotePtr ModuleName
info_mod_ptr (Int -> Word16
forall {a}. (Integral a, Outputable a) => a -> Word16
toW16 Int
infox) RemotePtr CostCentre
cc
return $ breakInstr `consOL` 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
break_info ::
HscEnv ->
Module ->
Module ->
Maybe ModBreaks ->
Maybe ModBreaks
break_info :: HscEnv -> Module -> Module -> Maybe ModBreaks -> Maybe ModBreaks
break_info HscEnv
hsc_env Module
mod Module
current_mod Maybe ModBreaks
current_mod_breaks
| Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
current_mod
= ModBreaks -> Maybe ModBreaks
check_mod_ptr (ModBreaks -> Maybe ModBreaks)
-> Maybe ModBreaks -> Maybe ModBreaks
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ModBreaks
current_mod_breaks
| Just HomeModInfo
hp <- HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
= ModBreaks -> Maybe ModBreaks
check_mod_ptr (HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hp)
| Bool
otherwise
= Maybe ModBreaks
forall a. Maybe a
Nothing
where
check_mod_ptr :: ModBreaks -> Maybe ModBreaks
check_mod_ptr ModBreaks
mb
| RemotePtr ModuleName
mod_ptr <- ModBreaks -> RemotePtr ModuleName
modBreaks_module ModBreaks
mb
, RemotePtr ModuleName -> Ptr ModuleName
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ModuleName
mod_ptr Ptr ModuleName -> Ptr ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr ModuleName
forall a. Ptr a
nullPtr
= ModBreaks -> Maybe ModBreaks
forall a. a -> Maybe a
Just ModBreaks
mb
| Bool
otherwise
= Maybe ModBreaks
forall a. Maybe a
Nothing
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
getVarOffSets :: Platform
-> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, WordOff)]
getVarOffSets Platform
platform ByteOff
depth Map Id ByteOff
env = (Id -> Maybe (Id, WordOff)) -> [Id] -> [Maybe (Id, WordOff)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Maybe (Id, WordOff)
getOffSet
where
getOffSet :: Id -> Maybe (Id, WordOff)
getOffSet Id
id = case Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
id Map Id ByteOff
env of
Maybe ByteOff
Nothing -> Maybe (Id, WordOff)
forall a. Maybe a
Nothing
Just ByteOff
offset ->
let !var_depth_ws :: WordOff
var_depth_ws = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
depth ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
offset) WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
2
in (Id, WordOff) -> Maybe (Id, WordOff)
forall a. a -> Maybe a
Just (Id
id, WordOff
var_depth_ws)
fvsToEnv :: BCEnv -> CgStgRhs -> [Id]
fvsToEnv :: Map Id ByteOff -> CgStgRhs -> [Id]
fvsToEnv Map Id ByteOff
p CgStgRhs
rhs = [Id
v | Id
v <- DIdSet -> [Id]
dVarSetElems (DIdSet -> [Id]) -> DIdSet -> [Id]
forall a b. (a -> b) -> a -> b
$ CgStgRhs -> DIdSet
forall (pass :: StgPass).
(XRhsClosure pass ~ DIdSet) =>
GenStgRhs pass -> DIdSet
freeVarsOfRhs CgStgRhs
rhs,
Id
v Id -> Map Id ByteOff -> Bool
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 = StgArg -> [PrimRep]
stgArgRep StgArg
e
(push, szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
e
ret <- returnUnliftedReps d s szb reps
return (push `appOL` 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 <- BcM Profile
getProfile
let platform = Profile -> Platform
profilePlatform Profile
profile
ret <- case reps of
[] -> OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (BCInstr -> OrdList BCInstr) -> BCInstr -> OrdList BCInstr
forall a b. (a -> b) -> a -> b
$ ArgRep -> BCInstr
RETURN ArgRep
V)
[PrimRep
rep] -> OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (BCInstr -> OrdList BCInstr) -> BCInstr -> OrdList BCInstr
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) = Profile
-> NativeCallType
-> ByteOff
-> (PrimRep -> PrimRep)
-> [PrimRep]
-> (NativeCallInfo, [(PrimRep, ByteOff)])
forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> PrimRep)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile NativeCallType
NativeTupleReturn ByteOff
0 PrimRep -> PrimRep
forall a. a -> a
id [PrimRep]
nv_reps
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)
return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`
PUSH_BCO tuple_bco `consOL`
unitOL RETURN_TUPLE
return ( mkSlideB platform szb (d - s)
`consOL` 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 <- BcM Profile
getProfile
let platform = Profile -> Platform
profilePlatform Profile
profile
(call_info, tuple_components) = layoutNativeCall profile
NativeTupleReturn
d
stgArgRepU
es
go ByteOff
_ [OrdList BCInstr]
pushes [] = [OrdList BCInstr] -> BcM [OrdList BCInstr]
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList BCInstr] -> [OrdList BCInstr]
forall a. [a] -> [a]
reverse [OrdList BCInstr]
pushes)
go !ByteOff
dd [OrdList BCInstr]
pushes ((StgArg
a, ByteOff
off):[(StgArg, ByteOff)]
cs) = do (push, szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p StgArg
a
massert (off == dd + szb)
go (dd + szb) (push:pushes) cs
pushes <- go d [] tuple_components
ret <- returnUnliftedReps d
s
(wordsToBytes platform $ nativeCallSize call_info)
(map stgArgRepU es)
return (mconcat pushes `appOL` 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 => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
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 (XLet 'CodeGen -> GenStgBinding 'CodeGen -> CgStgExpr -> CgStgExpr
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLetNoEscape 'CodeGen
XLet '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 Type
_typ))
CgStgExpr
body)
= do
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 <- targetPlatform <$> getDynFlags
let !d2 = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform
body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLet XLet 'CodeGen
_ext GenStgBinding 'CodeGen
binds CgStgExpr
body) = do
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let (xs,rhss) = case binds of StgNonRec BinderP 'CodeGen
x CgStgRhs
rhs -> ([Id
BinderP 'CodeGen
x],[CgStgRhs
rhs])
StgRec [(BinderP 'CodeGen, CgStgRhs)]
xs_n_rhss -> [(Id, CgStgRhs)] -> ([Id], [CgStgRhs])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CgStgRhs)]
[(BinderP 'CodeGen, CgStgRhs)]
xs_n_rhss
n_binds = [Id] -> WordOff
forall i a. Num i => [a] -> i
genericLength [Id]
xs
fvss = (CgStgRhs -> [Id]) -> [CgStgRhs] -> [[Id]]
forall a b. (a -> b) -> [a] -> [b]
map (Map Id ByteOff -> CgStgRhs -> [Id]
fvsToEnv Map Id ByteOff
p') [CgStgRhs]
rhss
size_w = Platform -> Id -> WordOff
idSizeW Platform
platform
sizes = ([Id] -> WordOff) -> [[Id]] -> [WordOff]
forall a b. (a -> b) -> [a] -> [b]
map (\[Id]
rhs_fvs -> [WordOff] -> WordOff
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Id -> WordOff) -> [Id] -> [WordOff]
forall a b. (a -> b) -> [a] -> [b]
map Id -> WordOff
size_w [Id]
rhs_fvs)) [[Id]]
fvss
arities = (CgStgRhs -> HalfWord) -> [CgStgRhs] -> [HalfWord]
forall a b. (a -> b) -> [a] -> [b]
map ([Id] -> HalfWord
forall i a. Num i => [a] -> i
genericLength ([Id] -> HalfWord) -> (CgStgRhs -> [Id]) -> CgStgRhs -> HalfWord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], CgStgExpr) -> [Id]
forall a b. (a, b) -> a
fst (([Id], CgStgExpr) -> [Id])
-> (CgStgRhs -> ([Id], CgStgExpr)) -> CgStgRhs -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CgStgRhs -> ([Id], CgStgExpr)
collect) [CgStgRhs]
rhss
offsets = ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
d (WordOff -> ByteOff -> [ByteOff]
forall i a. Integral i => i -> a -> [a]
genericReplicate WordOff
n_binds (Platform -> ByteOff
wordSize Platform
platform))
p' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList ([Id] -> [ByteOff] -> [(Id, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zipE [Id]
xs [ByteOff]
offsets) Map Id ByteOff
p
d' = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
n_binds
zipE = String -> [a] -> [b] -> [(a, b)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"schemeE"
build_thunk
:: StackDepth
-> [Id]
-> WordOff
-> ProtoBCO Name
-> WordOff
-> HalfWord
-> BcM BCInstrList
build_thunk ByteOff
_ [] WordOff
size ProtoBCO Name
bco WordOff
off HalfWord
arity
= OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
bco BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (WordOff -> HalfWord -> BCInstr
mkap (WordOff
offWordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+WordOff
size) (WordOff -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
size)))
where
mkap :: WordOff -> HalfWord -> BCInstr
mkap | HalfWord
arity HalfWord -> HalfWord -> Bool
forall a. Eq a => a -> a -> Bool
== HalfWord
0 = WordOff -> HalfWord -> BCInstr
MKAP
| Bool
otherwise = WordOff -> HalfWord -> BCInstr
MKPAP
build_thunk ByteOff
dd (Id
fv:[Id]
fvs) WordOff
size ProtoBCO Name
bco WordOff
off HalfWord
arity = do
(push_code, pushed_szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p' (Id -> StgArg
StgVarArg Id
fv)
more_push_code <-
build_thunk (dd + pushed_szb) fvs size bco off arity
return (push_code `appOL` more_push_code)
alloc_code = [BCInstr] -> OrdList BCInstr
forall a. [a] -> OrdList a
toOL ((WordOff -> HalfWord -> BCInstr)
-> [WordOff] -> [HalfWord] -> [BCInstr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith WordOff -> HalfWord -> BCInstr
mkAlloc [WordOff]
sizes [HalfWord]
arities)
where mkAlloc :: WordOff -> HalfWord -> BCInstr
mkAlloc WordOff
sz HalfWord
0
| Bool
is_tick = HalfWord -> BCInstr
ALLOC_AP_NOUPD (WordOff -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
sz)
| Bool
otherwise = HalfWord -> BCInstr
ALLOC_AP (WordOff -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
sz)
mkAlloc WordOff
sz HalfWord
arity = HalfWord -> HalfWord -> BCInstr
ALLOC_PAP HalfWord
arity (WordOff -> HalfWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
sz)
is_tick = case GenStgBinding 'CodeGen
binds of
StgNonRec BinderP 'CodeGen
id CgStgRhs
_ -> OccName -> FastString
occNameFS (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
BinderP 'CodeGen
id) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
tickFS
GenStgBinding 'CodeGen
_other -> Bool
False
compile_bind ByteOff
d' [Id]
fvs a
x (CgStgRhs
rhs::CgStgRhs) WordOff
size HalfWord
arity WordOff
off = do
bco <- [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [Id]
fvs (a -> Name
forall a. NamedThing a => a -> Name
getName a
x,CgStgRhs
rhs)
build_thunk d' fvs size bco off arity
compile_binds =
[ ByteOff
-> [Id]
-> Id
-> CgStgRhs
-> WordOff
-> HalfWord
-> WordOff
-> BcM (OrdList BCInstr)
forall {a}.
NamedThing a =>
ByteOff
-> [Id]
-> a
-> CgStgRhs
-> WordOff
-> HalfWord
-> WordOff
-> BcM (OrdList BCInstr)
compile_bind ByteOff
d' [Id]
fvs Id
x CgStgRhs
rhs WordOff
size HalfWord
arity WordOff
n
| ([Id]
fvs, Id
x, CgStgRhs
rhs, WordOff
size, HalfWord
arity, WordOff
n) <-
[[Id]]
-> [Id]
-> [CgStgRhs]
-> [WordOff]
-> [HalfWord]
-> [WordOff]
-> [([Id], Id, CgStgRhs, WordOff, HalfWord, WordOff)]
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 [WordOff]
sizes [HalfWord]
arities [WordOff
n_binds, WordOff
n_bindsWordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-WordOff
1 .. WordOff
1]
]
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
schemeE ByteOff
_d ByteOff
_s Map Id ByteOff
_p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
_ Int
bp_id [XTickishId 'TickishPassStg]
_ Module
_) CgStgExpr
_rhs)
= String -> BcM (OrdList BCInstr)
forall a. HasCallStack => String -> a
panic (String
"schemeE: Breakpoint without let binding: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
forall a. Show a => a -> String
show Int
bp_id String -> String -> String
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 Id
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) Type
_ty) [StgArg]
args Type
result_ty)
= if CCallSpec -> Bool
isSupportedCConv CCallSpec
ccall_spec
then ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Type
-> [StgArg]
-> BcM (OrdList BCInstr)
generateCCall ByteOff
d ByteOff
s Map Id ByteOff
p CCallSpec
ccall_spec Type
result_ty [StgArg]
args
else BcM (OrdList BCInstr)
forall a. a
unsupportedCConvException
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgOpApp (StgPrimOp PrimOp
op) [StgArg]
args Type
_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) ([StgArg] -> [StgArg]
forall a. [a] -> [a]
reverse [StgArg]
args)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgOpApp (StgPrimCallOp (PrimCall FastString
label GenUnit UnitId
unit)) [StgArg]
args Type
result_ty)
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> FastString
-> Maybe (GenUnit UnitId)
-> Type
-> [StgArg]
-> BcM (OrdList BCInstr)
generatePrimCall ByteOff
d ByteOff
s Map Id ByteOff
p FastString
label (GenUnit UnitId -> Maybe (GenUnit UnitId)
forall a. a -> Maybe a
Just GenUnit UnitId
unit) Type
result_ty [StgArg]
args
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgConApp DataCon
con ConstructorNumber
_cn [StgArg]
args [[PrimRep]]
_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 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 <- profilePlatform <$> getProfile
return (alloc_con `appOL`
mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN 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 ([StgArg] -> [StgArg]
forall a. [a] -> [a]
reverse [StgArg]
args)
schemeT ByteOff
_ ByteOff
_ Map Id ByteOff
_ CgStgExpr
e = String -> SDoc -> BcM (OrdList BCInstr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToByteCode.schemeT"
(StgPprOpts -> CgStgExpr -> SDoc
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 <- BcM Profile
getProfile
let platform = Profile -> Platform
profilePlatform Profile
profile
non_voids =
[NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps ([StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs [StgArg]
args)
(_, _, args_offsets) =
mkVirtHeapOffsetsWithPadding profile StdHeader non_voids
do_pushery !ByteOff
d (FieldOffOrPadding StgArg
arg : [FieldOffOrPadding StgArg]
args) = do
(push, arg_bytes) <- case FieldOffOrPadding StgArg
arg of
(Padding Int
l Int
_) -> (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff))
-> (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
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 (NonVoid StgArg -> StgArg
forall a. NonVoid a -> a
fromNonVoid NonVoid StgArg
a)
more_push_code <- do_pushery (d + arg_bytes) args
return (push `appOL` more_push_code)
do_pushery !ByteOff
d [] = do
let !n_arg_words :: WordOff
n_arg_words = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
orig_d)
OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (DataCon -> WordOff -> BCInstr
PACK DataCon
con WordOff
n_arg_words))
do_pushery orig_d (reverse 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 <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
do_pushes init_d args (map (atomRep platform) args)
where
do_pushes :: ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
do_pushes !ByteOff
d [] [ArgRep]
reps = do
Bool -> (() -> BcM ()) -> () -> BcM ()
forall a. HasCallStack => Bool -> a -> a
assert ([ArgRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ArgRep]
reps) () -> BcM ()
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(push_fn, sz) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
fn)
platform <- profilePlatform <$> getProfile
assert (sz == wordSize platform) return ()
let slide = Platform -> ByteOff -> ByteOff -> BCInstr
mkSlideB Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
init_d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform) (ByteOff
init_d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
return (push_fn `appOL` (slide `consOL` unitOL 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) = Int -> [StgArg] -> ([StgArg], [StgArg])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [StgArg]
args
(next_d, push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
push_seq ByteOff
d [StgArg]
these_args
platform <- profilePlatform <$> getProfile
instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps
return (push_code `appOL` (push_apply `consOL` instrs))
push_seq :: ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
push_seq ByteOff
d [] = (ByteOff, OrdList BCInstr) -> BcM (ByteOff, OrdList BCInstr)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
d, OrdList BCInstr
forall a. OrdList a
nilOL)
push_seq ByteOff
d (StgArg
arg:[StgArg]
args) = do
(push_code, sz) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
arg
(final_d, more_push_code) <- push_seq (d + sz) args
return (final_d, push_code `appOL` 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
| (ArgRep -> Bool) -> [ArgRep] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ArgRep -> [ArgRep] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ArgRep
V16, ArgRep
V32, ArgRep
V64]) [ArgRep]
argReps
= String -> (BCInstr, Int, [ArgRep])
forall a. HasCallStack => String -> a
sorry String
"SIMD vector operations are not available in GHCi"
findPushSeq [ArgRep]
_
= String -> (BCInstr, Int, [ArgRep])
forall a. HasCallStack => 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 <- BcM Profile
getProfile
hsc_env <- getHscEnv
let
platform = Profile -> Platform
profilePlatform Profile
profile
non_void_arg_reps = Platform -> Type -> [ArgRep]
typeArgReps Platform
platform Type
bndr_ty
ubx_tuple_frame =
(Type -> Bool
isUnboxedTupleType Type
bndr_ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
bndr_ty) Bool -> Bool -> Bool
&&
[ArgRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ArgRep]
non_void_arg_reps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
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 | Bool
ubx_tuple_frame =
(if Bool
profiling then ByteOff
5 else ByteOff
4) ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
| Bool
otherwise = ByteOff
2 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
save_ccs_size_b | Bool
profiling Bool -> Bool -> Bool
&&
Bool -> Bool
not Bool
ubx_tuple_frame = ByteOff
2 ByteOff -> ByteOff -> ByteOff
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 | Bool
ubx_tuple_frame = Platform -> ByteOff
wordSize Platform
platform
| Bool
otherwise = ByteOff
0
(bndr_size, call_info, args_offsets)
| ubx_tuple_frame =
let bndr_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
bndr)
(call_info, args_offsets) =
layoutNativeCall profile NativeTupleReturn 0 id bndr_reps
in ( wordsToBytes platform (nativeCallSize call_info)
, call_info
, args_offsets
)
| otherwise = ( wordsToBytes platform (idSizeW platform bndr)
, voidTupleReturnInfo
, []
)
d_bndr =
ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
bndr_size
d_alts = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
bndr_size ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
unlifted_itbl_size_b
p_alts = Id -> ByteOff -> Map Id ByteOff -> Map Id ByteOff
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 = Id -> Type
idType Id
bndr
isAlgCase = Type -> Bool
isAlgType Type
bndr_ty
codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)
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 rhs_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts CgStgExpr
rhs
return (NoDiscr, 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}
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
real_bndrs = do
rhs_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts CgStgExpr
rhs
return (my_discr alt, rhs_code)
| Type -> Bool
isUnboxedTupleType Type
bndr_ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
bndr_ty =
let bndr_ty :: NonVoid Id -> PrimRep
bndr_ty = Id -> PrimRep
idPrimRepU (Id -> PrimRep) -> (NonVoid Id -> Id) -> NonVoid Id -> PrimRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid
tuple_start :: ByteOff
tuple_start = ByteOff
d_bndr
(NativeCallInfo
call_info, [(NonVoid Id, ByteOff)]
args_offsets) =
Profile
-> NativeCallType
-> ByteOff
-> (NonVoid Id -> PrimRep)
-> [NonVoid Id]
-> (NativeCallInfo, [(NonVoid Id, ByteOff)])
forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> PrimRep)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile
NativeCallType
NativeTupleReturn
ByteOff
0
NonVoid Id -> PrimRep
bndr_ty
([Id] -> [NonVoid Id]
assertNonVoidIds [Id]
[BinderP 'CodeGen]
bndrs)
stack_bot :: ByteOff
stack_bot = ByteOff
d_alts
p' :: Map Id ByteOff
p' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList
[ (Id
arg, ByteOff
tuple_start ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
-
Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (NativeCallInfo -> WordOff
nativeCallSize NativeCallInfo
call_info) ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+
ByteOff
offset)
| (NonVoid Id
arg, ByteOff
offset) <- [(NonVoid Id, ByteOff)]
args_offsets]
Map Id ByteOff
p_alts
in do
rhs_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' CgStgExpr
rhs
return (NoDiscr, rhs_code)
| Bool
otherwise =
let (Int
tot_wds, Int
_ptrs_wds, [(NonVoid Id, Int)]
args_offsets) =
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (Int, Int, [(NonVoid Id, Int)])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets Profile
profile ClosureHeader
NoHeader
([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps ([Id] -> [NonVoid Id]
assertNonVoidIds [Id]
real_bndrs))
size :: WordOff
size = Int -> WordOff
WordOff Int
tot_wds
stack_bot :: ByteOff
stack_bot = ByteOff
d_alts ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
size
p' :: Map Id ByteOff
p' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList
[ (Id
arg, ByteOff
stack_bot ByteOff -> ByteOff -> ByteOff
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
Bool -> BcM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert Bool
isAlgCase
rhs_code <- ByteOff
-> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' CgStgExpr
rhs
return (my_discr alt,
unitOL (UNPACK size) `appOL` rhs_code)
where
real_bndrs :: [Id]
real_bndrs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Id -> Bool
isTyVar [Id]
[BinderP 'CodeGen]
bndrs
my_discr GenStgAlt pass
alt = case GenStgAlt pass -> AltCon
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 (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DataCon -> Int
dataConTag DataCon
dc Int -> Int -> Int
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 (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumInt8 Integer
i -> Int8 -> Discr
DiscrI8 (Integer -> Int8
forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumInt16 Integer
i -> Int16 -> Discr
DiscrI16 (Integer -> Int16
forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumInt32 Integer
i -> Int32 -> Discr
DiscrI32 (Integer -> Int32
forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumInt64 Integer
i -> Int64 -> Discr
DiscrI64 (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
i)
LitNumber LitNumType
LitNumWord Integer
w -> Word -> Discr
DiscrW (Integer -> Word
forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumWord8 Integer
w -> Word8 -> Discr
DiscrW8 (Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumWord16 Integer
w -> Word16 -> Discr
DiscrW16 (Integer -> Word16
forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumWord32 Integer
w -> Word32 -> Discr
DiscrW32 (Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumWord64 Integer
w -> Word64 -> Discr
DiscrW64 (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
w)
LitNumber LitNumType
LitNumBigNat Integer
_ -> Discr
unsupported
LitFloat Rational
r -> Float -> Discr
DiscrF (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r)
LitDouble Rational
r -> Double -> Discr
DiscrD (Rational -> Double
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 = String -> SDoc -> Discr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"schemeE(StgCase).my_discr:" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
l)
maybe_ncons
| Bool -> Bool
not Bool
isAlgCase = Maybe Int
forall a. Maybe a
Nothing
| Bool
otherwise
= case [DataCon
dc | DataAlt DataCon
dc <- CgStgAlt -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con (CgStgAlt -> AltCon) -> [CgStgAlt] -> [AltCon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CgStgAlt]
alts] of
[] -> Maybe Int
forall a. Maybe a
Nothing
(DataCon
dc:[DataCon]
_) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (TyCon -> Int
tyConFamilySize (DataCon -> TyCon
dataConTyCon DataCon
dc))
(extra_pointers, extra_slots)
| ubx_tuple_frame && profiling = ([1], 3)
| ubx_tuple_frame = ([1], 2)
| otherwise = ([], 0)
bitmap_size :: WordOff
bitmap_size = Int -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
extra_slots WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+
Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
bitmap_size' :: Int
bitmap_size' = WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
bitmap_size
pointers =
[Int]
extra_pointers [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
(Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bitmap_size') ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
extra_slots) [Int]
rel_slots)
where
rel_slots :: [Int]
rel_slots = IntSet -> [Int]
IntSet.toAscList (IntSet -> [Int]) -> IntSet -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> IntSet
IntSet.fromList ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ Map Id Int -> [Int]
forall k a. Map k a -> [a]
Map.elems (Map Id Int -> [Int]) -> Map Id Int -> [Int]
forall a b. (a -> b) -> a -> b
$ (Id -> ByteOff -> Maybe Int) -> Map Id ByteOff -> Map Id Int
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 | Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
id) Bool -> Bool -> Bool
||
Type -> Bool
isUnboxedSumType (Id -> Type
idType Id
id) = Maybe Int
forall a. Maybe a
Nothing
| ArgRep -> Bool
isFollowableArg (Platform -> Id -> ArgRep
idArgRep Platform
platform Id
id) = Int -> Maybe Int
forall a. a -> Maybe a
Just (WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
rel_offset)
| Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
where rel_offset :: WordOff
rel_offset = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
offset)
bitmap = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform Int
bitmap_size' [Int]
pointers
alt_stuff <- mapM codeAlt alts
alt_final0 <- mkMultiBranch maybe_ncons alt_stuff
let alt_final
| Bool
ubx_tuple_frame = WordOff -> WordOff -> BCInstr
SLIDE WordOff
0 WordOff
2 BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
alt_final0
| Bool
otherwise = OrdList BCInstr
alt_final0
let
alt_bco_name = Id -> Name
forall a. NamedThing a => a -> Name
getName Id
bndr
alt_bco = Platform
-> Name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> WordOff
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> WordOff
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
alt_bco_name OrdList BCInstr
alt_final ([CgStgAlt] -> Either [CgStgAlt] CgStgRhs
forall a b. a -> Either a b
Left [CgStgAlt]
alts)
Int
0 WordOff
bitmap_size [StgWord]
bitmap Bool
True
scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
(d + ret_frame_size_b + save_ccs_size_b)
p scrut
alt_bco' <- emitBc alt_bco
if ubx_tuple_frame
then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
`consOL` scrut_code)
else let scrut_rep = case [ArgRep]
non_void_arg_reps of
[] -> ArgRep
V
[ArgRep
rep] -> ArgRep
rep
[ArgRep]
_ -> String -> ArgRep
forall a. HasCallStack => String -> a
panic String
"schemeE(StgCase).push_alts"
in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code)
layoutNativeCall :: Profile
-> NativeCallType
-> ByteOff
-> (a -> PrimRep)
-> [a]
-> ( NativeCallInfo
, [(a, ByteOff)]
)
layoutNativeCall :: forall a.
Profile
-> NativeCallType
-> ByteOff
-> (a -> PrimRep)
-> [a]
-> (NativeCallInfo, [(a, ByteOff)])
layoutNativeCall Profile
profile NativeCallType
call_type ByteOff
start_off a -> PrimRep
arg_rep [a]
reps =
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
arg_ty :: a -> CmmType
arg_ty = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform (PrimRep -> CmmType) -> (a -> PrimRep) -> a -> CmmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PrimRep
arg_rep
(Int
orig_stk_bytes, [(a, ParamLocation)]
pos) = Profile
-> Int
-> Convention
-> (a -> CmmType)
-> [a]
-> (Int, [(a, ParamLocation)])
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, Int -> ByteOff
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 = [(GlobalReg, Int)] -> Map GlobalReg Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(GlobalReg, Int)] -> Map GlobalReg Int)
-> [(GlobalReg, Int)] -> Map GlobalReg Int
forall a b. (a -> b) -> a -> b
$ [GlobalReg] -> [Int] -> [(GlobalReg, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Platform -> GlobalArgRegs -> [GlobalReg]
allArgRegsCover Platform
platform GlobalArgRegs
SCALAR_ARG_REGS) [Int
0..]
reg_order :: GlobalReg -> (Int, GlobalReg)
reg_order :: GlobalReg -> (Int, GlobalReg)
reg_order GlobalReg
reg | Just Int
n <- GlobalReg -> Map GlobalReg Int -> Maybe Int
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 (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)
= [((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a]))
-> [((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a])
forall a b. (a -> b) -> a -> b
$ (((Int, GlobalReg), a) -> ((Int, GlobalReg), a) -> Ordering)
-> [((Int, GlobalReg), a)] -> [((Int, GlobalReg), a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((((Int, GlobalReg), a) -> (Int, GlobalReg))
-> ((Int, GlobalReg), a) -> ((Int, GlobalReg), a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Int, GlobalReg), a) -> (Int, GlobalReg)
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) = Platform
-> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
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 = [GlobalReg] -> RegSet GlobalReg
forall r. Ord r => [r] -> RegSet r
mkRegSet (((Int, GlobalReg) -> GlobalReg)
-> [(Int, GlobalReg)] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map (Int, GlobalReg) -> GlobalReg
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, Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
get_byte_off (a, ParamLocation)
_ =
String -> (a, b)
forall a. HasCallStack => 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)
}
, ((a, ByteOff) -> (a, ByteOff) -> Ordering)
-> [(a, ByteOff)] -> [(a, ByteOff)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((a, ByteOff) -> ByteOff)
-> (a, ByteOff) -> (a, ByteOff) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, ByteOff) -> ByteOff
forall a b. (a, b) -> b
snd) ([(a, ByteOff)] -> [(a, ByteOff)])
-> [(a, ByteOff)] -> [(a, ByteOff)]
forall a b. (a -> b) -> a -> b
$
((a, ByteOff) -> (a, ByteOff)) -> [(a, ByteOff)] -> [(a, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
x, ByteOff
o) -> (a
x, ByteOff
o ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
start_off))
([(a, ByteOff)]
orig_stk_params [(a, ByteOff)] -> [(a, ByteOff)] -> [(a, ByteOff)]
forall a. [a] -> [a] -> [a]
++ ((a, ParamLocation) -> (a, ByteOff))
-> [(a, ParamLocation)] -> [(a, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (a, ParamLocation) -> (a, ByteOff)
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 =
Platform
-> Name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> WordOff
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> WordOff
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
invented_name OrdList BCInstr
body_code ([CgStgAlt] -> Either [CgStgAlt] CgStgRhs
forall a b. a -> Either a b
Left [])
Int
0 WordOff
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
(WordOff
bitmap_size, [StgWord]
bitmap) = Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (WordOff, [StgWord])
mkStackBitmap Platform
platform WordOff
nptrs_prefix NativeCallInfo
args_info [(PrimRep, ByteOff)]
args
body_code :: OrdList BCInstr
body_code = WordOff -> WordOff -> OrdList BCInstr
mkSlideW WordOff
0 WordOff
1
OrdList BCInstr -> BCInstr -> OrdList BCInstr
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 =
Platform
-> Name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> WordOff
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> WordOff
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
invented_name OrdList BCInstr
body_code ([CgStgAlt] -> Either [CgStgAlt] CgStgRhs
forall a b. a -> Either a b
Left [])
Int
0 WordOff
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
(WordOff
bitmap_size, [StgWord]
bitmap) = Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (WordOff, [StgWord])
mkStackBitmap Platform
platform WordOff
nptrs_prefix NativeCallInfo
args_info [(PrimRep, ByteOff)]
args
body_code :: OrdList BCInstr
body_code = BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
CASEFAIL
mkStackBitmap
:: Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (WordOff, [StgWord])
mkStackBitmap :: Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (WordOff, [StgWord])
mkStackBitmap Platform
platform WordOff
nptrs_prefix NativeCallInfo
args_info [(PrimRep, ByteOff)]
args
= (WordOff
bitmap_size, [StgWord]
bitmap)
where
bitmap_size :: WordOff
bitmap_size = WordOff
nptrs_prefix WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
arg_bottom
bitmap :: [StgWord]
bitmap = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform (WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
bitmap_size) [Int]
ptr_offsets
arg_bottom :: WordOff
arg_bottom = NativeCallInfo -> WordOff
nativeCallSize NativeCallInfo
args_info
ptr_offsets :: [Int]
ptr_offsets = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (ByteOff -> Int) -> [ByteOff] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordOff -> Int) -> (ByteOff -> WordOff) -> ByteOff -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteOff -> WordOff
convert_arg_offset)
([ByteOff] -> [Int]) -> [ByteOff] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((PrimRep, ByteOff) -> Maybe ByteOff)
-> [(PrimRep, ByteOff)] -> [ByteOff]
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) = ByteOff -> Maybe ByteOff
forall a. a -> Maybe a
Just ByteOff
byte_offset
| Bool
otherwise = Maybe ByteOff
forall a. Maybe a
Nothing
convert_arg_offset :: ByteOff -> WordOff
convert_arg_offset :: ByteOff -> WordOff
convert_arg_offset ByteOff
arg_offset =
WordOff
nptrs_prefix WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ (WordOff
arg_bottom WordOff -> WordOff -> WordOff
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 (GenUnit UnitId)
-> Type
-> [StgArg]
-> BcM (OrdList BCInstr)
generatePrimCall ByteOff
d ByteOff
s Map Id ByteOff
p FastString
target Maybe (GenUnit UnitId)
_mb_unit Type
_result_ty [StgArg]
args
= do
profile <- BcM Profile
getProfile
let
platform = Profile -> Platform
profilePlatform Profile
profile
non_void PrimOrVoidRep
VoidRep = Bool
False
non_void PrimOrVoidRep
_ = Bool
True
nv_args :: [StgArg]
nv_args = (StgArg -> Bool) -> [StgArg] -> [StgArg]
forall a. (a -> Bool) -> [a] -> [a]
filter (PrimOrVoidRep -> Bool
non_void (PrimOrVoidRep -> Bool)
-> (StgArg -> PrimOrVoidRep) -> StgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> PrimOrVoidRep
stgArgRep1) [StgArg]
args
(args_info, args_offsets) =
layoutNativeCall profile
NativePrimCall
0
stgArgRepU
nv_args
prim_args_offsets = (StgArg -> PrimRep) -> [(StgArg, ByteOff)] -> [(PrimRep, ByteOff)]
forall (f :: * -> *) a c b.
Functor f =>
(a -> c) -> f (a, b) -> f (c, b)
mapFst StgArg -> PrimRep
stgArgRepU [(StgArg, ByteOff)]
args_offsets
shifted_args_offsets = (ByteOff -> ByteOff) -> [(StgArg, ByteOff)] -> [(StgArg, ByteOff)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd (ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
d) [(StgArg, ByteOff)]
args_offsets
push_target = Literal -> WordOff -> BCInstr
PUSH_UBX (FastString -> FunctionOrData -> Literal
LitLabel FastString
target FunctionOrData
IsFunction) WordOff
1
push_info = Literal -> WordOff -> BCInstr
PUSH_UBX (Platform -> NativeCallInfo -> Literal
mkNativeCallInfoLit Platform
platform NativeCallInfo
args_info) WordOff
1
szb = Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (NativeCallInfo -> WordOff
nativeCallSize NativeCallInfo
args_info WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
3)
go ByteOff
_ [OrdList BCInstr]
pushes [] = [OrdList BCInstr] -> BcM [OrdList BCInstr]
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList BCInstr] -> [OrdList BCInstr]
forall a. [a] -> [a]
reverse [OrdList BCInstr]
pushes)
go !ByteOff
dd [OrdList BCInstr]
pushes ((StgArg
a, ByteOff
off):[(StgArg, ByteOff)]
cs) = do (push, szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p StgArg
a
massert (off == dd + szb)
go (dd + szb) (push:pushes) cs
push_args <- go d [] shifted_args_offsets
args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets)
return $ mconcat push_args `appOL`
(push_target `consOL`
push_info `consOL`
PUSH_BCO args_bco `consOL`
(mkSlideB platform szb (d - s) `consOL` unitOL PRIMCALL))
generateCCall
:: StackDepth
-> Sequel
-> BCEnv
-> CCallSpec
-> Type
-> [StgArg]
-> BcM BCInstrList
generateCCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Type
-> [StgArg]
-> BcM (OrdList BCInstr)
generateCCall ByteOff
d0 ByteOff
s Map Id ByteOff
p (CCallSpec CCallTarget
target CCallConv
PrimCallConv Safety
_) Type
result_ty [StgArg]
args
| (StaticTarget SourceText
_ FastString
label Maybe (GenUnit UnitId)
mb_unit Bool
_) <- CCallTarget
target
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> FastString
-> Maybe (GenUnit UnitId)
-> Type
-> [StgArg]
-> BcM (OrdList BCInstr)
generatePrimCall ByteOff
d0 ByteOff
s Map Id ByteOff
p FastString
label Maybe (GenUnit UnitId)
mb_unit Type
result_ty [StgArg]
args
| Bool
otherwise
= String -> BcM (OrdList BCInstr)
forall a. HasCallStack => 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
_ Safety
safety) Type
result_ty [StgArg]
args
= do
profile <- BcM Profile
getProfile
let
args_r_to_l = [StgArg] -> [StgArg]
forall a. [a] -> [a]
reverse [StgArg]
args
platform = Profile -> Platform
profilePlatform Profile
profile
addr_size_b :: ByteOff
addr_size_b = Platform -> ByteOff
wordSize Platform
platform
arrayish_rep_hdr_size :: TyCon -> Maybe Int
arrayish_rep_hdr_size TyCon
t
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon
= Int -> Maybe Int
forall a. a -> Maybe a
Just (Profile -> Int
arrPtrsHdrSize Profile
profile)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon
= Int -> Maybe Int
forall a. a -> Maybe a
Just (Profile -> Int
smallArrPtrsHdrSize Profile
profile)
| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon
= Int -> Maybe Int
forall a. a -> Maybe a
Just (Profile -> Int
arrWordsHdrSize Profile
profile)
| Bool
otherwise
= Maybe Int
forall a. Maybe a
Nothing
pargs
:: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimOrVoidRep)]
pargs ByteOff
_ [] = [(OrdList BCInstr, PrimOrVoidRep)]
-> BcM [(OrdList BCInstr, PrimOrVoidRep)]
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
pargs ByteOff
d (aa :: StgArg
aa@(StgVarArg Id
a):[StgArg]
az)
| Just TyCon
t <- Type -> Maybe TyCon
tyConAppTyCon_maybe (Id -> Type
idType Id
a)
, Just Int
hdr_sz <- TyCon -> Maybe Int
arrayish_rep_hdr_size TyCon
t
= do rest <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimOrVoidRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [StgArg]
az
(push_fo, _) <- pushAtom d p aa
let code = OrdList BCInstr
push_fo OrdList BCInstr -> BCInstr -> OrdList BCInstr
forall a. OrdList a -> a -> OrdList a
`snocOL` WordOff -> Int -> BCInstr
SWIZZLE WordOff
0 (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hdr_sz)
return ((code, NVRep AddrRep) : rest)
pargs ByteOff
d (StgArg
aa:[StgArg]
az) = do (code_a, sz_a) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
aa
rest <- pargs (d + sz_a) az
return ((code_a, stgArgRep1 aa) : rest)
code_n_reps <- pargs d0 args_r_to_l
let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
a_reps_sizeW = [WordOff] -> WordOff
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((PrimOrVoidRep -> WordOff) -> [PrimOrVoidRep] -> [WordOff]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimOrVoidRep -> WordOff
repSizeWords Platform
platform) [PrimOrVoidRep]
a_reps_pushed_r_to_l)
push_args = [OrdList BCInstr] -> OrdList BCInstr
forall a. [OrdList a] -> OrdList a
concatOL [OrdList BCInstr]
pushs_arg
!d_after_args = ByteOff
d0 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
a_reps_sizeW
a_reps_pushed_RAW
| PrimOrVoidRep
VoidRep:[PrimOrVoidRep]
xs <- [PrimOrVoidRep]
a_reps_pushed_r_to_l
= [PrimOrVoidRep] -> [PrimOrVoidRep]
forall a. [a] -> [a]
reverse [PrimOrVoidRep]
xs
| Bool
otherwise
= String -> [PrimOrVoidRep]
forall a. HasCallStack => String -> a
panic String
"GHC.StgToByteCode.generateCCall: missing or invalid World token?"
r_rep = Type -> PrimOrVoidRep
maybe_getCCallReturnRep Type
result_ty
maybe_static_target :: Maybe Literal
maybe_static_target =
case CCallTarget
target of
CCallTarget
DynamicTarget -> Maybe Literal
forall a. Maybe a
Nothing
StaticTarget SourceText
_ FastString
_ Maybe (GenUnit UnitId)
_ Bool
False ->
String -> Maybe Literal
forall a. HasCallStack => String -> a
panic String
"generateCCall: unexpected FFI value import"
StaticTarget SourceText
_ FastString
target Maybe (GenUnit UnitId)
_ Bool
True ->
Literal -> Maybe Literal
forall a. a -> Maybe a
Just (FastString -> FunctionOrData -> Literal
LitLabel FastString
target FunctionOrData
IsFunction)
let
is_static = Maybe Literal -> Bool
forall a. Maybe a -> Bool
isJust Maybe Literal
maybe_static_target
a_reps
| Bool
is_static = [PrimOrVoidRep]
a_reps_pushed_RAW
| PrimOrVoidRep
_:[PrimOrVoidRep]
xs <- [PrimOrVoidRep]
a_reps_pushed_RAW = [PrimOrVoidRep]
xs
| Bool
otherwise = String -> [PrimOrVoidRep]
forall a. HasCallStack => String -> a
panic String
"GHC.StgToByteCode.generateCCall: dyn with no args"
(push_Addr, d_after_Addr)
| Just machlabel <- maybe_static_target
= (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)
| otherwise
= (nilOL, d_after_args)
r_sizeW = Platform -> PrimOrVoidRep -> WordOff
repSizeWords Platform
platform PrimOrVoidRep
r_rep
d_after_r = ByteOff
d_after_Addr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
r_sizeW
push_r = case PrimOrVoidRep
r_rep of
PrimOrVoidRep
VoidRep -> OrdList BCInstr
forall a. OrdList a
nilOL
NVRep PrimRep
r -> BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Literal -> WordOff -> BCInstr
PUSH_UBX (Platform -> PrimRep -> Literal
mkDummyLiteral Platform
platform PrimRep
r) WordOff
r_sizeW)
stk_offset = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d_after_r ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
let ffires = Platform -> PrimOrVoidRep -> FFIType
primRepToFFIType Platform
platform PrimOrVoidRep
r_rep
ffiargs = (PrimOrVoidRep -> FFIType) -> [PrimOrVoidRep] -> [FFIType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimOrVoidRep -> FFIType
primRepToFFIType Platform
platform) [PrimOrVoidRep]
a_reps
interp <- hscInterp <$> getHscEnv
token <- ioToBc $ interpCmd interp (PrepFFI ffiargs ffires)
recordFFIBc token
let
do_call = BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (WordOff -> RemotePtr C_ffi_cif -> Word16 -> BCInstr
CCALL WordOff
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 = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d_after_r ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
wrapup = WordOff -> WordOff -> OrdList BCInstr
mkSlideW WordOff
r_sizeW (WordOff
d_after_r_min_s WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
r_sizeW)
OrdList BCInstr -> BCInstr -> OrdList BCInstr
forall a. OrdList a -> a -> OrdList a
`snocOL` ArgRep -> BCInstr
RETURN (Platform -> PrimOrVoidRep -> ArgRep
toArgRepOrV Platform
platform PrimOrVoidRep
r_rep)
return (
push_args `appOL`
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
)
primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType
primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType
primRepToFFIType Platform
_ PrimOrVoidRep
VoidRep = FFIType
FFIVoid
primRepToFFIType Platform
platform (NVRep PrimRep
r)
= case PrimRep
r of
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
BoxedRep Maybe Levity
_ -> FFIType
FFIPointer
VecRep{} -> String -> SDoc -> FFIType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primRepToFFIType" (PrimRep -> SDoc
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
BoxedRep Maybe Levity
_ -> Literal
LitNullAddr
VecRep{} -> String -> SDoc -> Literal
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkDummyLiteral" (PrimRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr PrimRep
pr)
maybe_getCCallReturnRep :: Type -> PrimOrVoidRep
maybe_getCCallReturnRep :: Type -> PrimOrVoidRep
maybe_getCCallReturnRep Type
fn_ty
= let
([Scaled Type]
_a_tys, Type
r_ty) = Type -> ([Scaled Type], Type)
splitFunTys (Type -> Type
dropForAlls Type
fn_ty)
in
case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
r_ty of
[] -> PrimOrVoidRep
VoidRep
[PrimRep
rep] -> PrimRep -> PrimOrVoidRep
NVRep PrimRep
rep
[PrimRep]
_ -> String -> SDoc -> PrimOrVoidRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"maybe_getCCallReturn: can't handle:"
(Type -> SDoc
pprType Type
fn_ty)
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] Type
t)
= (Id, [Name]) -> Maybe (Id, [Name])
forall a. a -> Maybe a
Just (Id
v, Type -> [Name]
extract_constr_Names Type
t)
where
extract_constr_Names :: Type -> [Name]
extract_constr_Names Type
ty
| Type
rep_ty <- Type -> Type
unwrapType Type
ty
, Just TyCon
tyc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
rep_ty
, TyCon -> Bool
isDataTyCon TyCon
tyc
= (DataCon -> Name) -> [DataCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
forall a. NamedThing a => a -> Name
getName (Id -> Name) -> (DataCon -> Id) -> DataCon -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Id
dataConWorkId) (TyCon -> [DataCon]
tyConDataCons TyCon
tyc)
| Bool
otherwise
= String -> SDoc -> [Name]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"maybe_is_tagToEnum_call.extract_constr_Ids" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
maybe_is_tagToEnum_call CgStgExpr
_ = Maybe (Id, [Name])
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
= Bool -> BcM (OrdList BCInstr) -> BcM (OrdList BCInstr)
forall a. HasCallStack => Bool -> a -> a
assert ([Name] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Name]
names) (BcM (OrdList BCInstr) -> BcM (OrdList BCInstr))
-> BcM (OrdList BCInstr) -> BcM (OrdList BCInstr)
forall a b. (a -> b) -> a -> b
$
do (push_arg, arg_bytes) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
arg)
labels <- getLabelsBc (genericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
dflags <- getDynFlags
let infos = [LocalLabel]
-> [LocalLabel]
-> [Int]
-> [Name]
-> [(LocalLabel, LocalLabel, Int, Name)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [LocalLabel]
labels ([LocalLabel] -> [LocalLabel]
forall a. HasCallStack => [a] -> [a]
tail [LocalLabel]
labels [LocalLabel] -> [LocalLabel] -> [LocalLabel]
forall a. [a] -> [a] -> [a]
++ [LocalLabel
label_fail])
[Int
0 ..] [Name]
names
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
steps = ((LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr)
-> [(LocalLabel, LocalLabel, Int, Name)] -> [OrdList BCInstr]
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 = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
arg_bytes)
return (push_arg
`appOL` concatOL steps
`appOL` toOL [ LABEL label_fail, CASEFAIL,
LABEL label_exit ]
`appOL` mkSlideW 1 slide_ws
`appOL` unitOL 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)
= [BCInstr] -> OrdList BCInstr
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 => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
var)
= (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
forall a. OrdList a
nilOL, ByteOff
0)
| Id -> Bool
isFCallId Id
var
= String -> SDoc -> BcM (OrdList BCInstr, ByteOff)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pushAtom: shouldn't get an FCallId here" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var)
| Just PrimOp
primop <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
var
= do
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
return (unitOL (PUSH_PRIMOP primop), wordSize platform)
| Just ByteOff
d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
var Map Id ByteOff
p
= do platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let !szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
with_instr :: (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr ByteOff -> BCInstr
instr = do
let !off_b :: ByteOff
off_b = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
d_v
(OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (ByteOff -> BCInstr
instr ByteOff
off_b), Platform -> ByteOff
wordSize Platform
platform)
case szb of
ByteOff
1 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr ByteOff -> BCInstr
PUSH8_W
ByteOff
2 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr ByteOff -> BCInstr
PUSH16_W
ByteOff
4 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr ByteOff -> BCInstr
PUSH32_W
ByteOff
_ -> do
let !szw :: WordOff
szw = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
szb
!off_w :: WordOff
off_w = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
d_v) WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
szw WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
1
(OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BCInstr] -> OrdList BCInstr
forall a. [a] -> OrdList a
toOL (WordOff -> BCInstr -> [BCInstr]
forall i a. Integral i => i -> a -> [a]
genericReplicate WordOff
szw (WordOff -> BCInstr
PUSH_L WordOff
off_w)),
Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
szw)
| Bool
otherwise
= do platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let !szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
massert (szb == wordSize platform)
case isDataConWorkId_maybe var of
Just DataCon
con -> do
Bool -> BcM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (DataCon -> Bool
isNullaryRepDataCon DataCon
con)
(OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (DataCon -> WordOff -> BCInstr
PACK DataCon
con WordOff
0), ByteOff
szb)
Maybe DataCon
Nothing
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
var) -> do
Bool -> BcM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Id -> Type
idType Id
var HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
addrPrimTy)
(OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Name -> BCInstr
PUSH_ADDR (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
var)), ByteOff
szb)
| Bool
otherwise -> do
(OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Name -> BCInstr
PUSH_G (Id -> Name
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 <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let code :: PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
rep =
(OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
padding_instr OrdList BCInstr -> BCInstr -> OrdList BCInstr
forall a. OrdList a -> a -> OrdList a
`snocOL` BCInstr
instr, ByteOff
size_bytes ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
padding_bytes)
where
size_bytes :: ByteOff
size_bytes = Int -> ByteOff
ByteOff (Int -> ByteOff) -> Int -> 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 ByteOff -> ByteOff -> ByteOff
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 -> WordOff -> BCInstr
PUSH_UBX Literal
lit (Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
size_bytes)
case 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 TypeOrConstraint
_ Type
rep-> case HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"pushLiteral") Type
rep of
[PrimRep
pr] -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
pr
[PrimRep]
_ -> String -> SDoc -> BcM (OrdList BCInstr, ByteOff)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pushLiteral" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
lit)
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 -> String -> BcM (OrdList BCInstr, ByteOff)
forall a. HasCallStack => 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 <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let !szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
v
done ByteOff -> BCInstr
instr = do
let !off :: ByteOff
off = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
d_v
(OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (ByteOff -> BCInstr
instr ByteOff
off), ByteOff
szb)
case szb of
ByteOff
1 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done ByteOff -> BCInstr
PUSH8
ByteOff
2 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done ByteOff -> BCInstr
PUSH16
ByteOff
4 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done ByteOff -> 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) = Int -> (OrdList BCInstr, ByteOff) -> (OrdList BCInstr, ByteOff)
forall {t} {b}.
(Eq t, Num t, Num b) =>
t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go Int
n (OrdList BCInstr
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 OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD8, b
off b -> b -> b
forall a. Num a => a -> a -> a
+ b
1)
t
2 -> (OrdList BCInstr
instrs OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD16, b
off b -> b -> b
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 OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD32, b
off b -> b -> b
forall a. Num a => a -> a -> a
+ b
4)
t
_ -> t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go (t
n t -> t -> t
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
lbl_default <- BcM LocalLabel
getLabelBc
let
mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree [] Discr
_range_lo Discr
_range_hi = OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
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 Discr -> Discr -> Bool
forall a. Eq a => a -> a -> Bool
== Discr
range_hi
= OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Discr, OrdList BCInstr) -> OrdList BCInstr
forall a b. (a, b) -> b
snd (Discr, OrdList BCInstr)
val)
| [(Discr, OrdList BCInstr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, OrdList BCInstr)]
defaults
= do lbl <- BcM LocalLabel
getLabelBc
return (testEQ (fst val) lbl
`consOL` (snd val
`appOL` (LABEL lbl `consOL` unitOL CASEFAIL)))
| Bool
otherwise
= OrdList BCInstr -> BcM (OrdList BCInstr)
forall a. a -> BcM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testEQ ((Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst (Discr, OrdList BCInstr)
val) LocalLabel
lbl_default BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` (Discr, OrdList BCInstr) -> OrdList BCInstr
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 = [(Discr, OrdList BCInstr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Discr, OrdList BCInstr)]
vals Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
([(Discr, OrdList BCInstr)]
vals_lo, [(Discr, OrdList BCInstr)]
vals_hi) = Int
-> [(Discr, OrdList BCInstr)]
-> ([(Discr, OrdList BCInstr)], [(Discr, OrdList BCInstr)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [(Discr, OrdList BCInstr)]
vals
v_mid :: Discr
v_mid = (Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst ([(Discr, OrdList BCInstr)] -> (Discr, OrdList BCInstr)
forall a. HasCallStack => [a] -> a
head [(Discr, OrdList BCInstr)]
vals_hi)
in do
label_geq <- BcM LocalLabel
getLabelBc
code_lo <- mkTree vals_lo range_lo (dec v_mid)
code_hi <- mkTree vals_hi v_mid range_hi
return (testLT v_mid label_geq
`consOL` (code_lo
`appOL` unitOL (LABEL label_geq)
`appOL` code_hi))
the_default
= case [(Discr, OrdList BCInstr)]
defaults of
[] -> OrdList BCInstr
forall a. OrdList a
nilOL
[(Discr
_, OrdList BCInstr
def)] -> LocalLabel -> BCInstr
LABEL LocalLabel
lbl_default BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
def
[(Discr, OrdList BCInstr)]
_ -> String -> OrdList BCInstr
forall a. HasCallStack => String -> a
panic String
"mkMultiBranch/the_default"
instrs <- mkTree notd_ways init_lo init_hi
return (instrs `appOL` the_default)
where
([(Discr, OrdList BCInstr)]
defaults, [(Discr, OrdList BCInstr)]
not_defaults) = ((Discr, OrdList BCInstr) -> Bool)
-> [(Discr, OrdList BCInstr)]
-> ([(Discr, OrdList BCInstr)], [(Discr, OrdList BCInstr)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Discr -> Bool
isNoDiscr(Discr -> Bool)
-> ((Discr, OrdList BCInstr) -> Discr)
-> (Discr, OrdList BCInstr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst) [(Discr, OrdList BCInstr)]
raw_ways
notd_ways :: [(Discr, OrdList BCInstr)]
notd_ways = ((Discr, OrdList BCInstr) -> (Discr, OrdList BCInstr) -> Ordering)
-> [(Discr, OrdList BCInstr)] -> [(Discr, OrdList BCInstr)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Discr, OrdList BCInstr) -> Discr)
-> (Discr, OrdList BCInstr) -> (Discr, OrdList BCInstr) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Discr, OrdList BCInstr) -> Discr
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 (Int8 -> Int8
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 (Int16 -> Int16
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 (Int32 -> Int32
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 (Int64 -> Int64
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 (Word8 -> Word8
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 (Word16 -> Word16
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 (Word32 -> Word32
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 (Word64 -> Word64
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
_ = String -> BCInstr
forall a. HasCallStack => 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 (Int8 -> Int16
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 (Int16 -> Int16
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 (Int32 -> Int32
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 (Int64 -> Int64
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 (Word8 -> Word8
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 (Word16 -> Word16
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 (Word32 -> Word32
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 (Word64 -> Word64
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
_ = String -> BCInstr
forall a. HasCallStack => String -> a
panic String
"mkMultiBranch NoDiscr"
(Discr
init_lo, Discr
init_hi) = case [(Discr, OrdList BCInstr)]
notd_ways of
[] -> String -> (Discr, Discr)
forall a. HasCallStack => String -> a
panic String
"mkMultiBranch: awesome foursome"
(Discr
discr, OrdList BCInstr
_):[(Discr, OrdList BCInstr)]
_ -> case Discr
discr of
DiscrI Int
_ -> ( Int -> Discr
DiscrI Int
forall a. Bounded a => a
minBound, Int -> Discr
DiscrI Int
forall a. Bounded a => a
maxBound )
DiscrI8 Int8
_ -> ( Int8 -> Discr
DiscrI8 Int8
forall a. Bounded a => a
minBound, Int8 -> Discr
DiscrI8 Int8
forall a. Bounded a => a
maxBound )
DiscrI16 Int16
_ -> ( Int16 -> Discr
DiscrI16 Int16
forall a. Bounded a => a
minBound, Int16 -> Discr
DiscrI16 Int16
forall a. Bounded a => a
maxBound )
DiscrI32 Int32
_ -> ( Int32 -> Discr
DiscrI32 Int32
forall a. Bounded a => a
minBound, Int32 -> Discr
DiscrI32 Int32
forall a. Bounded a => a
maxBound )
DiscrI64 Int64
_ -> ( Int64 -> Discr
DiscrI64 Int64
forall a. Bounded a => a
minBound, Int64 -> Discr
DiscrI64 Int64
forall a. Bounded a => a
maxBound )
DiscrW Word
_ -> ( Word -> Discr
DiscrW Word
forall a. Bounded a => a
minBound, Word -> Discr
DiscrW Word
forall a. Bounded a => a
maxBound )
DiscrW8 Word8
_ -> ( Word8 -> Discr
DiscrW8 Word8
forall a. Bounded a => a
minBound, Word8 -> Discr
DiscrW8 Word8
forall a. Bounded a => a
maxBound )
DiscrW16 Word16
_ -> ( Word16 -> Discr
DiscrW16 Word16
forall a. Bounded a => a
minBound, Word16 -> Discr
DiscrW16 Word16
forall a. Bounded a => a
maxBound )
DiscrW32 Word32
_ -> ( Word32 -> Discr
DiscrW32 Word32
forall a. Bounded a => a
minBound, Word32 -> Discr
DiscrW32 Word32
forall a. Bounded a => a
maxBound )
DiscrW64 Word64
_ -> ( Word64 -> Discr
DiscrW64 Word64
forall a. Bounded a => a
minBound, Word64 -> Discr
DiscrW64 Word64
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 -> String -> (Discr, Discr)
forall a. HasCallStack => String -> a
panic String
"mkMultiBranch NoDiscr"
(Word16
algMinBound, Word16
algMaxBound)
= case Maybe Int
maybe_ncons of
Just Int
n -> (Word16
0, Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1)
Maybe Int
Nothing -> (Word16
forall a. Bounded a => a
minBound, Word16
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
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
dec (DiscrW Word
w) = Word -> Discr
DiscrW (Word
wWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1)
dec (DiscrP Word16
i) = Word16 -> Discr
DiscrP (Word16
iWord16 -> Word16 -> Word16
forall 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
(Discr -> Discr -> Bool) -> (Discr -> Discr -> Bool) -> Eq Discr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Discr -> Discr -> Bool
== :: Discr -> Discr -> Bool
$c/= :: Discr -> Discr -> Bool
/= :: Discr -> Discr -> Bool
Eq, Eq Discr
Eq Discr =>
(Discr -> Discr -> Ordering)
-> (Discr -> Discr -> Bool)
-> (Discr -> Discr -> Bool)
-> (Discr -> Discr -> Bool)
-> (Discr -> Discr -> Bool)
-> (Discr -> Discr -> Discr)
-> (Discr -> Discr -> Discr)
-> Ord 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
$ccompare :: Discr -> Discr -> Ordering
compare :: Discr -> Discr -> Ordering
$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
>= :: Discr -> Discr -> Bool
$cmax :: Discr -> Discr -> Discr
max :: Discr -> Discr -> Discr
$cmin :: Discr -> Discr -> Discr
min :: Discr -> Discr -> Discr
Ord)
instance Outputable Discr where
ppr :: Discr -> SDoc
ppr (DiscrI Int
i) = Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i
ppr (DiscrI8 Int8
i) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Int8 -> String
forall a. Show a => a -> String
show Int8
i)
ppr (DiscrI16 Int16
i) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Int16 -> String
forall a. Show a => a -> String
show Int16
i)
ppr (DiscrI32 Int32
i) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Int32 -> String
forall a. Show a => a -> String
show Int32
i)
ppr (DiscrI64 Int64
i) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Int64 -> String
forall a. Show a => a -> String
show Int64
i)
ppr (DiscrW Word
w) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Word -> String
forall a. Show a => a -> String
show Word
w)
ppr (DiscrW8 Word8
w) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Word8 -> String
forall a. Show a => a -> String
show Word8
w)
ppr (DiscrW16 Word16
w) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Word16 -> String
forall a. Show a => a -> String
show Word16
w)
ppr (DiscrW32 Word32
w) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Word32 -> String
forall a. Show a => a -> String
show Word32
w)
ppr (DiscrW64 Word64
w) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Word64 -> String
forall a. Show a => a -> String
show Word64
w)
ppr (DiscrF Float
f) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Float -> String
forall a. Show a => a -> String
show Float
f)
ppr (DiscrD Double
d) = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Double -> String
forall a. Show a => a -> String
show Double
d)
ppr (DiscrP Word16
i) = Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
i
ppr Discr
NoDiscr = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DEF"
lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe :: Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe = Id -> Map Id ByteOff -> Maybe ByteOff
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 (Int -> WordOff) -> (Id -> Int) -> Id -> WordOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> ArgRep -> Int
argRepSizeW Platform
platform (ArgRep -> Int) -> (Id -> ArgRep) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> ArgRep
idArgRep Platform
platform
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
| Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
var) Bool -> Bool -> Bool
||
Type -> Bool
isUnboxedSumType (Id -> Type
idType Id
var) =
Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (WordOff -> ByteOff) -> (Id -> WordOff) -> Id -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Int -> WordOff
WordOff (Int -> WordOff) -> (Id -> Int) -> Id -> WordOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Id -> [Int]) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrimRep -> Int) -> [PrimRep] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> ArgRep -> Int
argRepSizeW Platform
platform (ArgRep -> Int) -> (PrimRep -> ArgRep) -> PrimRep -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> PrimRep -> ArgRep
toArgRep Platform
platform) ([PrimRep] -> [Int]) -> (Id -> [PrimRep]) -> Id -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Type -> [PrimRep]) -> (Id -> Type) -> Id -> [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> ByteOff) -> Id -> ByteOff
forall a b. (a -> b) -> a -> b
$ Id
var
| Bool
otherwise = Int -> ByteOff
ByteOff (Platform -> PrimRep -> Int
primRepSizeB Platform
platform (Id -> PrimRep
idPrimRepU Id
var))
repSizeWords :: Platform -> PrimOrVoidRep -> WordOff
repSizeWords :: Platform -> PrimOrVoidRep -> WordOff
repSizeWords Platform
platform PrimOrVoidRep
rep = Int -> WordOff
WordOff (Int -> WordOff) -> Int -> WordOff
forall a b. (a -> b) -> a -> b
$ Platform -> ArgRep -> Int
argRepSizeW Platform
platform (Platform -> PrimOrVoidRep -> ArgRep
toArgRepOrV Platform
platform PrimOrVoidRep
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
False
CCallConv
PrimCallConv -> Bool
True
CCallConv
JavaScriptCallConv -> Bool
False
CCallConv
CApiConv -> Bool
True
unsupportedCConvException :: a
unsupportedCConvException :: forall a. a
unsupportedCConvException = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError
(String
"Error: bytecode compiler can't handle some foreign calling conventions\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" Workaround: use -fobject-code, or compile this module to .o separately."))
mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstr
mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstr
mkSlideB Platform
platform ByteOff
nb ByteOff
db = WordOff -> WordOff -> BCInstr
SLIDE WordOff
n WordOff
d
where
!n :: WordOff
n = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
nb
!d :: WordOff
d = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
db
mkSlideW :: WordOff -> WordOff -> OrdList BCInstr
mkSlideW :: WordOff -> WordOff -> OrdList BCInstr
mkSlideW !WordOff
n !WordOff
ws
| WordOff
ws WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
== WordOff
0
= OrdList BCInstr
forall a. OrdList a
nilOL
| Bool
otherwise
= BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (WordOff -> WordOff -> BCInstr
SLIDE WordOff
n (WordOff -> BCInstr) -> WordOff -> BCInstr
forall a b. (a -> b) -> a -> b
$ WordOff -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
ws)
atomRep :: Platform -> StgArg -> ArgRep
atomRep :: Platform -> StgArg -> ArgRep
atomRep Platform
platform StgArg
e = Platform -> PrimOrVoidRep -> ArgRep
toArgRepOrV Platform
platform (StgArg -> PrimOrVoidRep
stgArgRep1 StgArg
e)
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
original_depth [ByteOff]
szsb = [ByteOff] -> [ByteOff]
forall a. HasCallStack => [a] -> [a]
tail ((ByteOff -> ByteOff -> ByteOff)
-> ByteOff -> [ByteOff] -> [ByteOff]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl' ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
(+) ByteOff
original_depth [ByteOff]
szsb)
typeArgReps :: Platform -> Type -> [ArgRep]
typeArgReps :: Platform -> Type -> [ArgRep]
typeArgReps Platform
platform = (PrimRep -> ArgRep) -> [PrimRep] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform) ([PrimRep] -> [ArgRep]) -> (Type -> [PrimRep]) -> Type -> [ArgRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep
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
, BcM_State -> Int
breakInfoIdx :: !Int
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving ((forall a b. (a -> b) -> BcM a -> BcM b)
-> (forall a b. a -> BcM b -> BcM a) -> Functor BcM
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
$cfmap :: forall a b. (a -> b) -> BcM a -> BcM b
fmap :: forall a b. (a -> b) -> BcM a -> BcM b
$c<$ :: forall a b. a -> BcM b -> BcM a
<$ :: forall a b. a -> BcM b -> BcM a
Functor)
ioToBc :: IO a -> BcM a
ioToBc :: forall a. IO a -> BcM a
ioToBc IO a
io = (BcM_State -> IO (BcM_State, a)) -> BcM a
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, a)) -> BcM a)
-> (BcM_State -> IO (BcM_State, a)) -> BcM a
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> do
x <- IO a
io
return (st, 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
-> Int
-> BcM_State
BcM_State HscEnv
hsc_env Module
this_mod Word32
0 [] Maybe ModBreaks
modBreaks IntMap CgBreakInfo
forall a. IntMap a
IntMap.empty Int
0)
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 = (BcM_State -> IO (BcM_State, b)) -> BcM b
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, b)) -> BcM b)
-> (BcM_State -> IO (BcM_State, b)) -> BcM b
forall a b. (a -> b) -> a -> b
$ \BcM_State
st0 -> do
(st1, q) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
let BcM k = cont q
(st2, r) <- k st1
return (st2, 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) = (BcM_State -> IO (BcM_State, b)) -> BcM b
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, b)) -> BcM b)
-> (BcM_State -> IO (BcM_State, b)) -> BcM b
forall a b. (a -> b) -> a -> b
$ \BcM_State
st0 -> do
(st1, _) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
(st2, r) <- cont st1
return (st2, r)
returnBc :: a -> BcM a
returnBc :: forall a. a -> BcM a
returnBc a
result = (BcM_State -> IO (BcM_State, a)) -> BcM a
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, a)) -> BcM a)
-> (BcM_State -> IO (BcM_State, a)) -> BcM a
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> ((BcM_State, a) -> IO (BcM_State, a)
forall a. a -> IO a
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 = a -> BcM a
forall a. a -> BcM a
returnBc
<*> :: forall a b. BcM (a -> b) -> BcM a -> BcM 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
(*>) = 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
(>>=) = 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
(>>) = BcM a -> BcM b -> BcM b
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 = (BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags)
-> (BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, DynFlags) -> IO (BcM_State, DynFlags)
forall a. a -> IO a
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 = (BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv)
-> (BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, HscEnv) -> IO (BcM_State, HscEnv)
forall a. a -> IO a
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 (DynFlags -> Profile) -> BcM DynFlags -> BcM Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
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
= (BcM_State -> IO (BcM_State, ProtoBCO Name)) -> BcM (ProtoBCO Name)
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, ProtoBCO Name))
-> BcM (ProtoBCO Name))
-> (BcM_State -> IO (BcM_State, ProtoBCO Name))
-> BcM (ProtoBCO Name)
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, ProtoBCO Name) -> IO (BcM_State, ProtoBCO Name)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{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
= (BcM_State -> IO (BcM_State, ())) -> BcM ()
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, ())) -> BcM ())
-> (BcM_State -> IO (BcM_State, ())) -> BcM ()
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, ()) -> IO (BcM_State, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{ffis = FFIInfo a : ffis st}, ())
getLabelBc :: BcM LocalLabel
getLabelBc :: BcM LocalLabel
getLabelBc
= (BcM_State -> IO (BcM_State, LocalLabel)) -> BcM LocalLabel
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, LocalLabel)) -> BcM LocalLabel)
-> (BcM_State -> IO (BcM_State, LocalLabel)) -> BcM LocalLabel
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> do let nl :: Word32
nl = BcM_State -> Word32
nextlabel BcM_State
st
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
nl Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Bounded a => a
maxBound) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. HasCallStack => String -> a
panic String
"getLabelBc: Ran out of labels"
(BcM_State, LocalLabel) -> IO (BcM_State, LocalLabel)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel = nl + 1}, Word32 -> LocalLabel
LocalLabel Word32
nl)
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc Word32
n
= (BcM_State -> IO (BcM_State, [LocalLabel])) -> BcM [LocalLabel]
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, [LocalLabel])) -> BcM [LocalLabel])
-> (BcM_State -> IO (BcM_State, [LocalLabel])) -> BcM [LocalLabel]
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> let ctr :: Word32
ctr = BcM_State -> Word32
nextlabel BcM_State
st
in (BcM_State, [LocalLabel]) -> IO (BcM_State, [LocalLabel])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel = ctr+n}, [Word32] -> [LocalLabel]
forall a b. Coercible a b => a -> b
coerce [Word32
ctr .. Word32
ctrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
nWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
1])
newBreakInfo :: CgBreakInfo -> BcM Int
newBreakInfo :: CgBreakInfo -> BcM Int
newBreakInfo CgBreakInfo
info = (BcM_State -> IO (BcM_State, Int)) -> BcM Int
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Int)) -> BcM Int)
-> (BcM_State -> IO (BcM_State, Int)) -> BcM Int
forall a b. (a -> b) -> a -> b
$ \BcM_State
st ->
let ix :: Int
ix = BcM_State -> Int
breakInfoIdx BcM_State
st
st' :: BcM_State
st' = BcM_State
st
{ breakInfo = IntMap.insert ix info (breakInfo st)
, breakInfoIdx = ix + 1
}
in (BcM_State, Int) -> IO (BcM_State, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st', Int
ix)
getCurrentModule :: BcM Module
getCurrentModule :: BcM Module
getCurrentModule = (BcM_State -> IO (BcM_State, Module)) -> BcM Module
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Module)) -> BcM Module)
-> (BcM_State -> IO (BcM_State, Module)) -> BcM Module
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, Module) -> IO (BcM_State, Module)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> Module
thisModule BcM_State
st)
getCurrentModBreaks :: BcM (Maybe ModBreaks)
getCurrentModBreaks :: BcM (Maybe ModBreaks)
getCurrentModBreaks = (BcM_State -> IO (BcM_State, Maybe ModBreaks))
-> BcM (Maybe ModBreaks)
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Maybe ModBreaks))
-> BcM (Maybe ModBreaks))
-> (BcM_State -> IO (BcM_State, Maybe ModBreaks))
-> BcM (Maybe ModBreaks)
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, Maybe ModBreaks) -> IO (BcM_State, Maybe ModBreaks)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> Maybe ModBreaks
modBreaks BcM_State
st)
tickFS :: FastString
tickFS :: FastString
tickFS = String -> FastString
fsLit String
"ticked"