NCG: New code layout algorithm.

Summary:
This patch implements a new code layout algorithm.
It has been tested for x86 and is disabled on other platforms.

Performance varies slightly be CPU/Machine but in general seems to be better
by around 2%.
Nofib shows only small differences of about +/- ~0.5% overall depending on
flags/machine performance in other benchmarks improved significantly.

Other benchmarks includes at least the benchmarks of: aeson, vector, megaparsec, attoparsec,
containers, text and xeno.

While the magnitude of gains differed three different CPUs where tested with
all getting faster although to differing degrees. I tested: Sandy Bridge(Xeon), Haswell,
Skylake

* Library benchmark results summarized:
  * containers: ~1.5% faster
  * aeson: ~2% faster
  * megaparsec: ~2-5% faster
  * xml library benchmarks: 0.2%-1.1% faster
  * vector-benchmarks: 1-4% faster
  * text: 5.5% faster

On average GHC compile times go down, as GHC compiled with the new layout
is faster than the overhead introduced by using the new layout algorithm,

Things this patch does:

* Move code responsilbe for block layout in it's own module.
* Move the NcgImpl Class into the NCGMonad module.
* Extract a control flow graph from the input cmm.
* Update this cfg to keep it in sync with changes during
  asm codegen. This has been tested on x64 but should work on x86.
  Other platforms still use the old codelayout.
* Assign weights to the edges in the CFG based on type and limited static
  analysis which are then used for block layout.
* Once we have the final code layout eliminate some redundant jumps.

  In particular turn a sequences of:
      jne .foo
      jmp .bar
    foo:
  into
      je bar
    foo:
      ..

Test Plan: ci

Reviewers: bgamari, jmct, jrtc27, simonmar, simonpj, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: RyanGlScott, trommler, jmct, carter, thomie, rwbarton

GHC Trac Issues: #15124

Differential Revision: https://phabricator.haskell.org/D4726

5 files changed, 49 insertions, 6 deletions

diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index 70e53d2325..1441ecaa0f 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -2,7 +2,7 @@ module CmmMachOp
     ( MachOp(..)
     , pprMachOp, isCommutableMachOp, isAssociativeMachOp
     , isComparisonMachOp, maybeIntComparison, machOpResultType
-    , machOpArgReps, maybeInvertComparison
+    , machOpArgReps, maybeInvertComparison, isFloatComparison
 
     -- MachOp builders
     , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
@@ -322,6 +322,17 @@ maybeIntComparison mop =
     MO_U_Lt w  -> Just w
     _ -> Nothing
 
+isFloatComparison :: MachOp -> Bool
+isFloatComparison mop =
+  case mop of
+    MO_F_Eq {} -> True
+    MO_F_Ne {} -> True
+    MO_F_Ge {} -> True
+    MO_F_Le {} -> True
+    MO_F_Gt {} -> True
+    MO_F_Lt {} -> True
+    _other     -> False
+
 -- -----------------------------------------------------------------------------
 -- Inverting conditions
 
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 286b1e306c..7ecfa468a2 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -7,6 +7,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 
 -- CmmNode type for representation using Hoopl graphs.
 
@@ -16,7 +18,7 @@ module CmmNode (
      ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
      CmmReturnInfo(..),
      mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
-     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors,
+     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,
 
      -- * Tick scopes
      CmmTickScope(..), isTickSubScope, combineTickScopes,
@@ -37,6 +39,7 @@ import qualified Unique as U
 
 import Hoopl.Block
 import Hoopl.Graph
+import Hoopl.Collections
 import Hoopl.Label
 import Data.Maybe
 import Data.List (tails,sortBy)
@@ -569,6 +572,24 @@ mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
 mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)
 mapSuccessors _ n = n
 
+mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
+                     -> (CmmNode O C, [a])
+mapCollectSuccessors f (CmmBranch bid)
+  = let (bid', acc) = f bid in (CmmBranch bid', [acc])
+mapCollectSuccessors f (CmmCondBranch p y n l)
+  = let (bidt, acct) = f y
+        (bidf, accf) = f n
+    in  (CmmCondBranch p bidt bidf l, [accf, acct])
+mapCollectSuccessors f (CmmSwitch e ids)
+  = let lbls = switchTargetsToList ids :: [Label]
+        lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)
+    in ( CmmSwitch e
+          (mapSwitchTargets
+            (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)
+          , map snd (mapElems lblMap)
+        )
+mapCollectSuccessors _ n = (n, [])
+
 -- -----------------------------------------------------------------------------
 
 -- | Tickish in Cmm context (annotations only)
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 77598a4b09..8c4f21452a 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -156,7 +156,6 @@ cpsTop hsc_env proc =
                     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
diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs
index f8bdfda3d1..d7f53a0bad 100644
--- a/compiler/cmm/Hoopl/Collections.hs
+++ b/compiler/cmm/Hoopl/Collections.hs
@@ -35,6 +35,7 @@ class IsSet set where
   setDifference :: set -> set -> set
   setIntersection :: set -> set -> set
   setIsSubsetOf :: set -> set -> Bool
+  setFilter :: (ElemOf set -> Bool) -> set -> set
 
   setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
   setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
@@ -69,6 +70,7 @@ class IsMap map where
   mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
   mapDelete :: KeyOf map -> map a -> map a
   mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
+  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a
 
   mapUnion :: map a -> map a -> map a
   mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
@@ -81,7 +83,10 @@ class IsMap map where
   mapFoldl :: (b -> a -> b) -> b -> map a -> b
   mapFoldr :: (a -> b -> b) -> b -> map a -> b
   mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
+  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m
   mapFilter :: (a -> Bool) -> map a -> map a
+  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a
+
 
   mapElems :: map a -> [a]
   mapKeys :: map a -> [KeyOf map]
@@ -104,7 +109,7 @@ mapUnions maps = foldl1' mapUnion maps
 -- Basic instances
 -----------------------------------------------------------------------------
 
-newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)
 
 instance IsSet UniqueSet where
   type ElemOf UniqueSet = Int
