-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
--
--
-- -----------------------------------------------------------------------------
{-# 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
-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser
{-
Here we do:
(a) Constant folding
(c) Position independent code and dynamic linking
(i) introduce the appropriate indirections
and position independent refs
(ii) compile a list of imported symbols
(d) Some arch-specific optimizations
(a) will be moving to the new Hoopl pipeline, however, (c) and
(d) are only needed by the native backend and will continue to live
here.
Ideas for other things we could do (put these in Hoopl please!):
- shortcut jumps-to-jumps
- simple CSE: if an expr is assigned to a temp, then replace later occs of
that expr with the temp, until the expr is no longer valid (can push through
temp assignments, and certain assigns to mem...)
-}
cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
cmmToCmm config (CmmProc info lbl live graph)
= runCmmOpt config $
do blocks' <- mapM cmmBlockConFold (toBlockList graph)
return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
type OptMResult a = (# a, [CLabel] #)
pattern OptMResult :: a -> b -> (# a, b #)
pattern OptMResult x y = (# x, y #)
{-# COMPLETE OptMResult #-}
newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)
deriving (Functor)
instance Applicative CmmOptM where
pure x = CmmOptM $ \_ imports -> OptMResult x imports
(<*>) = ap
instance Monad CmmOptM where
(CmmOptM f) >>= g =
CmmOptM $ \config imports0 ->
case f config imports0 of
OptMResult x imports1 ->
case g x of
CmmOptM g' -> g' config imports1
instance CmmMakeDynamicReferenceM CmmOptM where
addImport = addImportCmmOpt
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports)
getCmmOptConfig :: CmmOptM NCGConfig
getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports
runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])
runCmmOpt config (CmmOptM f) =
case f config [] of
OptMResult result imports -> (result, imports)
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold block = do
let (entry, middle, last) = blockSplit block
stmts = blockToList middle
stmts' <- mapM cmmStmtConFold stmts
last' <- cmmStmtConFold last
return $ blockJoin entry (blockFromList stmts') last'
-- This does three optimizations, but they're very quick to check, so we don't
-- bother turning them off even when the Hoopl code is active. Since
-- this is on the old Cmm representation, we can't reuse the code either:
-- * reg = reg --> nop
-- * if 0 then jump --> nop
-- * if 1 then jump --> jump
-- We might be tempted to skip this step entirely of not Opt_PIC, but
-- there is some PowerPC code for the non-PIC case, which would also
-- have to be separated.
cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
-> do src' <- cmmExprConFold DataReference src
return $ case src' of
CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")
new_src -> CmmAssign reg new_src
CmmStore addr src align
-> do addr' <- cmmExprConFold DataReference addr
src' <- cmmExprConFold DataReference src
return $ CmmStore addr' src' align
CmmCall { cml_target = addr }
-> do addr' <- cmmExprConFold JumpReference addr
return $ stmt { cml_target = addr' }
CmmUnsafeForeignCall target regs args
-> do target' <- case target of
ForeignTarget e conv -> do
e' <- cmmExprConFold CallReference e
return $ ForeignTarget e' conv
PrimTarget _ ->
return target
args' <- mapM (cmmExprConFold DataReference) args
return $ CmmUnsafeForeignCall target' regs args'
CmmCondBranch test true false likely
-> do test' <- cmmExprConFold DataReference test
return $ case test' of
CmmLit (CmmInt 0 _) -> CmmBranch false
CmmLit (CmmInt _ _) -> CmmBranch true
_other -> CmmCondBranch test' true false likely
CmmSwitch expr ids
-> do expr' <- cmmExprConFold DataReference expr
return $ CmmSwitch expr' ids
other
-> return other
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind expr = do
config <- getCmmOptConfig
let expr' = if not (ncgDoConstantFolding config)
then expr
else cmmExprCon config expr
cmmExprNative referenceKind expr'
cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align
cmmExprCon config (CmmMachOp mop args)
= cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args)
cmmExprCon _ other = other
-- handles both PIC and non-PIC cases... a very strange mixture
-- of things to do.
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative referenceKind expr = do
config <- getCmmOptConfig
let platform = ncgPlatform config
arch = platformArch platform
case expr of
CmmLoad addr rep align
-> do addr' <- cmmExprNative DataReference addr
return $ CmmLoad addr' rep align
CmmMachOp mop args
-> do args' <- mapM (cmmExprNative DataReference) args
return $ CmmMachOp mop args'
CmmLit (CmmBlock id)
-> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
-- we must convert block Ids to CLabels here, because we
-- might have to do the PIC transformation. Hence we must
-- not modify BlockIds beyond this point.
CmmLit (CmmLabel lbl)
-> cmmMakeDynamicReference config referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do dynRef <- cmmMakeDynamicReference config referenceKind lbl
-- need to optimize here, since it's late
return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))
]
-- On powerpc (non-PIC), it's easier to jump directly to a label than
-- to use the register table, so we replace these registers
-- with the corresponding labels:
CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _))
| arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _))
| arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal (GlobalRegUse GCFun _))
| arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
other
-> return other