-- -----------------------------------------------------------------------------
--
-- (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 :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm NCGConfig
_ top :: RawCmmDecl
top@(CmmData Section
_ RawCmmStatics
_) = (RawCmmDecl
top, [])
cmmToCmm NCGConfig
config (CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
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)

instance Applicative CmmOptM where
    pure :: forall a. a -> CmmOptM a
pure a
x = (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a)
-> (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
forall a b. (a -> b) -> a -> b
$ \NCGConfig
_ [CLabel]
imports -> a -> [CLabel] -> OptMResult a
forall a b. a -> b -> (# a, b #)
OptMResult a
x [CLabel]
imports
    <*> :: forall a b. CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b
(<*>) = CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad CmmOptM where
  (CmmOptM NCGConfig -> [CLabel] -> OptMResult a
f) >>= :: forall a b. CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b
>>= a -> CmmOptM b
g =
    (NCGConfig -> [CLabel] -> OptMResult b) -> CmmOptM b
forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> [CLabel] -> OptMResult b) -> CmmOptM b)
-> (NCGConfig -> [CLabel] -> OptMResult b) -> CmmOptM b
forall a b. (a -> b) -> a -> b
$ \NCGConfig
config [CLabel]
imports0 ->
                case NCGConfig -> [CLabel] -> OptMResult a
f NCGConfig
config [CLabel]
imports0 of
                  OptMResult a
x [CLabel]
imports1 ->
                    case a -> CmmOptM b
g a
x of
                      CmmOptM NCGConfig -> [CLabel] -> OptMResult b
g' -> NCGConfig -> [CLabel] -> OptMResult b
g' NCGConfig
config [CLabel]
imports1

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'

-- 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 :: 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

-- handles both PIC and non-PIC cases... a very strange mixture
-- of things to do.
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)))
          -- 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 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
                -- 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 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