{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}
module GHC.Cmm.GenericOpt
( cmmToCmm
)
where
import GHC.Prelude hiding (head)
import GHC.Platform
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Types
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Opt ( cmmMachOpFold )
import GHC.Cmm.CLabel
import GHC.Data.FastString
import GHC.Unit
import Control.Monad.Trans.Reader
import GHC.Utils.Monad.State.Strict as Strict
cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm NCGConfig
_ top :: RawCmmDecl
top@(CmmData Section
_ RawCmmStatics
_) = (RawCmmDecl
top, [])
cmmToCmm NCGConfig
config (CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalRegUse]
live CmmGraph
graph)
= NCGConfig -> CmmOptM RawCmmDecl -> (RawCmmDecl, [CLabel])
forall a. NCGConfig -> CmmOptM a -> (a, [CLabel])
runCmmOpt NCGConfig
config (CmmOptM RawCmmDecl -> (RawCmmDecl, [CLabel]))
-> CmmOptM RawCmmDecl -> (RawCmmDecl, [CLabel])
forall a b. (a -> b) -> a -> b
$
do blocks' <- (CmmBlock -> CmmOptM CmmBlock) -> [CmmBlock] -> CmmOptM [CmmBlock]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold (CmmGraph -> [CmmBlock]
toBlockList CmmGraph
graph)
return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
type OptMResult a = (# a, [CLabel] #)
pattern OptMResult :: a -> b -> (# a, b #)
pattern $mOptMResult :: forall {r} {a} {b}.
(# a, b #) -> (a -> b -> r) -> ((# #) -> r) -> r
$bOptMResult :: forall a b. a -> b -> (# a, b #)
OptMResult x y = (# x, y #)
{-# COMPLETE OptMResult #-}
newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)
deriving ((forall a b. (a -> b) -> CmmOptM a -> CmmOptM b)
-> (forall a b. a -> CmmOptM b -> CmmOptM a) -> Functor CmmOptM
forall a b. a -> CmmOptM b -> CmmOptM a
forall a b. (a -> b) -> CmmOptM a -> CmmOptM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CmmOptM a -> CmmOptM b
fmap :: forall a b. (a -> b) -> CmmOptM a -> CmmOptM b
$c<$ :: forall a b. a -> CmmOptM b -> CmmOptM a
<$ :: forall a b. a -> CmmOptM b -> CmmOptM a
Functor, Functor CmmOptM
Functor CmmOptM =>
(forall a. a -> CmmOptM a)
-> (forall a b. CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b)
-> (forall a b c.
(a -> b -> c) -> CmmOptM a -> CmmOptM b -> CmmOptM c)
-> (forall a b. CmmOptM a -> CmmOptM b -> CmmOptM b)
-> (forall a b. CmmOptM a -> CmmOptM b -> CmmOptM a)
-> Applicative CmmOptM
forall a. a -> CmmOptM a
forall a b. CmmOptM a -> CmmOptM b -> CmmOptM a
forall a b. CmmOptM a -> CmmOptM b -> CmmOptM b
forall a b. CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b
forall a b c. (a -> b -> c) -> CmmOptM a -> CmmOptM b -> CmmOptM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> CmmOptM a
pure :: forall a. a -> CmmOptM a
$c<*> :: forall a b. CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b
<*> :: forall a b. CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b
$cliftA2 :: forall a b c. (a -> b -> c) -> CmmOptM a -> CmmOptM b -> CmmOptM c
liftA2 :: forall a b c. (a -> b -> c) -> CmmOptM a -> CmmOptM b -> CmmOptM c
$c*> :: forall a b. CmmOptM a -> CmmOptM b -> CmmOptM b
*> :: forall a b. CmmOptM a -> CmmOptM b -> CmmOptM b
$c<* :: forall a b. CmmOptM a -> CmmOptM b -> CmmOptM a
<* :: forall a b. CmmOptM a -> CmmOptM b -> CmmOptM a
Applicative, Applicative CmmOptM
Applicative CmmOptM =>
(forall a b. CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b)
-> (forall a b. CmmOptM a -> CmmOptM b -> CmmOptM b)
-> (forall a. a -> CmmOptM a)
-> Monad CmmOptM
forall a. a -> CmmOptM a
forall a b. CmmOptM a -> CmmOptM b -> CmmOptM b
forall a b. CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b
>>= :: forall a b. CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b
$c>> :: forall a b. CmmOptM a -> CmmOptM b -> CmmOptM b
>> :: forall a b. CmmOptM a -> CmmOptM b -> CmmOptM b
$creturn :: forall a. a -> CmmOptM a
return :: forall a. a -> CmmOptM a
Monad) via (ReaderT NCGConfig (Strict.State [CLabel]))
instance CmmMakeDynamicReferenceM CmmOptM where
addImport :: CLabel -> CmmOptM ()
addImport = CLabel -> CmmOptM ()
addImportCmmOpt
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt CLabel
lbl = (NCGConfig -> [CLabel] -> OptMResult ()) -> CmmOptM ()
forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> [CLabel] -> OptMResult ()) -> CmmOptM ())
-> (NCGConfig -> [CLabel] -> OptMResult ()) -> CmmOptM ()
forall a b. (a -> b) -> a -> b
$ \NCGConfig
_ [CLabel]
imports -> () -> [CLabel] -> OptMResult ()
forall a b. a -> b -> (# a, b #)
OptMResult () (CLabel
lblCLabel -> [CLabel] -> [CLabel]
forall a. a -> [a] -> [a]
:[CLabel]
imports)
getCmmOptConfig :: CmmOptM NCGConfig
getCmmOptConfig :: CmmOptM NCGConfig
getCmmOptConfig = (NCGConfig -> [CLabel] -> OptMResult NCGConfig)
-> CmmOptM NCGConfig
forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> [CLabel] -> OptMResult NCGConfig)
-> CmmOptM NCGConfig)
-> (NCGConfig -> [CLabel] -> OptMResult NCGConfig)
-> CmmOptM NCGConfig
forall a b. (a -> b) -> a -> b
$ \NCGConfig
config [CLabel]
imports -> NCGConfig -> [CLabel] -> OptMResult NCGConfig
forall a b. a -> b -> (# a, b #)
OptMResult NCGConfig
config [CLabel]
imports
runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])
runCmmOpt :: forall a. NCGConfig -> CmmOptM a -> (a, [CLabel])
runCmmOpt NCGConfig
config (CmmOptM NCGConfig -> [CLabel] -> OptMResult a
f) =
case NCGConfig -> [CLabel] -> OptMResult a
f NCGConfig
config [] of
OptMResult a
result [CLabel]
imports -> (a
result, [CLabel]
imports)
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold CmmBlock
block = do
let (CmmNode 'Closed 'Open
entry, Block CmmNode 'Open 'Open
middle, CmmNode 'Open 'Closed
last) = CmmBlock
-> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Open,
CmmNode 'Open 'Closed)
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Closed 'Closed
-> (n 'Closed 'Open, Block n 'Open 'Open, n 'Open 'Closed)
blockSplit CmmBlock
block
stmts :: [CmmNode 'Open 'Open]
stmts = Block CmmNode 'Open 'Open -> [CmmNode 'Open 'Open]
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Open 'Open -> [n 'Open 'Open]
blockToList Block CmmNode 'Open 'Open
middle
stmts' <- (CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open))
-> [CmmNode 'Open 'Open] -> CmmOptM [CmmNode 'Open 'Open]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold [CmmNode 'Open 'Open]
stmts
last' <- cmmStmtConFold last
return $ blockJoin entry (blockFromList stmts') last'
cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold CmmNode e x
stmt
= case CmmNode e x
stmt of
CmmAssign CmmReg
reg CmmExpr
src
-> do src' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
src
return $ case src' of
CmmReg CmmReg
reg' | CmmReg
reg CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== CmmReg
reg' -> FastString -> CmmNode 'Open 'Open
CmmComment (String -> FastString
fsLit String
"nop")
CmmExpr
new_src -> CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
reg CmmExpr
new_src
CmmStore CmmExpr
addr CmmExpr
src AlignmentSpec
align
-> do addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
addr
src' <- cmmExprConFold DataReference src
return $ CmmStore addr' src' align
CmmCall { cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target = CmmExpr
addr }
-> do addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
JumpReference CmmExpr
addr
return $ stmt { cml_target = addr' }
CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
regs [CmmExpr]
args
-> do target' <- case ForeignTarget
target of
ForeignTarget CmmExpr
e ForeignConvention
conv -> do
e' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
CallReference CmmExpr
e
return $ ForeignTarget e' conv
PrimTarget CallishMachOp
_ ->
ForeignTarget -> CmmOptM ForeignTarget
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignTarget
target
args' <- mapM (cmmExprConFold DataReference) args
return $ CmmUnsafeForeignCall target' regs args'
CmmCondBranch CmmExpr
test BlockId
true BlockId
false Maybe Bool
likely
-> do test' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
test
return $ case test' of
CmmLit (CmmInt Integer
0 Width
_) -> BlockId -> CmmNode 'Open 'Closed
CmmBranch BlockId
false
CmmLit (CmmInt Integer
_ Width
_) -> BlockId -> CmmNode 'Open 'Closed
CmmBranch BlockId
true
CmmExpr
_other -> CmmExpr
-> BlockId -> BlockId -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
test' BlockId
true BlockId
false Maybe Bool
likely
CmmSwitch CmmExpr
expr SwitchTargets
ids
-> do expr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
expr
return $ CmmSwitch expr' ids
CmmNode e x
other
-> CmmNode e x -> CmmOptM (CmmNode e x)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmNode e x
other
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
referenceKind CmmExpr
expr = do
config <- CmmOptM NCGConfig
getCmmOptConfig
let expr' = if Bool -> Bool
not (NCGConfig -> Bool
ncgDoConstantFolding NCGConfig
config)
then CmmExpr
expr
else NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config CmmExpr
expr
cmmExprNative referenceKind expr'
cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config (CmmLoad CmmExpr
addr CmmType
rep AlignmentSpec
align) = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config CmmExpr
addr) CmmType
rep AlignmentSpec
align
cmmExprCon NCGConfig
config (CmmMachOp MachOp
mop [CmmExpr]
args)
= Platform -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold (NCGConfig -> Platform
ncgPlatform NCGConfig
config) MachOp
mop ((CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config) [CmmExpr]
args)
cmmExprCon NCGConfig
_ CmmExpr
other = CmmExpr
other
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind CmmExpr
expr = do
config <- CmmOptM NCGConfig
getCmmOptConfig
let platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
arch = Platform -> Arch
platformArch Platform
platform
case expr of
CmmLoad CmmExpr
addr CmmType
rep AlignmentSpec
align
-> do addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
DataReference CmmExpr
addr
return $ CmmLoad addr' rep align
CmmMachOp MachOp
mop [CmmExpr]
args
-> do args' <- (CmmExpr -> CmmOptM CmmExpr) -> [CmmExpr] -> CmmOptM [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
DataReference) [CmmExpr]
args
return $ CmmMachOp mop args'
CmmLit (CmmBlock BlockId
id)
-> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (BlockId -> CLabel
infoTblLbl BlockId
id)))
CmmLit (CmmLabel CLabel
lbl)
-> NCGConfig -> ReferenceKind -> CLabel -> CmmOptM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
referenceKind CLabel
lbl
CmmLit (CmmLabelOff CLabel
lbl Int
off)
-> do dynRef <- NCGConfig -> ReferenceKind -> CLabel -> CmmOptM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
referenceKind CLabel
lbl
return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))
]
CmmReg (CmmGlobal (GlobalRegUse GlobalReg
EagerBlackholeInfo CmmType
_))
| Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (NCGConfig -> Bool
ncgPIC NCGConfig
config)
-> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$
CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
rtsUnitId (String -> FastString
fsLit String
"__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal (GlobalRegUse GlobalReg
GCEnter1 CmmType
_))
| Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (NCGConfig -> Bool
ncgPIC NCGConfig
config)
-> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$
CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
rtsUnitId (String -> FastString
fsLit String
"__stg_gc_enter_1")))
CmmReg (CmmGlobal (GlobalRegUse GlobalReg
GCFun CmmType
_))
| Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (NCGConfig -> Bool
ncgPIC NCGConfig
config)
-> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$
CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
rtsUnitId (String -> FastString
fsLit String
"__stg_gc_fun")))
CmmExpr
other
-> CmmExpr -> CmmOptM CmmExpr
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmExpr
other