@@ -122,6 +127,7 @@ instance IsSet UniqueSet where
   setDifference (US x) (US y) = US (S.difference x y)
   setIntersection (US x) (US y) = US (S.intersection x y)
   setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
+  setFilter f (US s) = US (S.filter f s)
 
   setFoldl k z (US s) = S.foldl' k z s
   setFoldr k z (US s) = S.foldr k z s
@@ -147,6 +153,7 @@ instance IsMap UniqueMap where
   mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
   mapDelete k (UM m) = UM (M.delete k m)
   mapAlter f k (UM m) = UM (M.alter f k m)
+  mapAdjust f k (UM m) = UM (M.adjust f k m)
 
   mapUnion (UM x) (UM y) = UM (M.union x y)
   mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
@@ -159,7 +166,9 @@ instance IsMap UniqueMap where
   mapFoldl k z (UM m) = M.foldl' k z m
   mapFoldr k z (UM m) = M.foldr k z m
   mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
+  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
   mapFilter f (UM m) = UM (M.filter f m)
+  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
 
   mapElems (UM m) = M.elems m
   mapKeys (UM m) = M.keys m
diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs
index 7fddbf4c3f..2e75d97244 100644
--- a/compiler/cmm/Hoopl/Label.hs
+++ b/compiler/cmm/Hoopl/Label.hs
@@ -46,7 +46,7 @@ instance Outputable Label where
 -----------------------------------------------------------------------------
 -- LabelSet
 
-newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)
 
 instance IsSet LabelSet where
   type ElemOf LabelSet = Label
@@ -64,7 +64,7 @@ instance IsSet LabelSet where
   setDifference (LS x) (LS y) = LS (setDifference x y)
   setIntersection (LS x) (LS y) = LS (setIntersection x y)
   setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
-
+  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)
   setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
   setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
 
@@ -92,6 +92,7 @@ instance IsMap LabelMap where
   mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
   mapDelete (Label k) (LM m) = LM (mapDelete k m)
   mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
+  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)
 
   mapUnion (LM x) (LM y) = LM (mapUnion x y)
   mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
@@ -105,7 +106,9 @@ instance IsMap LabelMap where
   mapFoldr k z (LM m) = mapFoldr k z m
   mapFoldlWithKey k z (LM m) =
       mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
+  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
   mapFilter f (LM m) = LM (mapFilter f m)
+  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
 
   mapElems (LM m) = mapElems m
   mapKeys (LM m) = map mkHooplLabel (mapKeys m)