Eliminate duplicate code in Cmm pipeline
[ghc.git] / compiler / cmm / CmmPipeline.hs
index 470751b..1447f6d 100644 (file)
@@ -1,7 +1,3 @@
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
--- Norman likes local bindings
--- If this module lives on I'd like to get rid of this flag in due course
-
 module CmmPipeline (
   -- | Converts C-- with an implicit stack and native C-- calls into
   -- optimized, CPS converted and native-call-less C--.  The latter
@@ -9,192 +5,356 @@ module CmmPipeline (
   cmmPipeline
 ) where
 
-import CLabel
 import Cmm
 import CmmLint
-import CmmLive
 import CmmBuildInfoTables
 import CmmCommonBlockElim
 import CmmProcPoint
-import CmmRewriteAssignments
 import CmmContFlowOpt
-import OptimizationFuel
 import CmmLayoutStack
+import CmmSink
 import Hoopl
-import CmmUtils
 
+import UniqSupply
 import DynFlags
 import ErrUtils
 import HscTypes
-import Data.Maybe
 import Control.Monad
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
 import Outputable
-import StaticFlags
+import Platform
 
 -----------------------------------------------------------------------------
 -- | Top level driver for C-- pipeline
 -----------------------------------------------------------------------------
--- There are two complications here:
--- 1. We need to compile the procedures in two stages because we need
---    an analysis of the procedures to tell us what CAFs they use.
---    The first stage returns a map from procedure labels to CAFs,
---    along with a closure that will compute SRTs and attach them to
---    the compiled procedures.
---    The second stage is to combine the CAF information into a top-level
---    CAF environment mapping non-static closures to the CAFs they keep live,
---    then pass that environment to the closures returned in the first
---    stage of compilation.
--- 2. We need to thread the module's SRT around when the SRT tables
---    are computed for each procedure.
---    The SRT needs to be threaded because it is grown lazily.
--- 3. We run control flow optimizations twice, once before any pipeline
---    work is done, and once again at the very end on all of the
---    resulting C-- blocks.  EZY: It's unclear whether or not whether
---    we actually need to do the initial pass.
+
 cmmPipeline  :: HscEnv -- Compilation env including
                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
              -> TopSRT     -- SRT table and accumulating list of compiled procs
              -> CmmGroup             -- Input C-- with Procedures
              -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
+
 cmmPipeline hsc_env topSRT prog =
   do let dflags = hsc_dflags hsc_env
-     --
-     showPass dflags "CPSZ"
 
-     (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) prog
-     -- tops :: [[(CmmDecl,CAFSet]]  (one list per group)
+     showPass dflags "CPSZ"
 
-     let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
+     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
 
-     -- folding over the groups
-     (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
+     (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" cmms
 
-     let cmms :: CmmGroup
-         cmms = reverse (concat tops)
+     return (topSRT, cmms)
 
-     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
 
-     return (topSRT, cmms)
+cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
+cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
+cpsTop hsc_env proc =
+    do
+       ----------- Control-flow optimisations ----------------------------------
 
-{- [Note global fuel]
-~~~~~~~~~~~~~~~~~~~~~
-The identity and the last pass are stored in
-mutable reference cells in an 'HscEnv' and are
-global to one compiler session.
--}
+       -- The first round of control-flow optimisation speeds up the
+       -- later passes by removing lots of empty blocks, so we do it
+       -- even when optimisation isn't turned on.
+       --
+       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
+            return $ cmmCfgOptsProc splitting_proc_points proc
+       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
 
--- EZY: It might be helpful to have an easy way of dumping the "pre"
--- input for any given phase, besides just turning it all on with
--- -ddump-cmmz
+       let !TopInfo {stack_info=StackInfo { arg_space = entry_off
+                                          , do_layout = do_layout }} = h
 
-cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)])
-cpsTop _ p@(CmmData {}) = return ([], [(Set.empty, p)])
-cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
-    do
-       ----------- Control-flow optimisations ---------------
-       g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
-       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
+       ----------- Eliminate common blocks -------------------------------------
+       g <- {-# SCC "elimCommonBlocks" #-}
+            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
+                          Opt_D_dump_cmm_cbe "Post common block elimination"
 
-       ----------- Eliminate common blocks -------------------
-       g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
-       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
        -- Any work storing block Labels must be performed _after_
        -- elimCommonBlocks
 
-       ----------- Proc points -------------------
-       let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
-       procPoints <- {-# SCC "minimalProcPointSet" #-} run $
-                     minimalProcPointSet (targetPlatform dflags) callPPs g
-
-       ----------- Layout the stack and manifest Sp ---------------
-       -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
-       (g, stackmaps) <- {-# SCC "layoutStack" #-}
-                         run $ cmmLayoutStack procPoints entry_off g
-       dump Opt_D_dump_cmmz_sp "Layout Stack" g
-
---       ----------- Sink and inline assignments -------------------
---       g <- {-# SCC "rewriteAssignments" #-} runOptimization $
---            rewriteAssignments platform g
---       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
+       ----------- Proc points -------------------------------------------------
+       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
+       proc_points <-
+          if splitting_proc_points
+             then do
+               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
+                  minimalProcPointSet (targetPlatform dflags) call_pps g
+               dumpIfSet_dyn dflags Opt_D_dump_cmm "Proc points"
+                     (ppr l $$ ppr pp $$ ppr g)
+               return pp
+             else
+               return call_pps
 
-       ------------- Split into separate procedures ------------
-       procPointMap  <- {-# SCC "procPointAnalysis" #-} run $
-                        procPointAnalysis procPoints g
-       dumpWith dflags ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
-       gs <- {-# SCC "splitAtProcPoints" #-} run $
-             splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
-       dumps Opt_D_dump_cmmz_split "Post splitting" gs
+       ----------- Layout the stack and manifest Sp ----------------------------
+       (g, stackmaps) <-
+            {-# SCC "layoutStack" #-}
+            if do_layout
+               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
+               else return (g, mapEmpty)
+       dump Opt_D_dump_cmm_sp "Layout Stack" g
 
-       ------------- More CAFs ------------------------------
-       cafEnv <- {-# SCC "cafAnal" #-} run $ cafAnal platform g
-       let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
-       mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
+       ----------- Sink and inline assignments  --------------------------------
+       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
+            condPass Opt_CmmSink (cmmSink dflags) g
+                     Opt_D_dump_cmm_sink "Sink assignments"
 
-       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
-       gs <- {-# SCC "setInfoTableStackMap" #-}
-             return $ map (setInfoTableStackMap stackmaps) gs
-       dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
+       ------------- CAF analysis ----------------------------------------------
+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
+       dumpIfSet_dyn dflags Opt_D_dump_cmm "CAFEnv" (ppr cafEnv)
 
-       ----------- Control-flow optimisations ---------------
-       gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
-       dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
+       g <- if splitting_proc_points
+            then do
+               ------------- Split into separate procedures -----------------------
+               pp_map  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
+                          procPointAnalysis proc_points g
+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" pp_map
+               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
+                    splitAtProcPoints dflags l call_pps proc_points pp_map
+                                      (CmmProc h l v g)
+               dumps Opt_D_dump_cmm_split "Post splitting" g
+               return g
+             else do
+               -- attach info tables to return points
+               return $ [attachContInfoTables call_pps (CmmProc h l v g)]
 
-       gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs
-       dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs
+       ------------- Populate info tables with stack info -----------------
+       g <- {-# SCC "setInfoTableStackMap" #-}
+            return $ map (setInfoTableStackMap dflags stackmaps) g
+       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
 
-       return (localCAFs, gs)
+       ----------- Control-flow optimisations -----------------------------
+       g <- {-# SCC "cmmCfgOpts(2)" #-}
+            return $ if optLevel dflags >= 1
+                     then map (cmmCfgOptsProc splitting_proc_points) g
+                     else g
+       g <- return (map removeUnreachableBlocksProc g)
+            -- See Note [unreachable blocks]
+       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
 
-              -- gs        :: [ (CAFSet, CmmDecl) ]
-              -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
+       return (cafEnv, g)
 
   where dflags = hsc_dflags hsc_env
         platform = targetPlatform dflags
-        mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
-                         | otherwise = z
         dump = dumpGraph dflags
 
         dumps flag name
-           = mapM_ (dumpWith dflags (pprPlatform platform) flag name)
+           = mapM_ (dumpWith dflags flag name)
+
+        condPass flag pass g dumpflag dumpname =
+            if gopt flag dflags
+               then do
+                    g <- return $ pass g
+                    dump dumpflag dumpname g
+                    return g
+               else return g
+
+
+        -- we don't need to split proc points for the NCG, unless
+        -- tablesNextToCode is off.  The latter is because we have no
+        -- label to put on info tables for basic blocks that are not
+        -- the entry point.
+        splitting_proc_points = hscTarget dflags /= HscAsm
+                             || not (tablesNextToCode dflags)
+                             || -- Note [inconsistent-pic-reg]
+                                usingInconsistentPicReg
+        usingInconsistentPicReg
+           = case (platformArch platform, platformOS platform, gopt Opt_PIC dflags)
+             of   (ArchX86, OSDarwin, pic) -> pic
+                  (ArchPPC, OSDarwin, pic) -> pic
+                  _                        -> False
+
+-- Note [Sinking after stack layout]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- In the past we considered running sinking pass also before stack
+-- layout, but after making some measurements we realized that:
+--
+--   a) running sinking only before stack layout produces slower
+--      code than running sinking only before stack layout
+--
+--   b) running sinking both before and after stack layout produces
+--      code that has the same performance as when running sinking
+--      only after stack layout.
+--
+-- In other words sinking before stack layout doesn't buy as anything.
+--
+-- An interesting question is "why is it better to run sinking after
+-- stack layout"? It seems that the major reason are stores and loads
+-- generated by stack layout. Consider this code before stack layout:
+--
+--  c1E:
+--      _c1C::P64 = R3;
+--      _c1B::P64 = R2;
+--      _c1A::P64 = R1;
+--      I64[(young<c1D> + 8)] = c1D;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      R3 = _c1C::P64;
+--      R2 = _c1B::P64;
+--      R1 = _c1A::P64;
+--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Stack layout pass will save all local variables live across a call
+-- (_c1C, _c1B and _c1A in this example) on the stack just before
+-- making a call and reload them from the stack after returning from a
+-- call:
+--
+--  c1E:
+--      _c1C::P64 = R3;
+--      _c1B::P64 = R2;
+--      _c1A::P64 = R1;
+--      I64[Sp - 32] = c1D;
+--      P64[Sp - 24] = _c1A::P64;
+--      P64[Sp - 16] = _c1B::P64;
+--      P64[Sp - 8] = _c1C::P64;
+--      Sp = Sp - 32;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      _c1A::P64 = P64[Sp + 8];
+--      _c1B::P64 = P64[Sp + 16];
+--      _c1C::P64 = P64[Sp + 24];
+--      R3 = _c1C::P64;
+--      R2 = _c1B::P64;
+--      R1 = _c1A::P64;
+--      Sp = Sp + 32;
+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- If we don't run sinking pass after stack layout we are basically
+-- left with such code. However, running sinking on this code can lead
+-- to significant improvements:
+--
+--  c1E:
+--      I64[Sp - 32] = c1D;
+--      P64[Sp - 24] = R1;
+--      P64[Sp - 16] = R2;
+--      P64[Sp - 8] = R3;
+--      Sp = Sp - 32;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      R3 = P64[Sp + 24];
+--      R2 = P64[Sp + 16];
+--      R1 = P64[Sp + 8];
+--      Sp = Sp + 32;
+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Now we only have 9 assignments instead of 15.
+--
+-- There is one case when running sinking before stack layout could
+-- be beneficial. Consider this:
+--
+--   L1:
+--      x = y
+--      call f() returns L2
+--   L2: ...x...y...
+--
+-- Since both x and y are live across a call to f, they will be stored
+-- on the stack during stack layout and restored after the call:
+--
+--   L1:
+--      x = y
+--      P64[Sp - 24] = L2
+--      P64[Sp - 16] = x
+--      P64[Sp - 8]  = y
+--      Sp = Sp - 24
+--      call f() returns L2
+--   L2:
+--      y = P64[Sp + 16]
+--      x = P64[Sp + 8]
+--      Sp = Sp + 24
+--      ...x...y...
+--
+-- However, if we run sinking before stack layout we would propagate x
+-- to its usage place (both x and y must be local register for this to
+-- be possible - global registers cannot be floated past a call):
+--
+--   L1:
+--      x = y
+--      call f() returns L2
+--   L2: ...y...y...
+--
+-- Thus making x dead at the call to f(). If we ran stack layout now
+-- we would generate less stores and loads:
+--
+--   L1:
+--      x = y
+--      P64[Sp - 16] = L2
+--      P64[Sp - 8]  = y
+--      Sp = Sp - 16
+--      call f() returns L2
+--   L2:
+--      y = P64[Sp + 8]
+--      Sp = Sp + 16
+--      ...y...y...
+--
+-- But since we don't see any benefits from running sinking befroe stack
+-- layout, this situation probably doesn't arise too often in practice.
+--
+
+{- Note [inconsistent-pic-reg]
+
+On x86/Darwin, PIC is implemented by inserting a sequence like
+
+    call 1f
+ 1: popl %reg
+
+at the proc entry point, and then referring to labels as offsets from
+%reg.  If we don't split proc points, then we could have many entry
+points in a proc that would need this sequence, and each entry point
+would then get a different value for %reg.  If there are any join
+points, then at the join point we don't have a consistent value for
+%reg, so we don't know how to refer to labels.
+
+Hence, on x86/Darwin, we have to split proc points, and then each proc
+point will get its own PIC initialisation sequence.
+
+The situation is the same for ppc/Darwin. We use essentially the same
+sequence to load the program counter onto reg:
+
+    bcl  20,31,1f
+ 1: mflr reg
+
+This isn't an issue on x86/ELF, where the sequence is
+
+    call 1f
+ 1: popl %reg
+    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg
+
+so %reg always has a consistent value: the address of
+_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
+
+-}
+
+{- Note [unreachable blocks]
+
+The control-flow optimiser sometimes leaves unreachable blocks behind
+containing junk code.  If these blocks make it into the native code
+generator then they trigger a register allocator panic because they
+refer to undefined LocalRegs, so we must eliminate any unreachable
+blocks before passing the code onwards.
+
+-}
 
-        -- Runs a required transformation/analysis
-        run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
-        -- Runs an optional transformation/analysis (and should
-        -- thus be subject to optimization fuel)
-        runOptimization = runFuelIO (hsc_OptFuel hsc_env)
+runUniqSM :: UniqSM a -> IO a
+runUniqSM m = do
+  us <- mkSplitUniqSupply 'u'
+  return (initUs_ us m)
 
 
-dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
+dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
 dumpGraph dflags flag name g = do
-  when (dopt Opt_DoCmmLinting dflags) $ do_lint g
-  dumpWith dflags (pprPlatform (targetPlatform dflags)) flag name g
+  when (gopt Opt_DoCmmLinting dflags) $ do_lint g
+  dumpWith dflags flag name g
  where
-  do_lint g = case cmmLintGraph (targetPlatform dflags) g of
-                 Just err -> do { printDump err
+  do_lint g = case cmmLintGraph dflags g of
+                 Just err -> do { fatalErrorMsg dflags err
                                 ; ghcExit dflags 1
                                 }
                  Nothing  -> return ()
 
-dumpWith :: DynFlags -> (a -> SDoc) -> DynFlag -> String -> a -> IO ()
-dumpWith dflags pprFun flag txt g = do
-         -- ToDo: No easy way of say "dump all the cmmz, *and* split
-         -- them into files."  Also, -ddump-cmmz doesn't play nicely
+dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO ()
+dumpWith dflags flag txt g = do
+         -- ToDo: No easy way of say "dump all the cmm, *and* split
+         -- them into files."  Also, -ddump-cmm doesn't play nicely
          -- with -ddump-to-file, since the headers get omitted.
-   dumpIfSet_dyn dflags flag txt (pprFun g)
+   dumpIfSet_dyn dflags flag txt (ppr g)
    when (not (dopt flag dflags)) $
-      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
-
--- This probably belongs in CmmBuildInfoTables?
--- We're just finishing the job here: once we know what CAFs are defined
--- in non-static closures, we can build the SRTs.
-toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
-                 -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
-toTops hsc_env topCAFEnv (topSRT, tops) gs =
-  do let setSRT (topSRT, rst) g =
-           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
-              return (topSRT, gs : rst)
-     (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
-     return (topSRT, concat gs' : tops)
+      dumpIfSet_dyn dflags Opt_D_dump_cmm txt (ppr g)