{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen, stgExprToBCOs ) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.ByteCode.Instr
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
import GHC.Cmm.CallConv
import GHC.Cmm.Expr
import GHC.Cmm.Node
import GHC.Cmm.Utils
import GHC.Platform
import GHC.Platform.Profile
import GHC.Runtime.Interpreter
import GHCi.FFI
import GHCi.RemoteTypes
import GHC.Types.Basic
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Id.Make
import GHC.Types.Id
import GHC.Types.ForeignCall
import GHC.Core
import GHC.Types.Literal
import GHC.Builtin.PrimOps
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Types.Var.Set
import GHC.Builtin.Types ( unboxedUnitTy )
import GHC.Builtin.Types.Prim
import GHC.Core.TyCo.Ppr ( pprType )
import GHC.Utils.Error
import GHC.Types.Unique
import GHC.Builtin.Uniques
import GHC.Builtin.Utils ( primOpId )
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Var.Env
import GHC.Types.Tickish
import Data.List ( genericReplicate, genericLength, intersperse
, partition, scanl', sort, sortBy, zip4, zip6, nub )
import Foreign
import Control.Monad
import Data.Char
import GHC.Types.Unique.Supply
import GHC.Unit.Module
import Control.Exception
import Data.Array
import Data.Coerce (coerce)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.IntMap (IntMap)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified GHC.Data.FiniteMap as Map
import Data.Ord
import GHC.Stack.CCS
import Data.Either ( partitionEithers )
import qualified GHC.Types.CostCentre as CC
import GHC.Stg.Syntax
import GHC.Stg.FVs
byteCodeGen :: HscEnv
-> Module
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen :: HscEnv
-> Module
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod [StgTopBinding]
binds [TyCon]
tycs Maybe ModBreaks
mb_modBreaks
= Logger
-> DynFlags
-> SDoc
-> (CompiledByteCode -> ())
-> IO CompiledByteCode
-> IO CompiledByteCode
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"GHC.StgToByteCode"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
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 'Vanilla]
lifted_binds) = [Either (Id, ByteString) (GenStgBinding 'Vanilla)]
-> ([(Id, ByteString)], [GenStgBinding 'Vanilla])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Id, ByteString) (GenStgBinding 'Vanilla)]
-> ([(Id, ByteString)], [GenStgBinding 'Vanilla]))
-> [Either (Id, ByteString) (GenStgBinding 'Vanilla)]
-> ([(Id, ByteString)], [GenStgBinding 'Vanilla])
forall a b. (a -> b) -> a -> b
$ do
StgTopBinding
bnd <- [StgTopBinding]
binds
case StgTopBinding
bnd of
StgTopLifted GenStgBinding 'Vanilla
bnd -> [GenStgBinding 'Vanilla
-> Either (Id, ByteString) (GenStgBinding 'Vanilla)
forall a b. b -> Either a b
Right GenStgBinding 'Vanilla
bnd]
StgTopStringLit Id
b ByteString
str -> [(Id, ByteString)
-> Either (Id, ByteString) (GenStgBinding 'Vanilla)
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
[(Id, RemotePtr ())]
stringPtrs <- Interp -> [(Id, ByteString)] -> IO [(Id, RemotePtr ())]
allocateTopStrings Interp
interp [(Id, ByteString)]
strings
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'y'
(BcM_State{[FFIInfo]
Maybe ModBreaks
Word32
IntMap CgBreakInfo
Module
IdEnv (RemotePtr ())
UniqSupply
HscEnv
topStrings :: BcM_State -> IdEnv (RemotePtr ())
breakInfo :: BcM_State -> IntMap CgBreakInfo
modBreaks :: BcM_State -> Maybe ModBreaks
ffis :: BcM_State -> [FFIInfo]
nextlabel :: BcM_State -> Word32
thisModule :: BcM_State -> Module
uniqSupply :: BcM_State -> UniqSupply
bcm_hsc_env :: BcM_State -> HscEnv
topStrings :: IdEnv (RemotePtr ())
breakInfo :: IntMap CgBreakInfo
modBreaks :: Maybe ModBreaks
ffis :: [FFIInfo]
nextlabel :: Word32
thisModule :: Module
uniqSupply :: UniqSupply
bcm_hsc_env :: HscEnv
..}, [ProtoBCO Name]
proto_bcos) <-
HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM [ProtoBCO Name]
-> IO (BcM_State, [ProtoBCO Name])
forall r.
HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc HscEnv
hsc_env UniqSupply
us Module
this_mod Maybe ModBreaks
mb_modBreaks ([(Id, RemotePtr ())] -> IdEnv (RemotePtr ())
forall a. [(Id, a)] -> VarEnv a
mkVarEnv [(Id, RemotePtr ())]
stringPtrs) (BcM [ProtoBCO Name] -> IO (BcM_State, [ProtoBCO Name]))
-> BcM [ProtoBCO Name] -> IO (BcM_State, [ProtoBCO Name])
forall a b. (a -> b) -> a -> b
$ do
[GenStgBinding 'Vanilla]
prepd_binds <- (GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla))
-> [GenStgBinding 'Vanilla] -> BcM [GenStgBinding 'Vanilla]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind [GenStgBinding 'Vanilla]
lifted_binds
let flattened_binds :: [(Id, CgStgRhs)]
flattened_binds =
(GenStgBinding 'Vanilla -> [(Id, CgStgRhs)])
-> [GenStgBinding 'Vanilla] -> [(Id, CgStgRhs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenStgBinding 'CodeGen -> [(Id, CgStgRhs)]
forall (pass :: StgPass).
GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
flattenBind (GenStgBinding 'CodeGen -> [(Id, CgStgRhs)])
-> (GenStgBinding 'Vanilla -> GenStgBinding 'CodeGen)
-> GenStgBinding 'Vanilla
-> [(Id, CgStgRhs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgBinding 'Vanilla -> GenStgBinding 'CodeGen
annBindingFreeVars) ([GenStgBinding 'Vanilla] -> [GenStgBinding 'Vanilla]
forall a. [a] -> [a]
reverse [GenStgBinding 'Vanilla]
prepd_binds)
((Id, CgStgRhs) -> BcM (ProtoBCO Name))
-> [(Id, CgStgRhs)] -> BcM [ProtoBCO Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind [(Id, CgStgRhs)]
flattened_binds
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FFIInfo] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [FFIInfo]
ffis)
(String -> IO ()
forall a. String -> a
panic String
"GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_BCOs
String
"Proto-BCOs" DumpFormat
FormatByteCode
([SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (Char -> SDoc
char Char
' ') ((ProtoBCO Name -> SDoc) -> [ProtoBCO Name] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ProtoBCO Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ProtoBCO Name]
proto_bcos)))
CompiledByteCode
cbc <- Interp
-> Profile
-> [ProtoBCO Name]
-> [TyCon]
-> [RemotePtr ()]
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs Interp
interp Profile
profile [ProtoBCO Name]
proto_bcos [TyCon]
tycs (((Id, RemotePtr ()) -> RemotePtr ())
-> [(Id, RemotePtr ())] -> [RemotePtr ()]
forall a b. (a -> b) -> [a] -> [b]
map (Id, RemotePtr ()) -> RemotePtr ()
forall a b. (a, b) -> b
snd [(Id, RemotePtr ())]
stringPtrs)
(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 :: IntMap CgBreakInfo
modBreaks_breakInfo = IntMap CgBreakInfo
breakInfo })
() -> IO ()
forall a. a -> IO a
evaluate (CompiledByteCode -> ()
seqCompiledByteCode CompiledByteCode
cbc)
CompiledByteCode -> IO CompiledByteCode
forall (m :: * -> *) a. Monad m => a -> m a
return CompiledByteCode
cbc
where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
allocateTopStrings
:: Interp
-> [(Id, ByteString)]
-> IO [(Var, RemotePtr ())]
allocateTopStrings :: Interp -> [(Id, ByteString)] -> IO [(Id, RemotePtr ())]
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
[RemotePtr ()]
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
[(Id, RemotePtr ())] -> IO [(Id, RemotePtr ())]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id, RemotePtr ())] -> IO [(Id, RemotePtr ())])
-> [(Id, RemotePtr ())] -> IO [(Id, RemotePtr ())]
forall a b. (a -> b) -> a -> b
$ [Id] -> [RemotePtr ()] -> [(Id, RemotePtr ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs [RemotePtr ()]
ptrs
stgExprToBCOs :: HscEnv
-> Module
-> Type
-> StgRhs
-> IO UnlinkedBCO
stgExprToBCOs :: HscEnv -> Module -> Type -> StgRhs -> IO UnlinkedBCO
stgExprToBCOs HscEnv
hsc_env Module
this_mod Type
expr_ty StgRhs
expr
= Logger
-> DynFlags
-> SDoc
-> (UnlinkedBCO -> ())
-> IO UnlinkedBCO
-> IO UnlinkedBCO
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"GHC.StgToByteCode"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> UnlinkedBCO -> ()
forall a b. a -> b -> a
const ()) (IO UnlinkedBCO -> IO UnlinkedBCO)
-> IO UnlinkedBCO -> IO UnlinkedBCO
forall a b. (a -> b) -> a -> b
$ do
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'y'
(BcM_State HscEnv
_dflags UniqSupply
_us Module
_this_mod Word32
_final_ctr [FFIInfo]
mallocd Maybe ModBreaks
_ IntMap CgBreakInfo
_ IdEnv (RemotePtr ())
_, ProtoBCO Name
proto_bco)
<- HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM (ProtoBCO Name)
-> IO (BcM_State, ProtoBCO Name)
forall r.
HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc HscEnv
hsc_env UniqSupply
us Module
this_mod Maybe ModBreaks
forall a. Maybe a
Nothing IdEnv (RemotePtr ())
forall a. VarEnv a
emptyVarEnv (BcM (ProtoBCO Name) -> IO (BcM_State, ProtoBCO Name))
-> BcM (ProtoBCO Name) -> IO (BcM_State, ProtoBCO Name)
forall a b. (a -> b) -> a -> b
$ do
GenStgBinding 'CodeGen
prepd_expr <- GenStgBinding 'Vanilla -> GenStgBinding 'CodeGen
annBindingFreeVars (GenStgBinding 'Vanilla -> GenStgBinding 'CodeGen)
-> BcM (GenStgBinding 'Vanilla) -> BcM (GenStgBinding 'CodeGen)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind (BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
dummy_id StgRhs
expr)
case GenStgBinding 'CodeGen
prepd_expr of
(StgNonRec BinderP 'CodeGen
_ CgStgRhs
cg_expr) -> [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [] (Id -> Name
idName Id
dummy_id, CgStgRhs
cg_expr)
GenStgBinding 'CodeGen
_ ->
String -> BcM (ProtoBCO Name)
forall a. String -> a
panic String
"GHC.StgByteCode.stgExprToBCOs"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FFIInfo] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [FFIInfo]
mallocd)
(String -> IO ()
forall a. String -> a
panic String
"GHC.StgToByteCode.stgExprToBCOs: missing final emitBc?")
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_BCOs String
"Proto-BCOs" DumpFormat
FormatByteCode
(ProtoBCO Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr ProtoBCO Name
proto_bco)
Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO Interp
interp Profile
profile ProtoBCO Name
proto_bco
where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
dummy_id :: Id
dummy_id = FastString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> FastString
fsLit String
"BCO_toplevel")
(Int -> Unique
mkPseudoUniqueE Int
0)
Type
Many
Type
expr_ty
bcPrepRHS :: StgRhs -> BcM StgRhs
bcPrepRHS :: StgRhs -> BcM StgRhs
bcPrepRHS (StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args (StgTick bp :: StgTickish
bp@Breakpoint{} GenStgExpr 'Vanilla
expr)) = do
GenStgExpr 'Vanilla
expr' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
StgRhs -> BcM StgRhs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args (StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
expr'))
bcPrepRHS (StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
expr) =
XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args (GenStgExpr 'Vanilla -> StgRhs)
-> BcM (GenStgExpr 'Vanilla) -> BcM StgRhs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepRHS con :: StgRhs
con@StgRhsCon{} = StgRhs -> BcM StgRhs
forall (f :: * -> *) a. Applicative f => a -> f a
pure StgRhs
con
bcPrepExpr :: StgExpr -> BcM StgExpr
bcPrepExpr :: GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr (StgTick bp :: StgTickish
bp@(Breakpoint XBreakpoint 'TickishPassStg
tick_ty Int
_ [XTickishId 'TickishPassStg]
_) GenStgExpr 'Vanilla
rhs)
| Type -> Bool
isLiftedTypeKind (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
XBreakpoint 'TickishPassStg
tick_ty) = do
Id
id <- Type -> BcM Id
newId Type
XBreakpoint 'TickishPassStg
tick_ty
GenStgExpr 'Vanilla
rhs' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
let expr' :: GenStgExpr 'Vanilla
expr' = StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
rhs'
bnd :: GenStgBinding 'Vanilla
bnd = BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
id (XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
XRhsClosure 'Vanilla
noExtFieldSilent
CostCentreStack
CC.dontCareCCS
UpdateFlag
ReEntrant
[]
GenStgExpr 'Vanilla
expr'
)
letExp :: GenStgExpr 'Vanilla
letExp = XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet NoExtFieldSilent
XLet 'Vanilla
noExtFieldSilent GenStgBinding 'Vanilla
bnd (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
id [])
GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
letExp
| Bool
otherwise = do
Id
id <- Type -> BcM Id
newId (Type -> Type -> Type
mkVisFunTyMany Type
realWorldStatePrimTy Type
XBreakpoint 'TickishPassStg
tick_ty)
Id
st <- Type -> BcM Id
newId Type
realWorldStatePrimTy
GenStgExpr 'Vanilla
rhs' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
let expr' :: GenStgExpr 'Vanilla
expr' = StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
rhs'
bnd :: GenStgBinding 'Vanilla
bnd = BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
id (XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
XRhsClosure 'Vanilla
noExtFieldSilent
CostCentreStack
CC.dontCareCCS
UpdateFlag
ReEntrant
[Id
BinderP 'Vanilla
voidArgId]
GenStgExpr 'Vanilla
expr'
)
GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet NoExtFieldSilent
XLet 'Vanilla
noExtFieldSilent GenStgBinding 'Vanilla
bnd (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
id [Id -> StgArg
StgVarArg Id
st])
bcPrepExpr (StgTick StgTickish
tick GenStgExpr 'Vanilla
rhs) =
StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgExpr 'Vanilla) -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
bcPrepExpr (StgLet XLet 'Vanilla
xlet GenStgBinding 'Vanilla
bnds GenStgExpr 'Vanilla
expr) =
XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
xlet (GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgBinding 'Vanilla)
-> BcM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind GenStgBinding 'Vanilla
bnds
BcM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgExpr 'Vanilla) -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepExpr (StgLetNoEscape XLetNoEscape 'Vanilla
xlne GenStgBinding 'Vanilla
bnds GenStgExpr 'Vanilla
expr) =
XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
XLetNoEscape 'Vanilla
xlne (GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgBinding 'Vanilla)
-> BcM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind GenStgBinding 'Vanilla
bnds
BcM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgExpr 'Vanilla) -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepExpr (StgCase GenStgExpr 'Vanilla
expr BinderP 'Vanilla
bndr AltType
alt_type [GenStgAlt 'Vanilla]
alts) =
GenStgExpr 'Vanilla
-> Id
-> AltType
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase (GenStgExpr 'Vanilla
-> Id
-> AltType
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> GenStgExpr 'Vanilla)
-> BcM (GenStgExpr 'Vanilla)
-> BcM
(Id
-> AltType
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
BcM
(Id
-> AltType
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> GenStgExpr 'Vanilla)
-> BcM Id
-> BcM
(AltType
-> [(AltCon, [Id], GenStgExpr 'Vanilla)] -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> BcM Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
BinderP 'Vanilla
bndr
BcM
(AltType
-> [(AltCon, [Id], GenStgExpr 'Vanilla)] -> GenStgExpr 'Vanilla)
-> BcM AltType
-> BcM
([(AltCon, [Id], GenStgExpr 'Vanilla)] -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AltType -> BcM AltType
forall (f :: * -> *) a. Applicative f => a -> f a
pure AltType
alt_type
BcM ([(AltCon, [Id], GenStgExpr 'Vanilla)] -> GenStgExpr 'Vanilla)
-> BcM [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((AltCon, [Id], GenStgExpr 'Vanilla)
-> BcM (AltCon, [Id], GenStgExpr 'Vanilla))
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> BcM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AltCon, [Id], GenStgExpr 'Vanilla)
-> BcM (AltCon, [Id], GenStgExpr 'Vanilla)
GenStgAlt 'Vanilla -> BcM (GenStgAlt 'Vanilla)
bcPrepAlt [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts
bcPrepExpr lit :: GenStgExpr 'Vanilla
lit@StgLit{} = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
lit
bcPrepExpr (StgApp Id
x [])
| Id -> Bool
isNNLJoinPoint Id
x = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$
Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp (Id -> Id
protectNNLJoinPointId Id
x) [Id -> StgArg
StgVarArg Id
voidPrimId]
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgApp{} = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgConApp{} = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgOpApp{} = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app
bcPrepAlt :: StgAlt -> BcM StgAlt
bcPrepAlt :: GenStgAlt 'Vanilla -> BcM (GenStgAlt 'Vanilla)
bcPrepAlt (AltCon
ac, [BinderP 'Vanilla]
bndrs, GenStgExpr 'Vanilla
expr) = (,,) AltCon
ac [Id]
[BinderP 'Vanilla]
bndrs (GenStgExpr 'Vanilla -> (AltCon, [Id], GenStgExpr 'Vanilla))
-> BcM (GenStgExpr 'Vanilla)
-> BcM (AltCon, [Id], GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepBind :: StgBinding -> BcM StgBinding
bcPrepBind :: GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind (StgNonRec BinderP 'Vanilla
bndr StgRhs
rhs) =
let (Id
bndr', StgRhs
rhs') = (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind (Id
BinderP 'Vanilla
bndr, StgRhs
rhs)
in BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
bndr' (StgRhs -> GenStgBinding 'Vanilla)
-> BcM StgRhs -> BcM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgRhs -> BcM StgRhs
bcPrepRHS StgRhs
rhs'
bcPrepBind (StgRec [(BinderP 'Vanilla, StgRhs)]
bnds) =
[(Id, StgRhs)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([(Id, StgRhs)] -> GenStgBinding 'Vanilla)
-> BcM [(Id, StgRhs)] -> BcM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, StgRhs) -> BcM (Id, StgRhs))
-> [(Id, StgRhs)] -> BcM [(Id, StgRhs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((\(Id
b,StgRhs
r) -> (,) Id
b (StgRhs -> (Id, StgRhs)) -> BcM StgRhs -> BcM (Id, StgRhs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgRhs -> BcM StgRhs
bcPrepRHS StgRhs
r) ((Id, StgRhs) -> BcM (Id, StgRhs))
-> ((Id, StgRhs) -> (Id, StgRhs))
-> (Id, StgRhs)
-> BcM (Id, StgRhs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind)
[(Id, StgRhs)]
[(BinderP 'Vanilla, StgRhs)]
bnds
bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind (Id
x, StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
cc UpdateFlag
upd_flag [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
body)
| Id -> Bool
isNNLJoinPoint Id
x
= ( Id -> Id
protectNNLJoinPointId Id
x
, XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
cc UpdateFlag
upd_flag ([Id]
[BinderP 'Vanilla]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId]) GenStgExpr 'Vanilla
body)
bcPrepSingleBind (Id, StgRhs)
bnd = (Id, StgRhs)
bnd
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 -> WordOff
forall a. String -> a
panic (String -> WordOff) -> String -> WordOff
forall a b. (a -> b) -> a -> b
$ String
"GHC.StgToByteCode.bytesToWords: bytes=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bytes
wordSize :: Platform -> ByteOff
wordSize :: Platform -> ByteOff
wordSize Platform
platform = Int -> ByteOff
ByteOff (Platform -> Int
platformWordSizeInBytes Platform
platform)
type Sequel = ByteOff
type StackDepth = ByteOff
type BCEnv = Map Id StackDepth
mkProtoBCO
:: Platform
-> name
-> BCInstrList
-> Either [CgStgAlt] (CgStgRhs)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO :: Platform
-> name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform name
nm BCInstrList
instrs_ordlist Either [CgStgAlt] CgStgRhs
origin Int
arity Word16
bitmap_size [StgWord]
bitmap Bool
is_ret [FFIInfo]
ffis
= ProtoBCO :: forall a.
a
-> [BCInstr]
-> [StgWord]
-> Word16
-> Int
-> Either [CgStgAlt] CgStgRhs
-> [FFIInfo]
-> ProtoBCO a
ProtoBCO {
protoBCOName :: name
protoBCOName = name
nm,
protoBCOInstrs :: [BCInstr]
protoBCOInstrs = [BCInstr]
maybe_with_stack_check,
protoBCOBitmap :: [StgWord]
protoBCOBitmap = [StgWord]
bitmap,
protoBCOBitmapSize :: Word16
protoBCOBitmapSize = Word16
bitmap_size,
protoBCOArity :: Int
protoBCOArity = Int
arity,
protoBCOExpr :: Either [CgStgAlt] CgStgRhs
protoBCOExpr = Either [CgStgAlt] CgStgRhs
origin,
protoBCOFFIs :: [FFIInfo]
protoBCOFFIs = [FFIInfo]
ffis
}
where
maybe_with_stack_check :: [BCInstr]
maybe_with_stack_check
| Bool
is_ret Bool -> Bool -> Bool
&& Word
stack_usage 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 (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 (BCInstrList -> [BCInstr]
forall a. OrdList a -> [a]
fromOL BCInstrList
instrs_ordlist)
peep :: [BCInstr] -> [BCInstr]
peep (PUSH_L Word16
off1 : PUSH_L Word16
off2 : PUSH_L Word16
off3 : [BCInstr]
rest)
= Word16 -> Word16 -> Word16 -> BCInstr
PUSH_LLL Word16
off1 (Word16
off2Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
1) (Word16
off3Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
2) BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
peep (PUSH_L Word16
off1 : PUSH_L Word16
off2 : [BCInstr]
rest)
= Word16 -> Word16 -> BCInstr
PUSH_LL Word16
off1 (Word16
off2Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
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]
take (Platform -> ArgRep -> Int
argRepSizeW Platform
platform ArgRep
rep) (Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True) [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
non_void :: [ArgRep] -> [ArgRep]
non_void :: [ArgRep] -> [ArgRep]
non_void = (ArgRep -> Bool) -> [ArgRep] -> [ArgRep]
forall a. (a -> Bool) -> [a] -> [a]
filter ArgRep -> Bool
nv
where nv :: ArgRep -> Bool
nv ArgRep
V = Bool
False
nv ArgRep
_ = Bool
True
schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind (Id
id, CgStgRhs
rhs)
| Just DataCon
data_con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
id,
DataCon -> Bool
isNullaryRepDataCon DataCon
data_con = do
Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> Name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id) ([BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL [DataCon -> Word16 -> BCInstr
PACK DataCon
data_con Word16
0, BCInstr
ENTER])
(CgStgRhs -> Either [(AltCon, [Id], GenStgExpr 'CodeGen)] CgStgRhs
forall a b. b -> Either a b
Right CgStgRhs
rhs) Int
0 Word16
0 [] Bool
False)
| Bool
otherwise
= [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [] (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], GenStgExpr 'CodeGen)
-> BcM (ProtoBCO Name)
schemeR_wrk [Id]
fvs Name
nm CgStgRhs
rhs (CgStgRhs -> ([Id], GenStgExpr 'CodeGen)
collect CgStgRhs
rhs)
collect :: CgStgRhs -> ([Var], CgStgExpr)
collect :: CgStgRhs -> ([Id], GenStgExpr 'CodeGen)
collect (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
args GenStgExpr 'CodeGen
body) = ([Id]
[BinderP 'CodeGen]
args, GenStgExpr 'CodeGen
body)
collect (StgRhsCon CostCentreStack
_cc DataCon
dc ConstructorNumber
cnum [StgTickish]
_ticks [StgArg]
args) = ([], DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr 'CodeGen
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> 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], GenStgExpr 'CodeGen)
-> BcM (ProtoBCO Name)
schemeR_wrk [Id]
fvs Name
nm CgStgRhs
original_body ([Id]
args, GenStgExpr 'CodeGen
body)
= do
Profile
profile <- BcM Profile
getProfile
let
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
all_args :: [Id]
all_args = [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
fvs
arity :: Int
arity = [Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
all_args
szsb_args :: [ByteOff]
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
sum_szsb_args = [ByteOff] -> ByteOff
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ByteOff]
szsb_args
p_init :: Map Id ByteOff
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 :: [Bool]
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
bcIdArgRep Platform
platform) [Id]
all_args))
bitmap_size :: Word16
bitmap_size = [Bool] -> Word16
forall i a. Num i => [a] -> i
genericLength [Bool]
bits
bitmap :: [StgWord]
bitmap = Platform -> [Bool] -> [StgWord]
mkBitmap Platform
platform [Bool]
bits
BCInstrList
body_code <- ByteOff -> Map Id ByteOff -> GenStgExpr 'CodeGen -> BcM BCInstrList
schemeER_wrk ByteOff
sum_szsb_args Map Id ByteOff
p_init GenStgExpr 'CodeGen
body
([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> Name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
nm BCInstrList
body_code (CgStgRhs -> Either [(AltCon, [Id], GenStgExpr 'CodeGen)] CgStgRhs
forall a b. b -> Either a b
Right CgStgRhs
original_body)
Int
arity Word16
bitmap_size [StgWord]
bitmap Bool
False)
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeER_wrk :: ByteOff -> Map Id ByteOff -> GenStgExpr 'CodeGen -> BcM BCInstrList
schemeER_wrk ByteOff
d Map Id ByteOff
p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
tick_ty Int
tick_no [XTickishId 'TickishPassStg]
fvs) GenStgExpr 'CodeGen
rhs)
= do BCInstrList
code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p GenStgExpr 'CodeGen
rhs
Array Int (RemotePtr CostCentre)
cc_arr <- BcM (Array Int (RemotePtr CostCentre))
getCCArray
ModuleName
this_mod <- Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> BcM Module -> BcM ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Module
getCurrentModule
Platform
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 :: [Maybe (Id, Word16)]
idOffSets = Platform
-> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets Platform
platform ByteOff
d Map Id ByteOff
p [Id]
[XTickishId 'TickishPassStg]
fvs
let breakInfo :: CgBreakInfo
breakInfo = CgBreakInfo :: [Maybe (Id, Word16)] -> Type -> CgBreakInfo
CgBreakInfo
{ cgb_vars :: [Maybe (Id, Word16)]
cgb_vars = [Maybe (Id, Word16)]
idOffSets
, cgb_resty :: Type
cgb_resty = Type
XBreakpoint 'TickishPassStg
tick_ty
}
Int -> CgBreakInfo -> BcM ()
newBreakInfo Int
tick_no CgBreakInfo
breakInfo
HscEnv
hsc_env <- BcM HscEnv
getHscEnv
let cc :: RemotePtr CostCentre
cc | Just Interp
interp <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
, Interp -> Bool
interpreterProfiled Interp
interp
= Array Int (RemotePtr CostCentre)
cc_arr 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 breakInstr :: BCInstr
breakInstr = Word16 -> Unique -> RemotePtr CostCentre -> BCInstr
BRK_FUN (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tick_no) (ModuleName -> Unique
forall a. Uniquable a => a -> Unique
getUnique ModuleName
this_mod) RemotePtr CostCentre
cc
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList -> BcM BCInstrList) -> BCInstrList -> BcM BCInstrList
forall a b. (a -> b) -> a -> b
$ BCInstr
breakInstr BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
code
schemeER_wrk ByteOff
d Map Id ByteOff
p GenStgExpr 'CodeGen
rhs = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p GenStgExpr 'CodeGen
rhs
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets :: Platform
-> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets Platform
platform ByteOff
depth Map Id ByteOff
env = (Id -> Maybe (Id, Word16)) -> [Id] -> [Maybe (Id, Word16)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Maybe (Id, Word16)
getOffSet
where
getOffSet :: Id -> Maybe (Id, Word16)
getOffSet Id
id = case Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
id Map Id ByteOff
env of
Maybe ByteOff
Nothing -> Maybe (Id, Word16)
forall a. Maybe a
Nothing
Just ByteOff
offset ->
let !var_depth_ws :: Word16
var_depth_ws =
WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ 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, Word16) -> Maybe (Id, Word16)
forall a. a -> Maybe a
Just (Id
id, Word16
var_depth_ws)
truncIntegral16 :: Integral a => a -> Word16
truncIntegral16 :: a -> Word16
truncIntegral16 a
w
| a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16)
= String -> Word16
forall a. String -> a
panic String
"stack depth overflow"
| Bool
otherwise
= a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w
trunc16B :: ByteOff -> Word16
trunc16B :: ByteOff -> Word16
trunc16B = ByteOff -> Word16
forall a. Integral a => a -> Word16
truncIntegral16
trunc16W :: WordOff -> Word16
trunc16W :: WordOff -> Word16
trunc16W = WordOff -> Word16
forall a. Integral a => a -> Word16
truncIntegral16
fvsToEnv :: BCEnv -> CgStgRhs -> [Id]
fvsToEnv :: Map Id ByteOff -> CgStgRhs -> [Id]
fvsToEnv Map Id ByteOff
p (StgRhsClosure XRhsClosure 'CodeGen
fvs CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
_ GenStgExpr 'CodeGen
_) =
[Id
v | Id
v <- DVarSet -> [Id]
dVarSetElems DVarSet
XRhsClosure 'CodeGen
fvs,
Id
v Id -> Map Id ByteOff -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Id ByteOff
p]
fvsToEnv Map Id ByteOff
_ CgStgRhs
_ = []
returnUnboxedAtom
:: StackDepth
-> Sequel
-> BCEnv
-> StgArg
-> BcM BCInstrList
returnUnboxedAtom :: ByteOff -> ByteOff -> Map Id ByteOff -> StgArg -> BcM BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map Id ByteOff
p StgArg
e = do
let reps :: [PrimRep]
reps = case StgArg
e of
StgLitArg Literal
lit -> HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRepArgs (Literal -> Type
literalType Literal
lit)
StgVarArg Id
i -> Id -> [PrimRep]
bcIdPrimReps Id
i
(BCInstrList
push, ByteOff
szb) <- ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
e
BCInstrList
ret <- ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM BCInstrList
returnUnboxedReps ByteOff
d ByteOff
s ByteOff
szb [PrimRep]
reps
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
ret)
returnUnboxedReps
:: StackDepth
-> Sequel
-> ByteOff
-> [PrimRep]
-> BcM BCInstrList
returnUnboxedReps :: ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM BCInstrList
returnUnboxedReps ByteOff
d ByteOff
s ByteOff
szb [PrimRep]
reps = do
Profile
profile <- BcM Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
non_void :: PrimRep -> Bool
non_void PrimRep
VoidRep = Bool
False
non_void PrimRep
_ = Bool
True
BCInstrList
ret <- case (PrimRep -> Bool) -> [PrimRep] -> [PrimRep]
forall a. (a -> Bool) -> [a] -> [a]
filter PrimRep -> Bool
non_void [PrimRep]
reps of
[] -> BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (BCInstr -> BCInstrList) -> BCInstr -> BCInstrList
forall a b. (a -> b) -> a -> b
$ ArgRep -> BCInstr
RETURN_UBX ArgRep
V)
[PrimRep
rep] -> BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (BCInstr -> BCInstrList) -> BCInstr -> BCInstrList
forall a b. (a -> b) -> a -> b
$ ArgRep -> BCInstr
RETURN_UBX (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep))
[PrimRep]
nv_reps -> do
let (TupleInfo
tuple_info, [(PrimRep, ByteOff)]
args_offsets) = Profile
-> ByteOff
-> (PrimRep -> CmmType)
-> [PrimRep]
-> (TupleInfo, [(PrimRep, ByteOff)])
forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile ByteOff
0 (Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform) [PrimRep]
nv_reps
args_ptrs :: [(Bool, ByteOff)]
args_ptrs = ((PrimRep, ByteOff) -> (Bool, ByteOff))
-> [(PrimRep, ByteOff)] -> [(Bool, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PrimRep
rep, ByteOff
off) -> (ArgRep -> Bool
isFollowableArg (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep), ByteOff
off)) [(PrimRep, ByteOff)]
args_offsets
ProtoBCO Name
tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO Platform
platform TupleInfo
tuple_info [(Bool, ByteOff)]
args_ptrs)
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList -> BcM BCInstrList) -> BCInstrList -> BcM BCInstrList
forall a b. (a -> b) -> a -> b
$ Literal -> Word16 -> BCInstr
PUSH_UBX (Platform -> TupleInfo -> Literal
mkTupleInfoLit Platform
platform TupleInfo
tuple_info) Word16
1 BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL`
ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
tuple_bco BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL`
BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
RETURN_TUPLE
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return ( Platform -> ByteOff -> ByteOff -> BCInstrList
mkSlideB Platform
platform ByteOff
szb (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
ret)
returnUnboxedTuple
:: StackDepth
-> Sequel
-> BCEnv
-> [StgArg]
-> BcM BCInstrList
returnUnboxedTuple :: ByteOff -> ByteOff -> Map Id ByteOff -> [StgArg] -> BcM BCInstrList
returnUnboxedTuple ByteOff
d ByteOff
s Map Id ByteOff
p [StgArg]
es = do
Profile
profile <- BcM Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
arg_ty :: StgArg -> CmmType
arg_ty StgArg
e = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform (StgArg -> PrimRep
atomPrimRep StgArg
e)
(TupleInfo
tuple_info, [(StgArg, ByteOff)]
tuple_components) = Profile
-> ByteOff
-> (StgArg -> CmmType)
-> [StgArg]
-> (TupleInfo, [(StgArg, ByteOff)])
forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile ByteOff
d StgArg -> CmmType
arg_ty [StgArg]
es
go :: ByteOff
-> [BCInstrList] -> [(StgArg, ByteOff)] -> BcM [BCInstrList]
go ByteOff
_ [BCInstrList]
pushes [] = [BCInstrList] -> BcM [BCInstrList]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BCInstrList] -> [BCInstrList]
forall a. [a] -> [a]
reverse [BCInstrList]
pushes)
go !ByteOff
dd [BCInstrList]
pushes ((StgArg
a, ByteOff
off):[(StgArg, ByteOff)]
cs) = do (BCInstrList
push, ByteOff
szb) <- ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p StgArg
a
MASSERT(off == dd + szb)
ByteOff
-> [BCInstrList] -> [(StgArg, ByteOff)] -> BcM [BCInstrList]
go (ByteOff
dd ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
szb) (BCInstrList
pushBCInstrList -> [BCInstrList] -> [BCInstrList]
forall a. a -> [a] -> [a]
:[BCInstrList]
pushes) [(StgArg, ByteOff)]
cs
[BCInstrList]
pushes <- ByteOff
-> [BCInstrList] -> [(StgArg, ByteOff)] -> BcM [BCInstrList]
go ByteOff
d [] [(StgArg, ByteOff)]
tuple_components
BCInstrList
ret <- ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM BCInstrList
returnUnboxedReps ByteOff
d
ByteOff
s
(Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (WordOff -> ByteOff) -> WordOff -> ByteOff
forall a b. (a -> b) -> a -> b
$ TupleInfo -> WordOff
tupleSize TupleInfo
tuple_info)
((StgArg -> PrimRep) -> [StgArg] -> [PrimRep]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> PrimRep
atomPrimRep [StgArg]
es)
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return ([BCInstrList] -> BCInstrList
forall a. Monoid a => [a] -> a
mconcat [BCInstrList]
pushes BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
ret)
schemeE
:: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeE :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLit Literal
lit) = ByteOff -> ByteOff -> Map Id ByteOff -> StgArg -> BcM BCInstrList
returnUnboxedAtom 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 BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
x)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: GenStgExpr 'CodeGen
e@(StgApp {}) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: GenStgExpr 'CodeGen
e@(StgConApp {}) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: GenStgExpr 'CodeGen
e@(StgOpApp {}) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLetNoEscape XLetNoEscape 'CodeGen
xlet GenStgBinding 'CodeGen
bnd GenStgExpr 'CodeGen
body)
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (XLet 'CodeGen
-> GenStgBinding 'CodeGen
-> GenStgExpr 'CodeGen
-> GenStgExpr 'CodeGen
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'CodeGen
XLetNoEscape 'CodeGen
xlet GenStgBinding 'CodeGen
bnd GenStgExpr 'CodeGen
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))
GenStgExpr 'CodeGen
body)
= do
BCInstrList
alloc_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM BCInstrList
mkConAppCode ByteOff
d ByteOff
s Map Id ByteOff
p DataCon
data_con [StgArg]
args
Platform
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 !d2 :: ByteOff
d2 = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform
BCInstrList
body_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d2 ByteOff
s (Id -> ByteOff -> Map Id ByteOff -> Map Id ByteOff
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
BinderP 'CodeGen
x ByteOff
d2 Map Id ByteOff
p) GenStgExpr 'CodeGen
body
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
alloc_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
body_code)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLet XLet 'CodeGen
_ext GenStgBinding 'CodeGen
binds GenStgExpr 'CodeGen
body) = do
Platform
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 ([Id]
xs,[CgStgRhs]
rhss) = case GenStgBinding 'CodeGen
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 :: WordOff
n_binds = [Id] -> WordOff
forall i a. Num i => [a] -> i
genericLength [Id]
xs
fvss :: [[Id]]
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 :: Id -> Word16
size_w = WordOff -> Word16
trunc16W (WordOff -> Word16) -> (Id -> WordOff) -> Id -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> WordOff
idSizeW Platform
platform
sizes :: [Word16]
sizes = ([Id] -> Word16) -> [[Id]] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map (\[Id]
rhs_fvs -> [Word16] -> Word16
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Id -> Word16) -> [Id] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Word16
size_w [Id]
rhs_fvs)) [[Id]]
fvss
arities :: [Word16]
arities = (CgStgRhs -> Word16) -> [CgStgRhs] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map ([Id] -> Word16
forall i a. Num i => [a] -> i
genericLength ([Id] -> Word16) -> (CgStgRhs -> [Id]) -> CgStgRhs -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], GenStgExpr 'CodeGen) -> [Id]
forall a b. (a, b) -> a
fst (([Id], GenStgExpr 'CodeGen) -> [Id])
-> (CgStgRhs -> ([Id], GenStgExpr 'CodeGen)) -> CgStgRhs -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CgStgRhs -> ([Id], GenStgExpr 'CodeGen)
collect) [CgStgRhs]
rhss
offsets :: [ByteOff]
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' :: 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] -> [ByteOff] -> [(Id, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zipE [Id]
xs [ByteOff]
offsets) Map Id ByteOff
p
d' :: ByteOff
d' = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
n_binds
zipE :: [a] -> [b] -> [(a, b)]
zipE = String -> [a] -> [b] -> [(a, b)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"schemeE"
build_thunk
:: StackDepth
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
build_thunk :: ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
build_thunk ByteOff
_ [] Word16
size ProtoBCO Name
bco Word16
off Word16
arity
= BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
bco BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Word16 -> Word16 -> BCInstr
mkap (Word16
offWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+Word16
size) Word16
size))
where
mkap :: Word16 -> Word16 -> BCInstr
mkap | Word16
arity Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0 = Word16 -> Word16 -> BCInstr
MKAP
| Bool
otherwise = Word16 -> Word16 -> BCInstr
MKPAP
build_thunk ByteOff
dd (Id
fv:[Id]
fvs) Word16
size ProtoBCO Name
bco Word16
off Word16
arity = do
(BCInstrList
push_code, ByteOff
pushed_szb) <- ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p' (Id -> StgArg
StgVarArg Id
fv)
BCInstrList
more_push_code <-
ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
build_thunk (ByteOff
dd ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
pushed_szb) [Id]
fvs Word16
size ProtoBCO Name
bco Word16
off Word16
arity
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
more_push_code)
alloc_code :: BCInstrList
alloc_code = [BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL ((Word16 -> Word16 -> BCInstr) -> [Word16] -> [Word16] -> [BCInstr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word16 -> Word16 -> BCInstr
mkAlloc [Word16]
sizes [Word16]
arities)
where mkAlloc :: Word16 -> Word16 -> BCInstr
mkAlloc Word16
sz Word16
0
| Bool
is_tick = Word16 -> BCInstr
ALLOC_AP_NOUPD Word16
sz
| Bool
otherwise = Word16 -> BCInstr
ALLOC_AP Word16
sz
mkAlloc Word16
sz Word16
arity = Word16 -> Word16 -> BCInstr
ALLOC_PAP Word16
arity Word16
sz
is_tick :: Bool
is_tick = case GenStgBinding 'CodeGen
binds of
StgNonRec BinderP 'CodeGen
id CgStgRhs
_ -> OccName -> FastString
occNameFS (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
-> [Id]
-> a
-> CgStgRhs
-> Word16
-> Word16
-> Word16
-> BcM BCInstrList
compile_bind ByteOff
d' [Id]
fvs a
x (CgStgRhs
rhs::CgStgRhs) Word16
size Word16
arity Word16
off = do
ProtoBCO Name
bco <- [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [Id]
fvs (a -> Name
forall a. NamedThing a => a -> Name
getName a
x,CgStgRhs
rhs)
ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
build_thunk ByteOff
d' [Id]
fvs Word16
size ProtoBCO Name
bco Word16
off Word16
arity
compile_binds :: [BcM BCInstrList]
compile_binds =
[ ByteOff
-> [Id]
-> Id
-> CgStgRhs
-> Word16
-> Word16
-> Word16
-> BcM BCInstrList
forall a.
NamedThing a =>
ByteOff
-> [Id]
-> a
-> CgStgRhs
-> Word16
-> Word16
-> Word16
-> BcM BCInstrList
compile_bind ByteOff
d' [Id]
fvs Id
x CgStgRhs
rhs Word16
size Word16
arity (WordOff -> Word16
trunc16W WordOff
n)
| ([Id]
fvs, Id
x, CgStgRhs
rhs, Word16
size, Word16
arity, WordOff
n) <-
[[Id]]
-> [Id]
-> [CgStgRhs]
-> [Word16]
-> [Word16]
-> [WordOff]
-> [([Id], Id, CgStgRhs, Word16, Word16, 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 [Word16]
sizes [Word16]
arities [WordOff
n_binds, WordOff
n_bindsWordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-WordOff
1 .. WordOff
1]
]
BCInstrList
body_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d' ByteOff
s Map Id ByteOff
p' GenStgExpr 'CodeGen
body
[BCInstrList]
thunk_codes <- [BcM BCInstrList] -> BcM [BCInstrList]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [BcM BCInstrList]
compile_binds
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
alloc_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [BCInstrList] -> BCInstrList
forall a. [OrdList a] -> OrdList a
concatOL [BCInstrList]
thunk_codes BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
body_code)
schemeE ByteOff
_d ByteOff
_s Map Id ByteOff
_p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
_ Int
bp_id [XTickishId 'TickishPassStg]
_) GenStgExpr 'CodeGen
_rhs)
= String -> BcM BCInstrList
forall a. 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
_ GenStgExpr 'CodeGen
rhs) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
rhs
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgCase GenStgExpr 'CodeGen
scrut BinderP 'CodeGen
_ AltType
_ []) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
scrut
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgCase GenStgExpr 'CodeGen
scrut BinderP 'CodeGen
bndr AltType
_ [CgStgAlt]
alts)
= ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
scrut Id
BinderP 'CodeGen
bndr [CgStgAlt]
alts
isNNLJoinPoint :: Id -> Bool
isNNLJoinPoint :: Id -> Bool
isNNLJoinPoint Id
x = Id -> Bool
isJoinId Id
x Bool -> Bool -> Bool
&&
Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= HasDebugCallStack => Type -> Maybe Bool
Type -> Maybe Bool
isLiftedType_maybe (Id -> Type
idType Id
x)
protectNNLJoinPointId :: Id -> Id
protectNNLJoinPointId :: Id -> Id
protectNNLJoinPointId Id
x
= ASSERT( isNNLJoinPoint x )
(Type -> Type) -> Id -> Id
updateIdTypeButNotMult (Type
unboxedUnitTy Type -> Type -> Type
`mkVisFunTyMany`) Id
x
schemeT :: StackDepth
-> Sequel
-> BCEnv
-> CgStgExpr
-> BcM BCInstrList
schemeT :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
app
| Just (Id
arg, [Name]
constr_names) <- GenStgExpr 'CodeGen -> Maybe (Id, [Name])
maybe_is_tagToEnum_call GenStgExpr 'CodeGen
app
= ByteOff
-> ByteOff -> Map Id ByteOff -> Id -> [Name] -> BcM BCInstrList
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 BCInstrList
generateCCall ByteOff
d ByteOff
s Map Id ByteOff
p CCallSpec
ccall_spec Type
result_ty ([StgArg] -> [StgArg]
forall a. [a] -> [a]
reverse [StgArg]
args)
else BcM BCInstrList
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 BCInstrList
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{} [StgArg]
_args Type
_ty)
= BcM BCInstrList
forall a. a
unsupportedCConvException
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgConApp DataCon
con ConstructorNumber
_ext [StgArg]
args [Type]
_tys)
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con
= ByteOff -> ByteOff -> Map Id ByteOff -> [StgArg] -> BcM BCInstrList
returnUnboxedTuple ByteOff
d ByteOff
s Map Id ByteOff
p [StgArg]
args
| Bool
otherwise
= do BCInstrList
alloc_con <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM BCInstrList
mkConAppCode ByteOff
d ByteOff
s Map Id ByteOff
p DataCon
con [StgArg]
args
Platform
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
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
alloc_con BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Word16 -> WordOff -> BCInstrList
mkSlideW Word16
1 (Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff -> WordOff) -> ByteOff -> WordOff
forall a b. (a -> b) -> a -> b
$ ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s) BCInstrList -> BCInstr -> BCInstrList
forall a. OrdList a -> a -> OrdList a
`snocOL`
BCInstr
ENTER)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgApp Id
fn [StgArg]
args)
= ByteOff
-> ByteOff -> Map Id ByteOff -> Id -> [StgArg] -> BcM BCInstrList
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
_ GenStgExpr 'CodeGen
e = String -> SDoc -> BcM BCInstrList
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToByteCode.schemeT"
(StgPprOpts -> GenStgExpr 'CodeGen -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
shortStgPprOpts GenStgExpr 'CodeGen
e)
mkConAppCode
:: StackDepth
-> Sequel
-> BCEnv
-> DataCon
-> [StgArg]
-> BcM BCInstrList
mkConAppCode :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM BCInstrList
mkConAppCode ByteOff
orig_d ByteOff
_ Map Id ByteOff
p DataCon
con [StgArg]
args = BcM BCInstrList
app_code
where
app_code :: BcM BCInstrList
app_code = do
Profile
profile <- BcM Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
non_voids :: [NonVoid (PrimRep, StgArg)]
non_voids =
[ (PrimRep, StgArg) -> NonVoid (PrimRep, StgArg)
forall a. a -> NonVoid a
NonVoid (PrimRep
prim_rep, StgArg
arg)
| StgArg
arg <- [StgArg]
args
, let prim_rep :: PrimRep
prim_rep = StgArg -> PrimRep
atomPrimRep StgArg
arg
, Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prim_rep)
]
(Int
_, Int
_, [FieldOffOrPadding StgArg]
args_offsets) =
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, StgArg)]
-> (Int, Int, [FieldOffOrPadding StgArg])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
StdHeader [NonVoid (PrimRep, StgArg)]
non_voids
do_pushery :: ByteOff -> [FieldOffOrPadding StgArg] -> BcM BCInstrList
do_pushery !ByteOff
d (FieldOffOrPadding StgArg
arg : [FieldOffOrPadding StgArg]
args) = do
(BCInstrList
push, ByteOff
arg_bytes) <- case FieldOffOrPadding StgArg
arg of
(Padding Int
l Int
_) -> (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff))
-> (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall a b. (a -> b) -> a -> b
$! Int -> (BCInstrList, ByteOff)
pushPadding Int
l
(FieldOff NonVoid StgArg
a Int
_) -> ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushConstrAtom ByteOff
d Map Id ByteOff
p (NonVoid StgArg -> StgArg
forall a. NonVoid a -> a
fromNonVoid NonVoid StgArg
a)
BCInstrList
more_push_code <- ByteOff -> [FieldOffOrPadding StgArg] -> BcM BCInstrList
do_pushery (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
arg_bytes) [FieldOffOrPadding StgArg]
args
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
more_push_code)
do_pushery !ByteOff
d [] = do
let !n_arg_words :: Word16
n_arg_words = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
orig_d)
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (DataCon -> Word16 -> BCInstr
PACK DataCon
con Word16
n_arg_words))
ByteOff -> [FieldOffOrPadding StgArg] -> BcM BCInstrList
do_pushery ByteOff
orig_d ([FieldOffOrPadding StgArg] -> [FieldOffOrPadding StgArg]
forall a. [a] -> [a]
reverse [FieldOffOrPadding StgArg]
args_offsets)
doTailCall
:: StackDepth
-> Sequel
-> BCEnv
-> Id
-> [StgArg]
-> BcM BCInstrList
doTailCall :: ByteOff
-> ByteOff -> Map Id ByteOff -> Id -> [StgArg] -> BcM BCInstrList
doTailCall ByteOff
init_d ByteOff
s Map Id ByteOff
p Id
fn [StgArg]
args = do
Platform
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
ByteOff -> [StgArg] -> [ArgRep] -> BcM BCInstrList
do_pushes ByteOff
init_d [StgArg]
args ((StgArg -> ArgRep) -> [StgArg] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> StgArg -> ArgRep
atomRep Platform
platform) [StgArg]
args)
where
do_pushes :: ByteOff -> [StgArg] -> [ArgRep] -> BcM BCInstrList
do_pushes !ByteOff
d [] [ArgRep]
reps = do
ASSERT( null reps ) return ()
(BCInstrList
push_fn, ByteOff
sz) <- ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
fn)
Platform
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
ASSERT( sz == wordSize platform ) return ()
let slide :: BCInstrList
slide = Platform -> ByteOff -> ByteOff -> BCInstrList
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)
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_fn BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (BCInstrList
slide BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
ENTER))
do_pushes !ByteOff
d [StgArg]
args [ArgRep]
reps = do
let (BCInstr
push_apply, Int
n, [ArgRep]
rest_of_reps) = [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq [ArgRep]
reps
([StgArg]
these_args, [StgArg]
rest_of_args) = Int -> [StgArg] -> ([StgArg], [StgArg])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [StgArg]
args
(ByteOff
next_d, BCInstrList
push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, BCInstrList)
push_seq ByteOff
d [StgArg]
these_args
Platform
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
BCInstrList
instrs <- ByteOff -> [StgArg] -> [ArgRep] -> BcM BCInstrList
do_pushes (ByteOff
next_d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform) [StgArg]
rest_of_args [ArgRep]
rest_of_reps
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (BCInstr
push_apply BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
instrs))
push_seq :: ByteOff -> [StgArg] -> BcM (ByteOff, BCInstrList)
push_seq ByteOff
d [] = (ByteOff, BCInstrList) -> BcM (ByteOff, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
d, BCInstrList
forall a. OrdList a
nilOL)
push_seq ByteOff
d (StgArg
arg:[StgArg]
args) = do
(BCInstrList
push_code, ByteOff
sz) <- ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
arg
(ByteOff
final_d, BCInstrList
more_push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, BCInstrList)
push_seq (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
sz) [StgArg]
args
(ByteOff, BCInstrList) -> BcM (ByteOff, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
final_d, BCInstrList
push_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
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]
_
= String -> (BCInstr, Int, [ArgRep])
forall a. String -> a
panic String
"GHC.StgToByteCode.findPushSeq"
doCase
:: StackDepth
-> Sequel
-> BCEnv
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
doCase :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
scrut Id
bndr [CgStgAlt]
alts
= do
Profile
profile <- BcM Profile
getProfile
HscEnv
hsc_env <- BcM HscEnv
getHscEnv
let
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
ubx_tuple_frame :: Bool
ubx_tuple_frame =
(Type -> Bool
isUnboxedTupleType Type
bndr_ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
bndr_ty) Bool -> Bool -> Bool
&&
[ArgRep] -> 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
non_void_arg_reps :: [ArgRep]
non_void_arg_reps = [ArgRep] -> [ArgRep]
non_void (Platform -> Type -> [ArgRep]
typeArgReps Platform
platform Type
bndr_ty)
profiling :: Bool
profiling
| Just Interp
interp <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
= Interp -> Bool
interpreterProfiled Interp
interp
| Bool
otherwise = Bool
False
ret_frame_size_b :: StackDepth
ret_frame_size_b :: ByteOff
ret_frame_size_b | Bool
ubx_tuple_frame =
(if Bool
profiling then ByteOff
5 else ByteOff
4) 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 :: ByteOff
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 :: ByteOff
unlifted_itbl_size_b | Bool
isAlgCase = ByteOff
0
| Bool
ubx_tuple_frame = ByteOff
3 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
| Bool
otherwise = Platform -> ByteOff
wordSize Platform
platform
(ByteOff
bndr_size, TupleInfo
tuple_info, [(PrimRep, ByteOff)]
args_offsets)
| Bool
ubx_tuple_frame =
let bndr_ty :: PrimRep -> CmmType
bndr_ty = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform
bndr_reps :: [PrimRep]
bndr_reps = (PrimRep -> Bool) -> [PrimRep] -> [PrimRep]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (PrimRep -> Bool) -> PrimRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.PrimRep -> Bool
isVoidRep) (Id -> [PrimRep]
bcIdPrimReps Id
bndr)
(TupleInfo
tuple_info, [(PrimRep, ByteOff)]
args_offsets) =
Profile
-> ByteOff
-> (PrimRep -> CmmType)
-> [PrimRep]
-> (TupleInfo, [(PrimRep, ByteOff)])
forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile ByteOff
0 PrimRep -> CmmType
bndr_ty [PrimRep]
bndr_reps
in ( Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (TupleInfo -> WordOff
tupleSize TupleInfo
tuple_info)
, TupleInfo
tuple_info
, [(PrimRep, ByteOff)]
args_offsets
)
| Bool
otherwise = ( Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (Platform -> Id -> WordOff
idSizeW Platform
platform Id
bndr)
, TupleInfo
voidTupleInfo
, []
)
d_bndr :: ByteOff
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_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 :: Map Id ByteOff
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 :: Type
bndr_ty = Id -> Type
idType Id
bndr
isAlgCase :: Bool
isAlgCase = Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
bndr_ty)
codeAlt :: (AltCon, [Id], GenStgExpr 'CodeGen) -> BcM (Discr, BCInstrList)
codeAlt (AltCon
DEFAULT, [Id]
_, GenStgExpr 'CodeGen
rhs)
= do BCInstrList
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts GenStgExpr 'CodeGen
rhs
(Discr, BCInstrList) -> BcM (Discr, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr
NoDiscr, BCInstrList
rhs_code)
codeAlt alt :: (AltCon, [Id], GenStgExpr 'CodeGen)
alt@(AltCon
_, [Id]
bndrs, GenStgExpr 'CodeGen
rhs)
| [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
real_bndrs = do
BCInstrList
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts GenStgExpr 'CodeGen
rhs
(Discr, BCInstrList) -> BcM (Discr, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AltCon, [Id], GenStgExpr 'CodeGen) -> Discr
forall b c. (AltCon, b, c) -> Discr
my_discr (AltCon, [Id], GenStgExpr 'CodeGen)
alt, BCInstrList
rhs_code)
| Type -> Bool
isUnboxedTupleType Type
bndr_ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
bndr_ty =
let bndr_ty :: Id -> CmmType
bndr_ty = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform (PrimRep -> CmmType) -> (Id -> PrimRep) -> Id -> CmmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
bcIdPrimRep
tuple_start :: ByteOff
tuple_start = ByteOff
d_bndr
(TupleInfo
tuple_info, [(Id, ByteOff)]
args_offsets) =
Profile
-> ByteOff
-> (Id -> CmmType)
-> [Id]
-> (TupleInfo, [(Id, ByteOff)])
forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile
ByteOff
0
Id -> CmmType
bndr_ty
[Id]
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 (TupleInfo -> WordOff
tupleSize TupleInfo
tuple_info) ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+
ByteOff
offset)
| (Id
arg, ByteOff
offset) <- [(Id, ByteOff)]
args_offsets
, Bool -> Bool
not (PrimRep -> Bool
isVoidRep (PrimRep -> Bool) -> PrimRep -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> PrimRep
bcIdPrimRep Id
arg)]
Map Id ByteOff
p_alts
in do
BCInstrList
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' GenStgExpr 'CodeGen
rhs
(Discr, BCInstrList) -> BcM (Discr, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr
NoDiscr, BCInstrList
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
[ (PrimRep, Id) -> NonVoid (PrimRep, Id)
forall a. a -> NonVoid a
NonVoid (Id -> PrimRep
bcIdPrimRep Id
id, Id
id)
| NonVoid Id
id <- [Id] -> [NonVoid Id]
nonVoidIds [Id]
real_bndrs
]
size :: WordOff
size = Int -> WordOff
WordOff Int
tot_wds
stack_bot :: ByteOff
stack_bot = ByteOff
d_alts 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
MASSERT(isAlgCase)
BCInstrList
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' GenStgExpr 'CodeGen
rhs
(Discr, BCInstrList) -> BcM (Discr, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AltCon, [Id], GenStgExpr 'CodeGen) -> Discr
forall b c. (AltCon, b, c) -> Discr
my_discr (AltCon, [Id], GenStgExpr 'CodeGen)
alt,
BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
UNPACK (WordOff -> Word16
trunc16W WordOff
size)) BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
rhs_code)
where
real_bndrs :: [Id]
real_bndrs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Id -> Bool
isTyVar [Id]
bndrs
my_discr :: (AltCon, b, c) -> Discr
my_discr (AltCon
DEFAULT, b
_, c
_) = Discr
NoDiscr
my_discr (DataAlt DataCon
dc, b
_, c
_)
| 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))
my_discr (LitAlt Literal
l, b
_, c
_)
= 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
LitNumWord Integer
w -> Word -> Discr
DiscrW (Integer -> Word
forall a. Num a => Integer -> a
fromInteger Integer
w)
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)
Literal
_ -> 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 :: Maybe Int
maybe_ncons
| Bool -> Bool
not Bool
isAlgCase = Maybe Int
forall a. Maybe a
Nothing
| Bool
otherwise
= case [DataCon
dc | (DataAlt DataCon
dc, [Id]
_, GenStgExpr 'CodeGen
_) <- [(AltCon, [Id], GenStgExpr 'CodeGen)]
[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))
([Int]
extra_pointers, Int
extra_slots)
| Bool
ubx_tuple_frame Bool -> Bool -> Bool
&& Bool
profiling = ([Int
1], Int
3)
| Bool
ubx_tuple_frame = ([Int
1], Int
2)
| Bool
otherwise = ([], Int
0)
bitmap_size :: Word16
bitmap_size = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ 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' :: Int
bitmap_size' = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bitmap_size
pointers :: [Int]
pointers =
[Int]
extra_pointers [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
[Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((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
binds :: [(Id, ByteOff)]
binds = Map Id ByteOff -> [(Id, ByteOff)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Id ByteOff
p
rel_slots :: [Int]
rel_slots = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Word16 -> Int) -> [Word16] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word16] -> [Int]) -> [Word16] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Id, ByteOff) -> [Word16]) -> [(Id, ByteOff)] -> [Word16]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Id, ByteOff) -> [Word16]
spread [(Id, ByteOff)]
binds
spread :: (Id, ByteOff) -> [Word16]
spread (Id
id, ByteOff
offset) | Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
id) Bool -> Bool -> Bool
||
Type -> Bool
isUnboxedSumType (Id -> Type
idType Id
id) = []
| ArgRep -> Bool
isFollowableArg (Platform -> Id -> ArgRep
bcIdArgRep Platform
platform Id
id) = [ Word16
rel_offset ]
| Bool
otherwise = []
where rel_offset :: Word16
rel_offset = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
offset)
bitmap :: [StgWord]
bitmap = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform Int
bitmap_size' [Int]
pointers
[(Discr, BCInstrList)]
alt_stuff <- ((AltCon, [Id], GenStgExpr 'CodeGen) -> BcM (Discr, BCInstrList))
-> [(AltCon, [Id], GenStgExpr 'CodeGen)]
-> BcM [(Discr, BCInstrList)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AltCon, [Id], GenStgExpr 'CodeGen) -> BcM (Discr, BCInstrList)
codeAlt [(AltCon, [Id], GenStgExpr 'CodeGen)]
[CgStgAlt]
alts
BCInstrList
alt_final <- Maybe Int -> [(Discr, BCInstrList)] -> BcM BCInstrList
mkMultiBranch Maybe Int
maybe_ncons [(Discr, BCInstrList)]
alt_stuff
let
alt_bco_name :: Name
alt_bco_name = Id -> Name
forall a. NamedThing a => a -> Name
getName Id
bndr
alt_bco :: [FFIInfo] -> ProtoBCO Name
alt_bco = Platform
-> Name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
alt_bco_name BCInstrList
alt_final ([(AltCon, [Id], GenStgExpr 'CodeGen)]
-> Either [(AltCon, [Id], GenStgExpr 'CodeGen)] CgStgRhs
forall a b. a -> Either a b
Left [(AltCon, [Id], GenStgExpr 'CodeGen)]
[CgStgAlt]
alts)
Int
0 Word16
bitmap_size [StgWord]
bitmap Bool
True
BCInstrList
scrut_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM BCInstrList
schemeE (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
save_ccs_size_b)
(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
save_ccs_size_b)
Map Id ByteOff
p GenStgExpr 'CodeGen
scrut
ProtoBCO Name
alt_bco' <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc [FFIInfo] -> ProtoBCO Name
alt_bco
if Bool
ubx_tuple_frame
then do
let args_ptrs :: [(Bool, ByteOff)]
args_ptrs =
((PrimRep, ByteOff) -> (Bool, ByteOff))
-> [(PrimRep, ByteOff)] -> [(Bool, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PrimRep
rep, ByteOff
off) -> (ArgRep -> Bool
isFollowableArg (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep), ByteOff
off))
[(PrimRep, ByteOff)]
args_offsets
ProtoBCO Name
tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO Platform
platform TupleInfo
tuple_info [(Bool, ByteOff)]
args_ptrs)
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> TupleInfo -> ProtoBCO Name -> BCInstr
PUSH_ALTS_TUPLE ProtoBCO Name
alt_bco' TupleInfo
tuple_info ProtoBCO Name
tuple_bco
BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
scrut_code)
else let push_alts :: BCInstr
push_alts
| Bool
isAlgCase
= ProtoBCO Name -> BCInstr
PUSH_ALTS ProtoBCO Name
alt_bco'
| Bool
otherwise
= let unlifted_rep :: ArgRep
unlifted_rep =
case [ArgRep]
non_void_arg_reps of
[] -> ArgRep
V
[ArgRep
rep] -> ArgRep
rep
[ArgRep]
_ -> String -> ArgRep
forall a. String -> a
panic String
"schemeE(StgCase).push_alts"
in ProtoBCO Name -> ArgRep -> BCInstr
PUSH_ALTS_UNLIFTED ProtoBCO Name
alt_bco' ArgRep
unlifted_rep
in BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr
push_alts BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
scrut_code)
layoutTuple :: Profile
-> ByteOff
-> (a -> CmmType)
-> [a]
-> ( TupleInfo
, [(a, ByteOff)]
)
layoutTuple :: Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile ByteOff
start_off a -> CmmType
arg_ty [a]
reps =
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
(Int
orig_stk_bytes, [(a, ParamLocation)]
pos) = 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]
([GlobalReg]
regs, [a]
reg_params)
= [(GlobalReg, a)] -> ([GlobalReg], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(GlobalReg, a)] -> ([GlobalReg], [a]))
-> [(GlobalReg, a)] -> ([GlobalReg], [a])
forall a b. (a -> b) -> a -> b
$ ((GlobalReg, a) -> (GlobalReg, a) -> Ordering)
-> [(GlobalReg, a)] -> [(GlobalReg, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((GlobalReg, a) -> GlobalReg)
-> (GlobalReg, a) -> (GlobalReg, a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (GlobalReg, a) -> GlobalReg
forall a b. (a, b) -> a
fst)
[(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
bmp_reg :: GlobalReg -> (a, a, a, a) -> (a, a, a, a)
bmp_reg GlobalReg
r ~(a
v, a
f, a
d, a
l)
= case GlobalReg
r of VanillaReg Int
n VGcPtr
_ -> (a -> Int -> a
forall a. (Bits a, Num a) => a -> Int -> a
a a
v Int
n, a
f, a
d, a
l )
FloatReg Int
n -> (a
v, a -> Int -> a
forall a. (Bits a, Num a) => a -> Int -> a
a a
f Int
n, a
d, a
l )
DoubleReg Int
n -> (a
v, a
f, a -> Int -> a
forall a. (Bits a, Num a) => a -> Int -> a
a a
d Int
n, a
l )
LongReg Int
n -> (a
v, a
f, a
d, a -> Int -> a
forall a. (Bits a, Num a) => a -> Int -> a
a a
l Int
n)
GlobalReg
_ ->
String -> SDoc -> (a, a, a, a)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToByteCode.layoutTuple unsupported register type"
(GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
r)
where a :: a -> Int -> a
a a
bmp Int
n = a
bmp a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a
1 a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
(RegBitmap
vanilla_regs, RegBitmap
float_regs, RegBitmap
double_regs, RegBitmap
long_regs)
= (GlobalReg
-> (RegBitmap, RegBitmap, RegBitmap, RegBitmap)
-> (RegBitmap, RegBitmap, RegBitmap, RegBitmap))
-> (RegBitmap, RegBitmap, RegBitmap, RegBitmap)
-> [GlobalReg]
-> (RegBitmap, RegBitmap, RegBitmap, RegBitmap)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GlobalReg
-> (RegBitmap, RegBitmap, RegBitmap, RegBitmap)
-> (RegBitmap, RegBitmap, RegBitmap, RegBitmap)
forall a a a a.
(Bits a, Bits a, Bits a, Bits a, Num a, Num a, Num a, Num a) =>
GlobalReg -> (a, a, a, a) -> (a, a, a, a)
bmp_reg (RegBitmap
0, RegBitmap
0, RegBitmap
0, RegBitmap
0) [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. String -> a
panic String
"GHC.StgToByteCode.layoutTuple get_byte_off"
in ( TupleInfo :: WordOff
-> RegBitmap
-> RegBitmap
-> RegBitmap
-> RegBitmap
-> WordOff
-> TupleInfo
TupleInfo
{ tupleSize :: WordOff
tupleSize = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (Int -> ByteOff
ByteOff Int
new_stk_bytes)
, tupleVanillaRegs :: RegBitmap
tupleVanillaRegs = RegBitmap
vanilla_regs
, tupleLongRegs :: RegBitmap
tupleLongRegs = RegBitmap
long_regs
, tupleFloatRegs :: RegBitmap
tupleFloatRegs = RegBitmap
float_regs
, tupleDoubleRegs :: RegBitmap
tupleDoubleRegs = RegBitmap
double_regs
, tupleNativeStackSize :: WordOff
tupleNativeStackSize = 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 -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO :: Platform
-> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO Platform
platform TupleInfo
info [(Bool, ByteOff)]
pointers =
Platform
-> Name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> BCInstrList
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
invented_name BCInstrList
body_code ([(AltCon, [Id], GenStgExpr 'CodeGen)]
-> Either [(AltCon, [Id], GenStgExpr 'CodeGen)] CgStgRhs
forall a b. a -> Either a b
Left [])
Int
0 Word16
bitmap_size [StgWord]
bitmap Bool
False
where
invented_name :: Name
invented_name = Unique -> FastString -> Name
mkSystemVarName (Int -> Unique
mkPseudoUniqueE Int
0) (String -> FastString
fsLit String
"tuple")
bitmap_size :: Word16
bitmap_size = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ WordOff
1 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ TupleInfo -> WordOff
tupleSize TupleInfo
info
bitmap :: [StgWord]
bitmap = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bitmap_size) ([Int] -> [StgWord]) -> [Int] -> [StgWord]
forall a b. (a -> b) -> a -> b
$
((Bool, ByteOff) -> Int) -> [(Bool, ByteOff)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> ((Bool, ByteOff) -> Int) -> (Bool, ByteOff) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordOff -> Int)
-> ((Bool, ByteOff) -> WordOff) -> (Bool, ByteOff) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff -> WordOff)
-> ((Bool, ByteOff) -> ByteOff) -> (Bool, ByteOff) -> WordOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, ByteOff) -> ByteOff
forall a b. (a, b) -> b
snd)
(((Bool, ByteOff) -> Bool) -> [(Bool, ByteOff)] -> [(Bool, ByteOff)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, ByteOff) -> Bool
forall a b. (a, b) -> a
fst [(Bool, ByteOff)]
pointers)
body_code :: BCInstrList
body_code = Word16 -> WordOff -> BCInstrList
mkSlideW Word16
0 WordOff
1
BCInstrList -> BCInstr -> BCInstrList
forall a. OrdList a -> a -> OrdList a
`snocOL` BCInstr
RETURN_TUPLE
generateCCall
:: StackDepth
-> Sequel
-> BCEnv
-> CCallSpec
-> Type
-> [StgArg]
-> BcM BCInstrList
generateCCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Type
-> [StgArg]
-> BcM BCInstrList
generateCCall ByteOff
d0 ByteOff
s Map Id ByteOff
p (CCallSpec CCallTarget
target CCallConv
cconv Safety
safety) Type
result_ty [StgArg]
args_r_to_l
= do
Profile
profile <- BcM Profile
getProfile
let
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
addr_size_b :: ByteOff
addr_size_b :: ByteOff
addr_size_b = Platform -> ByteOff
wordSize Platform
platform
arrayish_rep_hdr_size :: TyCon -> Maybe Int
arrayish_rep_hdr_size :: TyCon -> Maybe Int
arrayish_rep_hdr_size TyCon
t
| TyCon
t 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, PrimRep)]
pargs :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
pargs ByteOff
_ [] = [(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
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 [(BCInstrList, PrimRep)]
rest <- ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [StgArg]
az
(BCInstrList
push_fo, ByteOff
_) <- ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
aa
let code :: BCInstrList
code = BCInstrList
push_fo BCInstrList -> BCInstr -> BCInstrList
forall a. OrdList a -> a -> OrdList a
`snocOL` Word16 -> Word16 -> BCInstr
SWIZZLE Word16
0 (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hdr_sz)
[(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList
code, PrimRep
AddrRep) (BCInstrList, PrimRep)
-> [(BCInstrList, PrimRep)] -> [(BCInstrList, PrimRep)]
forall a. a -> [a] -> [a]
: [(BCInstrList, PrimRep)]
rest)
pargs ByteOff
d (StgArg
aa:[StgArg]
az) = do (BCInstrList
code_a, ByteOff
sz_a) <- ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
aa
[(BCInstrList, PrimRep)]
rest <- ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
sz_a) [StgArg]
az
[(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList
code_a, StgArg -> PrimRep
atomPrimRep StgArg
aa) (BCInstrList, PrimRep)
-> [(BCInstrList, PrimRep)] -> [(BCInstrList, PrimRep)]
forall a. a -> [a] -> [a]
: [(BCInstrList, PrimRep)]
rest)
[(BCInstrList, PrimRep)]
code_n_reps <- ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
pargs ByteOff
d0 [StgArg]
args_r_to_l
let
([BCInstrList]
pushs_arg, [PrimRep]
a_reps_pushed_r_to_l) = [(BCInstrList, PrimRep)] -> ([BCInstrList], [PrimRep])
forall a b. [(a, b)] -> ([a], [b])
unzip [(BCInstrList, PrimRep)]
code_n_reps
a_reps_sizeW :: WordOff
a_reps_sizeW = [WordOff] -> WordOff
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((PrimRep -> WordOff) -> [PrimRep] -> [WordOff]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> WordOff
repSizeWords Platform
platform) [PrimRep]
a_reps_pushed_r_to_l)
push_args :: BCInstrList
push_args = [BCInstrList] -> BCInstrList
forall a. [OrdList a] -> OrdList a
concatOL [BCInstrList]
pushs_arg
!d_after_args :: ByteOff
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 :: [PrimRep]
a_reps_pushed_RAW
| [PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
a_reps_pushed_r_to_l Bool -> Bool -> Bool
|| Bool -> Bool
not (PrimRep -> Bool
isVoidRep ([PrimRep] -> PrimRep
forall a. [a] -> a
head [PrimRep]
a_reps_pushed_r_to_l))
= String -> [PrimRep]
forall a. String -> a
panic String
"GHC.StgToByteCode.generateCCall: missing or invalid World token?"
| Bool
otherwise
= [PrimRep] -> [PrimRep]
forall a. [a] -> [a]
reverse ([PrimRep] -> [PrimRep]
forall a. [a] -> [a]
tail [PrimRep]
a_reps_pushed_r_to_l)
(Bool
returns_void, PrimRep
r_rep)
= case Type -> Maybe PrimRep
maybe_getCCallReturnRep Type
result_ty of
Maybe PrimRep
Nothing -> (Bool
True, PrimRep
VoidRep)
Just PrimRep
rr -> (Bool
False, PrimRep
rr)
maybe_static_target :: Maybe Literal
maybe_static_target :: Maybe Literal
maybe_static_target =
case CCallTarget
target of
CCallTarget
DynamicTarget -> Maybe Literal
forall a. Maybe a
Nothing
StaticTarget SourceText
_ FastString
_ Maybe Unit
_ Bool
False ->
String -> Maybe Literal
forall a. String -> a
panic String
"generateCCall: unexpected FFI value import"
StaticTarget SourceText
_ FastString
target Maybe Unit
_ Bool
True ->
Literal -> Maybe Literal
forall a. a -> Maybe a
Just (FastString -> Maybe Int -> FunctionOrData -> Literal
LitLabel FastString
target Maybe Int
mb_size FunctionOrData
IsFunction)
where
mb_size :: Maybe Int
mb_size
| OS
OSMinGW32 <- Platform -> OS
platformOS Platform
platform
, CCallConv
StdCallConv <- CCallConv
cconv
= Int -> Maybe Int
forall a. a -> Maybe a
Just (WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
a_reps_sizeW Int -> Int -> Int
forall a. Num a => a -> a -> a
* Platform -> Int
platformWordSizeInBytes Platform
platform)
| Bool
otherwise
= Maybe Int
forall a. Maybe a
Nothing
let
is_static :: Bool
is_static = Maybe Literal -> Bool
forall a. Maybe a -> Bool
isJust Maybe Literal
maybe_static_target
a_reps :: [PrimRep]
a_reps
| Bool
is_static = [PrimRep]
a_reps_pushed_RAW
| Bool
otherwise = if [PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
a_reps_pushed_RAW
then String -> [PrimRep]
forall a. String -> a
panic String
"GHC.StgToByteCode.generateCCall: dyn with no args"
else [PrimRep] -> [PrimRep]
forall a. [a] -> [a]
tail [PrimRep]
a_reps_pushed_RAW
(BCInstrList
push_Addr, ByteOff
d_after_Addr)
| Just Literal
machlabel <- Maybe Literal
maybe_static_target
= ([BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL [Literal -> Word16 -> BCInstr
PUSH_UBX Literal
machlabel Word16
1], ByteOff
d_after_args ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b)
| Bool
otherwise
= (BCInstrList
forall a. OrdList a
nilOL, ByteOff
d_after_args)
r_sizeW :: WordOff
r_sizeW = Platform -> PrimRep -> WordOff
repSizeWords Platform
platform PrimRep
r_rep
d_after_r :: ByteOff
d_after_r = ByteOff
d_after_Addr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
r_sizeW
push_r :: BCInstrList
push_r =
if Bool
returns_void
then BCInstrList
forall a. OrdList a
nilOL
else BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Literal -> Word16 -> BCInstr
PUSH_UBX (Platform -> PrimRep -> Literal
mkDummyLiteral Platform
platform PrimRep
r_rep) (WordOff -> Word16
trunc16W WordOff
r_sizeW))
stk_offset :: Word16
stk_offset = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d_after_r ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
conv :: FFIConv
conv = case CCallConv
cconv of
CCallConv
CCallConv -> FFIConv
FFICCall
CCallConv
StdCallConv -> FFIConv
FFIStdCall
CCallConv
_ -> String -> FFIConv
forall a. String -> a
panic String
"GHC.StgToByteCode: unexpected calling convention"
let ffires :: FFIType
ffires = Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform PrimRep
r_rep
ffiargs :: [FFIType]
ffiargs = (PrimRep -> FFIType) -> [PrimRep] -> [FFIType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform) [PrimRep]
a_reps
Interp
interp <- HscEnv -> Interp
hscInterp (HscEnv -> Interp) -> BcM HscEnv -> BcM Interp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM HscEnv
getHscEnv
RemotePtr C_ffi_cif
token <- IO (RemotePtr C_ffi_cif) -> BcM (RemotePtr C_ffi_cif)
forall a. IO a -> BcM a
ioToBc (IO (RemotePtr C_ffi_cif) -> BcM (RemotePtr C_ffi_cif))
-> IO (RemotePtr C_ffi_cif) -> BcM (RemotePtr C_ffi_cif)
forall a b. (a -> b) -> a -> b
$ Interp -> Message (RemotePtr C_ffi_cif) -> IO (RemotePtr C_ffi_cif)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
PrepFFI FFIConv
conv [FFIType]
ffiargs FFIType
ffires)
RemotePtr C_ffi_cif -> BcM ()
recordFFIBc RemotePtr C_ffi_cif
token
let
do_call :: BCInstrList
do_call = BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Word16 -> RemotePtr C_ffi_cif -> Word16 -> BCInstr
CCALL Word16
stk_offset RemotePtr C_ffi_cif
token Word16
flags)
where flags :: Word16
flags = case Safety
safety of
Safety
PlaySafe -> Word16
0x0
Safety
PlayInterruptible -> Word16
0x1
Safety
PlayRisky -> Word16
0x2
d_after_r_min_s :: WordOff
d_after_r_min_s = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d_after_r ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
wrapup :: BCInstrList
wrapup = Word16 -> WordOff -> BCInstrList
mkSlideW (WordOff -> Word16
trunc16W WordOff
r_sizeW) (WordOff
d_after_r_min_s WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
r_sizeW)
BCInstrList -> BCInstr -> BCInstrList
forall a. OrdList a -> a -> OrdList a
`snocOL` ArgRep -> BCInstr
RETURN_UBX (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
r_rep)
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (
BCInstrList
push_args BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
BCInstrList
push_Addr BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
push_r BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
do_call BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
wrapup
)
primRepToFFIType :: Platform -> PrimRep -> FFIType
primRepToFFIType :: Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform PrimRep
r
= case PrimRep
r of
PrimRep
VoidRep -> FFIType
FFIVoid
PrimRep
IntRep -> FFIType
signed_word
PrimRep
WordRep -> FFIType
unsigned_word
PrimRep
Int8Rep -> FFIType
FFISInt8
PrimRep
Word8Rep -> FFIType
FFIUInt8
PrimRep
Int16Rep -> FFIType
FFISInt16
PrimRep
Word16Rep -> FFIType
FFIUInt16
PrimRep
Int32Rep -> FFIType
FFISInt32
PrimRep
Word32Rep -> FFIType
FFIUInt32
PrimRep
Int64Rep -> FFIType
FFISInt64
PrimRep
Word64Rep -> FFIType
FFIUInt64
PrimRep
AddrRep -> FFIType
FFIPointer
PrimRep
FloatRep -> FFIType
FFIFloat
PrimRep
DoubleRep -> FFIType
FFIDouble
PrimRep
_ -> String -> FFIType
forall a. String -> a
panic String
"primRepToFFIType"
where
(FFIType
signed_word, FFIType
unsigned_word) = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> (FFIType
FFISInt32, FFIType
FFIUInt32)
PlatformWordSize
PW8 -> (FFIType
FFISInt64, FFIType
FFIUInt64)
mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral Platform
platform PrimRep
pr
= case PrimRep
pr of
PrimRep
IntRep -> Platform -> Integer -> Literal
mkLitInt Platform
platform Integer
0
PrimRep
WordRep -> Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
0
PrimRep
Int8Rep -> Integer -> Literal
mkLitInt8 Integer
0
PrimRep
Word8Rep -> Integer -> Literal
mkLitWord8 Integer
0
PrimRep
Int16Rep -> Integer -> Literal
mkLitInt16 Integer
0
PrimRep
Word16Rep -> Integer -> Literal
mkLitWord16 Integer
0
PrimRep
Int32Rep -> Integer -> Literal
mkLitInt32 Integer
0
PrimRep
Word32Rep -> Integer -> Literal
mkLitWord32 Integer
0
PrimRep
Int64Rep -> Integer -> Literal
mkLitInt64 Integer
0
PrimRep
Word64Rep -> Integer -> Literal
mkLitWord64 Integer
0
PrimRep
AddrRep -> Literal
LitNullAddr
PrimRep
DoubleRep -> Rational -> Literal
LitDouble Rational
0
PrimRep
FloatRep -> Rational -> Literal
LitFloat Rational
0
PrimRep
_ -> 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 -> Maybe PrimRep
maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep Type
fn_ty
= let
([Scaled Type]
_a_tys, Type
r_ty) = Type -> ([Scaled Type], Type)
splitFunTys (Type -> Type
dropForAlls Type
fn_ty)
r_reps :: [PrimRep]
r_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRepArgs Type
r_ty
blargh :: a
blargh :: a
blargh = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"maybe_getCCallReturn: can't handle:"
(Type -> SDoc
pprType Type
fn_ty)
in
case [PrimRep]
r_reps of
[] -> String -> Maybe PrimRep
forall a. String -> a
panic String
"empty typePrimRepArgs"
[PrimRep
VoidRep] -> Maybe PrimRep
forall a. Maybe a
Nothing
[PrimRep
rep]
| PrimRep -> Bool
isGcPtrRep PrimRep
rep -> Maybe PrimRep
forall a. a
blargh
| Bool
otherwise -> PrimRep -> Maybe PrimRep
forall a. a -> Maybe a
Just PrimRep
rep
[PrimRep]
_ -> Maybe PrimRep
forall a. a
blargh
maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
maybe_is_tagToEnum_call :: GenStgExpr 'CodeGen -> 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 GenStgExpr 'CodeGen
_ = 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 BCInstrList
implement_tagToId ByteOff
d ByteOff
s Map Id ByteOff
p Id
arg [Name]
names
= ASSERT( notNull names )
do (BCInstrList
push_arg, ByteOff
arg_bytes) <- ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
arg)
[LocalLabel]
labels <- Word32 -> BcM [LocalLabel]
getLabelsBc ([Name] -> Word32
forall i a. Num i => [a] -> i
genericLength [Name]
names)
LocalLabel
label_fail <- BcM LocalLabel
getLabelBc
LocalLabel
label_exit <- BcM LocalLabel
getLabelBc
DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let infos :: [(LocalLabel, LocalLabel, Int, Name)]
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. [a] -> [a]
tail [LocalLabel]
labels [LocalLabel] -> [LocalLabel] -> [LocalLabel]
forall a. [a] -> [a] -> [a]
++ [LocalLabel
label_fail])
[Int
0 ..] [Name]
names
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
steps :: [BCInstrList]
steps = ((LocalLabel, LocalLabel, Int, Name) -> BCInstrList)
-> [(LocalLabel, LocalLabel, Int, Name)] -> [BCInstrList]
forall a b. (a -> b) -> [a] -> [b]
map (LocalLabel -> (LocalLabel, LocalLabel, Int, Name) -> BCInstrList
mkStep LocalLabel
label_exit) [(LocalLabel, LocalLabel, Int, Name)]
infos
slide_ws :: WordOff
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)
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_arg
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Literal -> Word16 -> BCInstr
PUSH_UBX Literal
LitNullAddr Word16
1)
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [BCInstrList] -> BCInstrList
forall a. [OrdList a] -> OrdList a
concatOL [BCInstrList]
steps
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL [ LocalLabel -> BCInstr
LABEL LocalLabel
label_fail, BCInstr
CASEFAIL,
LocalLabel -> BCInstr
LABEL LocalLabel
label_exit ]
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Word16 -> WordOff -> BCInstrList
mkSlideW Word16
1 (WordOff
slide_ws WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
1)
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
ENTER)
where
mkStep :: LocalLabel -> (LocalLabel, LocalLabel, Int, Name) -> BCInstrList
mkStep LocalLabel
l_exit (LocalLabel
my_label, LocalLabel
next_label, Int
n, Name
name_for_n)
= [BCInstr] -> BCInstrList
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 (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (StgVarArg Id
var)
| [] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
var)
= (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
forall a. OrdList a
nilOL, ByteOff
0)
| Id -> Bool
isFCallId Id
var
= String -> SDoc -> BcM (BCInstrList, 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
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
(BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (PrimOp -> BCInstr
PUSH_PRIMOP PrimOp
primop), Platform -> ByteOff
wordSize Platform
platform)
| Just ByteOff
d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
var Map Id ByteOff
p
= do Platform
platform <- DynFlags -> Platform
targetPlatform (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 :: ByteOff
szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
with_instr :: (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
with_instr Word16 -> BCInstr
instr = do
let !off_b :: Word16
off_b = ByteOff -> Word16
trunc16B (ByteOff -> Word16) -> ByteOff -> Word16
forall a b. (a -> b) -> a -> b
$ ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
d_v
(BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
instr Word16
off_b), Platform -> ByteOff
wordSize Platform
platform)
case ByteOff
szb of
ByteOff
1 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
with_instr Word16 -> BCInstr
PUSH8_W
ByteOff
2 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
with_instr Word16 -> BCInstr
PUSH16_W
ByteOff
4 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
with_instr Word16 -> BCInstr
PUSH32_W
ByteOff
_ -> do
let !szw :: WordOff
szw = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
szb
!off_w :: Word16
off_w = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ 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
(BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return ([BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL (WordOff -> BCInstr -> [BCInstr]
forall i a. Integral i => i -> a -> [a]
genericReplicate WordOff
szw (Word16 -> BCInstr
PUSH_L Word16
off_w)), ByteOff
szb)
| Bool
otherwise
= do IdEnv (RemotePtr ())
topStrings <- BcM (IdEnv (RemotePtr ()))
getTopStrings
Platform
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
case IdEnv (RemotePtr ()) -> Id -> Maybe (RemotePtr ())
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv (RemotePtr ())
topStrings Id
var of
Just RemotePtr ()
ptr -> ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (StgArg -> BcM (BCInstrList, ByteOff))
-> StgArg -> BcM (BCInstrList, ByteOff)
forall a b. (a -> b) -> a -> b
$ Literal -> StgArg
StgLitArg (Literal -> StgArg) -> Literal -> StgArg
forall a b. (a -> b) -> a -> b
$ Platform -> Integer -> Literal
mkLitWord Platform
platform (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$
WordPtr -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordPtr -> Integer) -> WordPtr -> Integer
forall a b. (a -> b) -> a -> b
$ Ptr () -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr (Ptr () -> WordPtr) -> Ptr () -> WordPtr
forall a b. (a -> b) -> a -> b
$ RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
ptr
Maybe (RemotePtr ())
Nothing -> do
let sz :: ByteOff
sz = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
MASSERT( sz == wordSize platform )
(BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Name -> BCInstr
PUSH_G (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
var)), ByteOff
sz)
pushAtom ByteOff
_ Map Id ByteOff
_ (StgLitArg Literal
lit) = do
Platform
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 -> BcM (BCInstrList, ByteOff)
code PrimRep
rep =
(BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
instr, ByteOff
size_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
instr :: BCInstr
instr =
case ByteOff
size_bytes of
ByteOff
1 -> Literal -> BCInstr
PUSH_UBX8 Literal
lit
ByteOff
2 -> Literal -> BCInstr
PUSH_UBX16 Literal
lit
ByteOff
4 -> Literal -> BCInstr
PUSH_UBX32 Literal
lit
ByteOff
_ -> Literal -> Word16 -> BCInstr
PUSH_UBX Literal
lit (WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
size_bytes)
case Literal
lit of
LitLabel {} -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
AddrRep
LitFloat {} -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
FloatRep
LitDouble {} -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
DoubleRep
LitChar {} -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
WordRep
Literal
LitNullAddr -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
AddrRep
LitString {} -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
AddrRep
LitRubbish {} -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
WordRep
LitNumber LitNumType
nt Integer
_ -> case LitNumType
nt of
LitNumType
LitNumInt -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
IntRep
LitNumType
LitNumWord -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
WordRep
LitNumType
LitNumInt8 -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
Int8Rep
LitNumType
LitNumWord8 -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
Word8Rep
LitNumType
LitNumInt16 -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
Int16Rep
LitNumType
LitNumWord16 -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
Word16Rep
LitNumType
LitNumInt32 -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
Int32Rep
LitNumType
LitNumWord32 -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
Word32Rep
LitNumType
LitNumInt64 -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
Int64Rep
LitNumType
LitNumWord64 -> PrimRep -> BcM (BCInstrList, ByteOff)
code PrimRep
Word64Rep
LitNumType
LitNumInteger -> String -> BcM (BCInstrList, ByteOff)
forall a. String -> a
panic String
"pushAtom: LitInteger"
LitNumType
LitNumNatural -> String -> BcM (BCInstrList, ByteOff)
forall a. String -> a
panic String
"pushAtom: LitNatural"
pushConstrAtom
:: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
pushConstrAtom :: ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, ByteOff)
pushConstrAtom ByteOff
_ Map Id ByteOff
_ (StgLitArg lit :: Literal
lit@(LitFloat Rational
_)) =
(BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Literal -> BCInstr
PUSH_UBX32 Literal
lit), ByteOff
4)
pushConstrAtom ByteOff
d Map Id ByteOff
p va :: StgArg
va@(StgVarArg Id
v)
| Just ByteOff
d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
v Map Id ByteOff
p = do
Platform
platform <- DynFlags -> Platform
targetPlatform (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 :: ByteOff
szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
v
done :: (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
done Word16 -> BCInstr
instr = do
let !off :: Word16
off = ByteOff -> Word16
trunc16B (ByteOff -> Word16) -> ByteOff -> Word16
forall a b. (a -> b) -> a -> b
$ ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
d_v
(BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
instr Word16
off), ByteOff
szb)
case ByteOff
szb of
ByteOff
1 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
done Word16 -> BCInstr
PUSH8
ByteOff
2 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
done Word16 -> BCInstr
PUSH16
ByteOff
4 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
done Word16 -> BCInstr
PUSH32
ByteOff
_ -> ByteOff -> Map Id ByteOff -> StgArg -> BcM (BCInstrList, 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 (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
expr
pushPadding :: Int -> (BCInstrList, ByteOff)
pushPadding :: Int -> (BCInstrList, ByteOff)
pushPadding !Int
n = Int -> (BCInstrList, ByteOff) -> (BCInstrList, ByteOff)
forall t a.
(Eq t, Num t, Num a) =>
t -> (BCInstrList, a) -> (BCInstrList, a)
go Int
n (BCInstrList
forall a. OrdList a
nilOL, ByteOff
0)
where
go :: t -> (BCInstrList, a) -> (BCInstrList, a)
go t
n acc :: (BCInstrList, a)
acc@(!BCInstrList
instrs, !a
off) = case t
n of
t
0 -> (BCInstrList, a)
acc
t
1 -> (BCInstrList
instrs BCInstrList -> BCInstrList -> BCInstrList
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD8, a
off a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
t
2 -> (BCInstrList
instrs BCInstrList -> BCInstrList -> BCInstrList
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD16, a
off a -> a -> a
forall a. Num a => a -> a -> a
+ a
2)
t
3 -> t -> (BCInstrList, a) -> (BCInstrList, a)
go t
1 (t -> (BCInstrList, a) -> (BCInstrList, a)
go t
2 (BCInstrList, a)
acc)
t
4 -> (BCInstrList
instrs BCInstrList -> BCInstrList -> BCInstrList
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD32, a
off a -> a -> a
forall a. Num a => a -> a -> a
+ a
4)
t
_ -> t -> (BCInstrList, a) -> (BCInstrList, a)
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
4) (t -> (BCInstrList, a) -> (BCInstrList, a)
go t
4 (BCInstrList, a)
acc)
mkMultiBranch :: Maybe Int
-> [(Discr, BCInstrList)]
-> BcM BCInstrList
mkMultiBranch :: Maybe Int -> [(Discr, BCInstrList)] -> BcM BCInstrList
mkMultiBranch Maybe Int
maybe_ncons [(Discr, BCInstrList)]
raw_ways = do
LocalLabel
lbl_default <- BcM LocalLabel
getLabelBc
let
mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree [] Discr
_range_lo Discr
_range_hi = BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (LocalLabel -> BCInstr
JMP LocalLabel
lbl_default))
mkTree [(Discr, BCInstrList)
val] Discr
range_lo Discr
range_hi
| Discr
range_lo Discr -> Discr -> Bool
forall a. Eq a => a -> a -> Bool
== Discr
range_hi
= BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return ((Discr, BCInstrList) -> BCInstrList
forall a b. (a, b) -> b
snd (Discr, BCInstrList)
val)
| [(Discr, BCInstrList)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, BCInstrList)]
defaults
= do LocalLabel
lbl <- BcM LocalLabel
getLabelBc
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testEQ ((Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst (Discr, BCInstrList)
val) LocalLabel
lbl
BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` ((Discr, BCInstrList) -> BCInstrList
forall a b. (a, b) -> b
snd (Discr, BCInstrList)
val
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (LocalLabel -> BCInstr
LABEL LocalLabel
lbl BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
CASEFAIL)))
| Bool
otherwise
= BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testEQ ((Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst (Discr, BCInstrList)
val) LocalLabel
lbl_default BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` (Discr, BCInstrList) -> BCInstrList
forall a b. (a, b) -> b
snd (Discr, BCInstrList)
val)
mkTree [(Discr, BCInstrList)]
vals Discr
range_lo Discr
range_hi
= let n :: Int
n = [(Discr, BCInstrList)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Discr, BCInstrList)]
vals Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
vals_lo :: [(Discr, BCInstrList)]
vals_lo = Int -> [(Discr, BCInstrList)] -> [(Discr, BCInstrList)]
forall a. Int -> [a] -> [a]
take Int
n [(Discr, BCInstrList)]
vals
vals_hi :: [(Discr, BCInstrList)]
vals_hi = Int -> [(Discr, BCInstrList)] -> [(Discr, BCInstrList)]
forall a. Int -> [a] -> [a]
drop Int
n [(Discr, BCInstrList)]
vals
v_mid :: Discr
v_mid = (Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst ([(Discr, BCInstrList)] -> (Discr, BCInstrList)
forall a. [a] -> a
head [(Discr, BCInstrList)]
vals_hi)
in do
LocalLabel
label_geq <- BcM LocalLabel
getLabelBc
BCInstrList
code_lo <- [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree [(Discr, BCInstrList)]
vals_lo Discr
range_lo (Discr -> Discr
dec Discr
v_mid)
BCInstrList
code_hi <- [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree [(Discr, BCInstrList)]
vals_hi Discr
v_mid Discr
range_hi
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testLT Discr
v_mid LocalLabel
label_geq
BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` (BCInstrList
code_lo
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (LocalLabel -> BCInstr
LABEL LocalLabel
label_geq)
BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
code_hi))
the_default :: BCInstrList
the_default
= case [(Discr, BCInstrList)]
defaults of
[] -> BCInstrList
forall a. OrdList a
nilOL
[(Discr
_, BCInstrList
def)] -> LocalLabel -> BCInstr
LABEL LocalLabel
lbl_default BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
def
[(Discr, BCInstrList)]
_ -> String -> BCInstrList
forall a. String -> a
panic String
"mkMultiBranch/the_default"
BCInstrList
instrs <- [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree [(Discr, BCInstrList)]
notd_ways Discr
init_lo Discr
init_hi
BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
instrs BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
the_default)
where
([(Discr, BCInstrList)]
defaults, [(Discr, BCInstrList)]
not_defaults) = ((Discr, BCInstrList) -> Bool)
-> [(Discr, BCInstrList)]
-> ([(Discr, BCInstrList)], [(Discr, BCInstrList)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Discr -> Bool
isNoDiscr(Discr -> Bool)
-> ((Discr, BCInstrList) -> Discr) -> (Discr, BCInstrList) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst) [(Discr, BCInstrList)]
raw_ways
notd_ways :: [(Discr, BCInstrList)]
notd_ways = ((Discr, BCInstrList) -> (Discr, BCInstrList) -> Ordering)
-> [(Discr, BCInstrList)] -> [(Discr, BCInstrList)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Discr, BCInstrList) -> Discr)
-> (Discr, BCInstrList) -> (Discr, BCInstrList) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst) [(Discr, BCInstrList)]
not_defaults
testLT :: Discr -> LocalLabel -> BCInstr
testLT (DiscrI Int
i) LocalLabel
fail_label = Int -> LocalLabel -> BCInstr
TESTLT_I Int
i LocalLabel
fail_label
testLT (DiscrW Word
i) LocalLabel
fail_label = Word -> LocalLabel -> BCInstr
TESTLT_W Word
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. 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 (DiscrW Word
i) LocalLabel
fail_label = Word -> LocalLabel -> BCInstr
TESTEQ_W Word
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. String -> a
panic String
"mkMultiBranch NoDiscr"
(Discr
init_lo, Discr
init_hi)
| [(Discr, BCInstrList)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, BCInstrList)]
notd_ways
= String -> (Discr, Discr)
forall a. String -> a
panic String
"mkMultiBranch: awesome foursome"
| Bool
otherwise
= case (Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst ([(Discr, BCInstrList)] -> (Discr, BCInstrList)
forall a. [a] -> a
head [(Discr, BCInstrList)]
notd_ways) of
DiscrI Int
_ -> ( Int -> Discr
DiscrI Int
forall a. Bounded a => a
minBound, Int -> Discr
DiscrI Int
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 )
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. 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
| DiscrW Word
| 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
/= :: Discr -> Discr -> Bool
$c/= :: Discr -> Discr -> Bool
== :: Discr -> Discr -> Bool
$c== :: 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
min :: Discr -> Discr -> Discr
$cmin :: Discr -> Discr -> Discr
max :: Discr -> Discr -> Discr
$cmax :: Discr -> Discr -> Discr
>= :: Discr -> Discr -> Bool
$c>= :: Discr -> Discr -> Bool
> :: Discr -> Discr -> Bool
$c> :: Discr -> Discr -> Bool
<= :: Discr -> Discr -> Bool
$c<= :: Discr -> Discr -> Bool
< :: Discr -> Discr -> Bool
$c< :: Discr -> Discr -> Bool
compare :: Discr -> Discr -> Ordering
$ccompare :: Discr -> Discr -> Ordering
$cp1Ord :: Eq Discr
Ord)
instance Outputable Discr where
ppr :: Discr -> SDoc
ppr (DiscrI Int
i) = Int -> SDoc
int Int
i
ppr (DiscrW Word
w) = String -> SDoc
text (Word -> String
forall a. Show a => a -> String
show Word
w)
ppr (DiscrF Float
f) = String -> SDoc
text (Float -> String
forall a. Show a => a -> String
show Float
f)
ppr (DiscrD Double
d) = String -> SDoc
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
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
bcIdArgRep 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 (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
.
Id -> [PrimRep]
bcIdPrimReps (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
bcIdPrimRep Id
var))
bcIdArgRep :: Platform -> Id -> ArgRep
bcIdArgRep :: Platform -> Id -> ArgRep
bcIdArgRep Platform
platform = Platform -> PrimRep -> ArgRep
toArgRep Platform
platform (PrimRep -> ArgRep) -> (Id -> PrimRep) -> Id -> ArgRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
bcIdPrimRep
bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep Id
id
| [PrimRep
rep] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRepArgs (Id -> Type
idType Id
id)
= PrimRep
rep
| Bool
otherwise
= String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"bcIdPrimRep" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
id))
bcIdPrimReps :: Id -> [PrimRep]
bcIdPrimReps :: Id -> [PrimRep]
bcIdPrimReps Id
id = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRepArgs (Id -> Type
idType Id
id)
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords Platform
platform PrimRep
rep = Int -> WordOff
WordOff (Int -> WordOff) -> Int -> WordOff
forall a b. (a -> b) -> a -> b
$ Platform -> ArgRep -> Int
argRepSizeW Platform
platform (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep)
isFollowableArg :: ArgRep -> Bool
isFollowableArg :: ArgRep -> Bool
isFollowableArg ArgRep
P = Bool
True
isFollowableArg ArgRep
_ = Bool
False
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv (CCallSpec CCallTarget
_ CCallConv
cconv Safety
_) = case CCallConv
cconv of
CCallConv
CCallConv -> Bool
True
CCallConv
StdCallConv -> Bool
True
CCallConv
PrimCallConv -> Bool
False
CCallConv
JavaScriptCallConv -> Bool
False
CCallConv
CApiConv -> Bool
False
unsupportedCConvException :: a
unsupportedCConvException :: 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 -> OrdList BCInstr
mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstrList
mkSlideB Platform
platform !ByteOff
nb !ByteOff
db = Word16 -> WordOff -> BCInstrList
mkSlideW Word16
n WordOff
d
where
!n :: Word16
n = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
nb
!d :: WordOff
d = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
db
mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
mkSlideW :: Word16 -> WordOff -> BCInstrList
mkSlideW !Word16
n !WordOff
ws
| WordOff
ws WordOff -> WordOff -> Bool
forall a. Ord a => a -> a -> Bool
> Word16 -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
limit
= Word16 -> Word16 -> BCInstr
SLIDE Word16
n Word16
limit BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` Word16 -> WordOff -> BCInstrList
mkSlideW Word16
n (WordOff
ws WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- Word16 -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
limit)
| WordOff
ws WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
== WordOff
0
= BCInstrList
forall a. OrdList a
nilOL
| Bool
otherwise
= BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Word16 -> Word16 -> BCInstr
SLIDE Word16
n (Word16 -> BCInstr) -> Word16 -> BCInstr
forall a b. (a -> b) -> a -> b
$ WordOff -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
ws)
where
limit :: Word16
limit :: Word16
limit = Word16
forall a. Bounded a => a
maxBound
atomPrimRep :: StgArg -> PrimRep
atomPrimRep :: StgArg -> PrimRep
atomPrimRep (StgVarArg Id
v) = Id -> PrimRep
bcIdPrimRep Id
v
atomPrimRep (StgLitArg Literal
l) = HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRep1 (Literal -> Type
literalType Literal
l)
atomRep :: Platform -> StgArg -> ArgRep
atomRep :: Platform -> StgArg -> ArgRep
atomRep Platform
platform StgArg
e = Platform -> PrimRep -> ArgRep
toArgRep Platform
platform (StgArg -> PrimRep
atomPrimRep StgArg
e)
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
original_depth [ByteOff]
szsb = [ByteOff] -> [ByteOff]
forall a. [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]
typePrimRepArgs
data BcM_State
= BcM_State
{ BcM_State -> HscEnv
bcm_hsc_env :: HscEnv
, BcM_State -> UniqSupply
uniqSupply :: UniqSupply
, 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 -> IdEnv (RemotePtr ())
topStrings :: IdEnv (RemotePtr ())
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (a -> BcM b -> BcM a
(a -> b) -> BcM a -> BcM b
(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
<$ :: a -> BcM b -> BcM a
$c<$ :: forall a b. a -> BcM b -> BcM a
fmap :: (a -> b) -> BcM a -> BcM b
$cfmap :: forall a b. (a -> b) -> BcM a -> BcM b
Functor)
ioToBc :: IO a -> BcM a
ioToBc :: 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
a
x <- IO a
io
(BcM_State, a) -> IO (BcM_State, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, a
x)
runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc :: HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc HscEnv
hsc_env UniqSupply
us Module
this_mod Maybe ModBreaks
modBreaks IdEnv (RemotePtr ())
topStrings (BcM BcM_State -> IO (BcM_State, r)
m)
= BcM_State -> IO (BcM_State, r)
m (HscEnv
-> UniqSupply
-> Module
-> Word32
-> [FFIInfo]
-> Maybe ModBreaks
-> IntMap CgBreakInfo
-> IdEnv (RemotePtr ())
-> BcM_State
BcM_State HscEnv
hsc_env UniqSupply
us Module
this_mod Word32
0 [] Maybe ModBreaks
modBreaks IntMap CgBreakInfo
forall a. IntMap a
IntMap.empty IdEnv (RemotePtr ())
topStrings)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc :: 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
(BcM_State
st1, a
q) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
let BcM BcM_State -> IO (BcM_State, b)
k = a -> BcM b
cont a
q
(BcM_State
st2, b
r) <- BcM_State -> IO (BcM_State, b)
k BcM_State
st1
(BcM_State, b) -> IO (BcM_State, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st2, b
r)
thenBc_ :: BcM a -> BcM b -> BcM b
thenBc_ :: 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
(BcM_State
st1, a
_) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
(BcM_State
st2, b
r) <- BcM_State -> IO (BcM_State, b)
cont BcM_State
st1
(BcM_State, b) -> IO (BcM_State, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st2, b
r)
returnBc :: a -> BcM a
returnBc :: 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 (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, a
result))
instance Applicative BcM where
pure :: a -> BcM a
pure = a -> BcM a
forall a. a -> BcM a
returnBc
<*> :: 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
*> :: 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
>>= :: 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
>> :: BcM a -> BcM b -> BcM 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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{ffis :: [FFIInfo]
ffis=[]}, [FFIInfo] -> ProtoBCO Name
bco (BcM_State -> [FFIInfo]
ffis BcM_State
st))
recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc RemotePtr C_ffi_cif
a
= (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 (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{ffis :: [FFIInfo]
ffis = RemotePtr C_ffi_cif -> FFIInfo
FFIInfo RemotePtr C_ffi_cif
a FFIInfo -> [FFIInfo] -> [FFIInfo]
forall a. a -> [a] -> [a]
: BcM_State -> [FFIInfo]
ffis BcM_State
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. String -> a
panic String
"getLabelBc: Ran out of labels"
(BcM_State, LocalLabel) -> IO (BcM_State, LocalLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel :: Word32
nextlabel = Word32
nl Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1}, Word32 -> LocalLabel
LocalLabel Word32
nl)
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc Word32
n
= (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 (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel :: Word32
nextlabel = Word32
ctrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
n}, [Word32] -> [LocalLabel]
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])
getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
getCCArray :: BcM (Array Int (RemotePtr CostCentre))
getCCArray = (BcM_State -> IO (BcM_State, Array Int (RemotePtr CostCentre)))
-> BcM (Array Int (RemotePtr CostCentre))
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Array Int (RemotePtr CostCentre)))
-> BcM (Array Int (RemotePtr CostCentre)))
-> (BcM_State -> IO (BcM_State, Array Int (RemotePtr CostCentre)))
-> BcM (Array Int (RemotePtr CostCentre))
forall a b. (a -> b) -> a -> b
$ \BcM_State
st ->
let breaks :: ModBreaks
breaks = String -> Maybe ModBreaks -> ModBreaks
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"GHC.StgToByteCode.getCCArray" (Maybe ModBreaks -> ModBreaks) -> Maybe ModBreaks -> ModBreaks
forall a b. (a -> b) -> a -> b
$ BcM_State -> Maybe ModBreaks
modBreaks BcM_State
st in
(BcM_State, Array Int (RemotePtr CostCentre))
-> IO (BcM_State, Array Int (RemotePtr CostCentre))
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, ModBreaks -> Array Int (RemotePtr CostCentre)
modBreaks_ccs ModBreaks
breaks)
newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
newBreakInfo :: Int -> CgBreakInfo -> BcM ()
newBreakInfo Int
ix CgBreakInfo
info = (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 (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{breakInfo :: IntMap CgBreakInfo
breakInfo = Int -> CgBreakInfo -> IntMap CgBreakInfo -> IntMap CgBreakInfo
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
ix CgBreakInfo
info (BcM_State -> IntMap CgBreakInfo
breakInfo BcM_State
st)}, ())
newUnique :: BcM Unique
newUnique :: BcM Unique
newUnique = (BcM_State -> IO (BcM_State, Unique)) -> BcM Unique
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Unique)) -> BcM Unique)
-> (BcM_State -> IO (BcM_State, Unique)) -> BcM Unique
forall a b. (a -> b) -> a -> b
$
\BcM_State
st -> case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (BcM_State -> UniqSupply
uniqSupply BcM_State
st) of
(Unique
uniq, UniqSupply
us) -> let newState :: BcM_State
newState = BcM_State
st { uniqSupply :: UniqSupply
uniqSupply = UniqSupply
us }
in (BcM_State, Unique) -> IO (BcM_State, Unique)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
newState, Unique
uniq)
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 (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> Module
thisModule BcM_State
st)
getTopStrings :: BcM (IdEnv (RemotePtr ()))
getTopStrings :: BcM (IdEnv (RemotePtr ()))
getTopStrings = (BcM_State -> IO (BcM_State, IdEnv (RemotePtr ())))
-> BcM (IdEnv (RemotePtr ()))
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, IdEnv (RemotePtr ())))
-> BcM (IdEnv (RemotePtr ())))
-> (BcM_State -> IO (BcM_State, IdEnv (RemotePtr ())))
-> BcM (IdEnv (RemotePtr ()))
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, IdEnv (RemotePtr ()))
-> IO (BcM_State, IdEnv (RemotePtr ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> IdEnv (RemotePtr ())
topStrings BcM_State
st)
newId :: Type -> BcM Id
newId :: Type -> BcM Id
newId Type
ty = do
Unique
uniq <- BcM Unique
newUnique
Id -> BcM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> BcM Id) -> Id -> BcM Id
forall a b. (a -> b) -> a -> b
$ FastString -> Unique -> Type -> Type -> Id
mkSysLocal FastString
tickFS Unique
uniq Type
Many Type
ty
tickFS :: FastString
tickFS :: FastString
tickFS = String -> FastString
fsLit String
"ticked"