-- -----------------------------------------------------------------------------
--
-- (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 [CmmBlock]
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)
         RawCmmDecl -> CmmOptM RawCmmDecl
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawCmmDecl -> CmmOptM RawCmmDecl)
-> RawCmmDecl -> CmmOptM RawCmmDecl
forall a b. (a -> b) -> a -> b
$ LabelMap RawCmmStatics
-> CLabel -> [GlobalReg] -> CmmGraph -> RawCmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
graph) [CmmBlock]
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
  [CmmNode 'Open 'Open]
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
  CmmNode 'Open 'Closed
last' <- CmmNode 'Open 'Closed -> CmmOptM (CmmNode 'Open 'Closed)
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold CmmNode 'Open 'Closed
last
  CmmBlock -> CmmOptM CmmBlock
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmBlock -> CmmOptM CmmBlock) -> CmmBlock -> CmmOptM CmmBlock
forall a b. (a -> b) -> a -> b
$ CmmNode 'Closed 'Open
-> Block CmmNode 'Open 'Open -> CmmNode 'Open 'Closed -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n 'Closed 'Open
-> Block n 'Open 'Open
-> n 'Open 'Closed
-> Block n 'Closed 'Closed
blockJoin CmmNode 'Closed 'Open
entry ([CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
[n 'Open 'Open] -> Block n 'Open 'Open
blockFromList [CmmNode 'Open 'Open]
stmts') CmmNode 'Open 'Closed
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 CmmExpr
src' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
src
                 CmmNode e x -> CmmOptM (CmmNode e x)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode e x -> CmmOptM (CmmNode e x))
-> CmmNode e x -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ case CmmExpr
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 CmmExpr
addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
addr
                 CmmExpr
src'  <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
src
                 CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode 'Open 'Open
CmmStore CmmExpr
addr' CmmExpr
src' AlignmentSpec
align

        CmmCall { cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target = CmmExpr
addr }
           -> do CmmExpr
addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
JumpReference CmmExpr
addr
                 CmmNode e x -> CmmOptM (CmmNode e x)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode e x -> CmmOptM (CmmNode e x))
-> CmmNode e x -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ CmmNode e x
stmt { cml_target = addr' }

        CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
regs [CmmExpr]
args
           -> do ForeignTarget
target' <- case ForeignTarget
target of
                              ForeignTarget CmmExpr
e ForeignConvention
conv -> do
                                CmmExpr
e' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
CallReference CmmExpr
e
                                ForeignTarget -> CmmOptM ForeignTarget
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignTarget -> CmmOptM ForeignTarget)
-> ForeignTarget -> CmmOptM ForeignTarget
forall a b. (a -> b) -> a -> b
$ CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
e' ForeignConvention
conv
                              PrimTarget CallishMachOp
_ ->
                                ForeignTarget -> CmmOptM ForeignTarget
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignTarget
target
                 [CmmExpr]
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
cmmExprConFold ReferenceKind
DataReference) [CmmExpr]
args
                 CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall ForeignTarget
target' [CmmFormal]
regs [CmmExpr]
args'

        CmmCondBranch CmmExpr
test BlockId
true BlockId
false Maybe Bool
likely
           -> do CmmExpr
test' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
test
                 CmmNode e x -> CmmOptM (CmmNode e x)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode e x -> CmmOptM (CmmNode e x))
-> CmmNode e x -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ case CmmExpr
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 CmmExpr
expr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
expr
                 CmmNode 'Open 'Closed -> CmmOptM (CmmNode 'Open 'Closed)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode 'Open 'Closed -> CmmOptM (CmmNode 'Open 'Closed))
-> CmmNode 'Open 'Closed -> CmmOptM (CmmNode 'Open 'Closed)
forall a b. (a -> b) -> a -> b
$ CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch CmmExpr
expr' SwitchTargets
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
    NCGConfig
config <- CmmOptM NCGConfig
getCmmOptConfig

    let expr' :: CmmExpr
expr' = if Bool -> Bool
not (NCGConfig -> Bool
ncgDoConstantFolding NCGConfig
config)
                    then CmmExpr
expr
                    else NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config CmmExpr
expr

    ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind CmmExpr
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
     NCGConfig
config <- CmmOptM NCGConfig
getCmmOptConfig
     let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
         arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform
     case CmmExpr
expr of
        CmmLoad CmmExpr
addr CmmType
rep AlignmentSpec
align
          -> do CmmExpr
addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
DataReference CmmExpr
addr
                CmmExpr -> CmmOptM CmmExpr
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
addr' CmmType
rep AlignmentSpec
align

        CmmMachOp MachOp
mop [CmmExpr]
args
          -> do [CmmExpr]
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
                CmmExpr -> CmmOptM CmmExpr
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$ MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
mop [CmmExpr]
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 CmmExpr
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
                CmmExpr -> CmmOptM CmmExpr
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$ Platform -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold Platform
platform (Width -> MachOp
MO_Add (Platform -> Width
wordWidth Platform
platform)) [
                    CmmExpr
dynRef,
                    (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) (Platform -> Width
wordWidth Platform
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