compiler: move generic cmm optimization logic in NCG to a standalone module

This commit moves GHC.CmmToAsm.cmmToCmm to a standalone module,
GHC.Cmm.GenericOpt. The main motivation is enabling this logic to be
run in the wasm backend NCG code, which is defined in other modules
that's imported by GHC.CmmToAsm, causing a cyclic dependency issue.

(cherry picked from commit 6534da24)

compiler/GHC/Cmm/GenericOpt.hs

+-- -----------------------------------------------------------------------------
+--
+-- (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

compiler/GHC/CmmToAsm.hs

@@ -110,11 +110,9 @@ import GHC.Cmm.DebugBlock
 import GHC.Cmm.BlockId
 import GHC.StgToCmm.CgUtils ( fixStgRegisters )
 import GHC.Cmm
-import GHC.Cmm.Utils
 import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Opt           ( cmmMachOpFold )
+import GHC.Cmm.GenericOpt
 import GHC.Cmm.CLabel
 
 import GHC.Types.Unique.FM
@@ -949,196 +947,3 @@ genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
                       , natm_fileid final_st, final_cfg)
           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
     }
-
--- -----------------------------------------------------------------------------
--- 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

compiler/ghc.cabal.in

@@ -212,6 +212,7 @@ Library
         GHC.Cmm.Dataflow.Label
         GHC.Cmm.DebugBlock
         GHC.Cmm.Expr
+        GHC.Cmm.GenericOpt
         GHC.Cmm.Graph
         GHC.Cmm.Info
         GHC.Cmm.Info.Build