[commit: ghc] wip/T13861: WIP: optimise literals (bd6163c)

[git at git.haskell.org]

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

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

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

commit bd6163c85b8d64e8dcd75f3d7bf3b62450d96640
Author: Gabor Greif <ggreif at gmail.com>
Date:   Mon Jan 1 19:08:26 2018 +0100

    WIP: optimise literals


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

bd6163c85b8d64e8dcd75f3d7bf3b62450d96640
 compiler/simplStg/StgCse.hs | 26 ++++++++++++++++++--------
 1 file changed, 18 insertions(+), 8 deletions(-)

diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index bf8f4fc..2e1c4b2 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -412,29 +412,39 @@ stgCseRhs env bndr (StgRhsClosure ccs info occs upd args body)
 
 mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
 mkStgCase scrut bndr ty alts | all isBndr alts = scrut
-                             | Just alts' <- grouped alts = StgCase scrut bndr ty alts'
-                             | otherwise       = StgCase scrut bndr ty alts
+                             | Just alts' <- lump alts = StgCase scrut bndr ty alts'
+                             | otherwise = StgCase scrut bndr ty alts
 
   where
     -- see Note [All alternatives are the binder]
     isBndr (_, _, StgApp f []) = f == bndr
     isBndr _                   = False
     -- see Note [Lumping alternatives together]
-    grouped (def@(DEFAULT, _, _) : alts)
+    lump (def@(DEFAULT, _, _) : alts)
       | isBndr def
       , ((_:_),rest) <- partition isBndr alts
       = Just (def:rest)
-    grouped ((DEFAULT, _, _) : _) = Nothing
-    grouped alts | ((_:_:_),rest) <- partition isBndr alts
+    lump ((DEFAULT, _, _):_) = Nothing
+    lump alts
+      | (lits@(_:_:_),rest) <- partition
+                (\case (_,_,StgLit l) -> True; _ -> False) alts
+      , let itsLit (_,_,StgLit l) = l
+            itsLit _ = pprPanic "mkStgCase" (text "not StgLit")
+            glits = groupBy ((==) `on` itsLit) lits
+      , sglits@(((_,_,res):_:_):others) <- sortBy (comparing $ Down . length) glits
+      , let opt = Just ((DEFAULT, [], res) : concat others ++ rest)
+      = pprTrace "mkStgCase LIT" (ppr alts <+> text " --------> " <+> ppr opt) opt
+    lump alts | ((_:_:_),rest) <- partition isBndr alts
                  = Just ((DEFAULT, [], StgApp bndr []) : rest)
-    grouped alts
-      | (cons@(_:_:_),rest) <- partition (\case (_,_,StgConApp _ [] [])->True; _->False) alts
+    lump alts
+      | (cons@(_:_:_),rest) <- partition
+                (\case (_,_,StgConApp _ [] []) -> True; _ -> False) alts
       , let itsCon (_,_,StgConApp c [] []) = c
             itsCon _ = pprPanic "mkStgCase" (text "not StgConApp")
             gcons = groupBy ((==) `on` itsCon) cons
       , (((_,_,res):_:_):others) <- sortBy (comparing $ Down . length) gcons
       = Just ((DEFAULT, [], res) : concat others ++ rest)
-    grouped _ = Nothing
+    lump _ = Nothing
 
 -- Utilities