[commit: ghc] wip/T13861: WIP: implement lumping of same results for may constructors (b05558e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T13861
Link       : http://ghc.haskell.org/trac/ghc/changeset/b05558e4eb151243f9d280c4f17f9e2364b4aa9c/ghc

>---------------------------------------------------------------

commit b05558e4eb151243f9d280c4f17f9e2364b4aa9c
Author: Gabor Greif <ggreif at gmail.com>
Date:   Sat Dec 30 01:02:09 2017 +0100

    WIP: implement lumping of same results for may constructors


>---------------------------------------------------------------

b05558e4eb151243f9d280c4f17f9e2364b4aa9c
 compiler/codeGen/StgCmmClosure.hs |  2 +-
 compiler/simplStg/StgCse.hs       | 19 +++++++++++++------
 2 files changed, 14 insertions(+), 7 deletions(-)

diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 6566672..c7e6e2d 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -631,7 +631,7 @@ getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
   = SlowCall -- might be a function
 
-getCallMethod _ name id (LFUnknown False) 0 _v_args cg_loc _self_loop_info
+getCallMethod _ name id (LFUnknown False) 0 _v_args _cg_loc _self_loop_info
   | occNameString (nameOccName name) == "wild" -- TODO: make this robust
   = ReturnIt -- seems to come from case, must be (tagged) WHNF already
 
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index 6643454..ded1761 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -95,7 +95,8 @@ import Name (NamedThing (..), mkFCallName)
 import Unique (mkUniqueGrimily, getKey, getUnique)
 import TyCon (tyConFamilySize)
 
-import Data.List (partition)
+import Data.List (partition, sortBy, groupBy)
+import Data.Function (on)
 
 --------------
 -- The Trie --
@@ -422,11 +423,17 @@ mkStgCase scrut bndr ty alts | all isBndr alts = scrut
     -- see Note [Lumping alternatives together]
     grouped (def@(DEFAULT, _, _) : alts)
       | isBndr def
-      , (binds@(_:_),rest) <- partition isBndr alts
-      = pprTrace "mkStgCase" (ppr alts) $ Just (def:rest)
-    grouped alts | (binds@(_:_:_),rest) <- partition isBndr alts
-                 = pprTrace "mkStgCase#" (ppr alts) $ Just ((DEFAULT, [], StgApp bndr []) : rest)
-    -- TODO: common constr applications: partition, sort, group
+      , ((_:_),rest) <- partition isBndr alts
+      = Just (def:rest)
+    grouped alts | ((_:_:_),rest) <- partition isBndr alts
+                 = Just ((DEFAULT, [], StgApp bndr []) : rest)
+    grouped ((DEFAULT, _, _) : _) = Nothing
+    grouped alts
+      | (cons@(_:_:_),rest) <- partition (\case (_,_,StgConApp _ [] [])->True; _->False) alts
+      , let itsCon (_,_,StgConApp c [] []) = c
+            gcons = groupBy ((==) `on` itsCon) cons
+      , (((_,_,res):_:_):others) <- sortBy (comparing $ Down . length) gcons
+      = pprTrace "mkStgCase##" (ppr others) $ Just ((DEFAULT, [], res) : concat others ++ rest)
     grouped _ = Nothing
 
 -- Utilities