[commit: ghc] master: Optimise (case tagToEnum# x of ..) as in Trac #8317 (62c4058)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/62c405854afbeb6dabdaf5c737a2d7f625a2b3cb/ghc

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

commit 62c405854afbeb6dabdaf5c737a2d7f625a2b3cb
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Sep 17 22:02:27 2013 +0100

    Optimise (case tagToEnum# x of ..) as in Trac #8317
    
    See Note [Optimising tagToEnum#] in Simplify


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

62c405854afbeb6dabdaf5c737a2d7f625a2b3cb
 compiler/simplCore/Simplify.lhs |   43 ++++++++++++++++++++++++++++++++++++---
 1 file changed, 40 insertions(+), 3 deletions(-)

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index d006f7f..a88d943 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -14,7 +14,7 @@ import Type hiding      ( substTy, extendTvSubst, substTyVar )
 import SimplEnv
 import SimplUtils
 import FamInstEnv       ( FamInstEnv )
-import Literal          ( litIsLifted )
+import Literal          ( litIsLifted, mkMachInt )
 import Id
 import MkId             ( seqId, realWorldPrimId )
 import MkCore           ( mkImpossibleExpr, castBottomExpr )
@@ -23,7 +23,9 @@ import Name             ( mkSystemVarName, isExternalName )
 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType )
-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness, isMarkedStrict )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness 
+                        , isMarkedStrict, dataConTyCon, dataConTag, fIRST_TAG )
+import TyCon            ( isEnumerationTyCon )
 import CoreMonad        ( Tick(..), SimplifierMode(..) )
 import CoreSyn
 import Demand           ( StrictSig(..), dmdTypeDepth )
@@ -31,11 +33,13 @@ import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreUnfold
 import CoreUtils
 import CoreArity
+import PrimOp           ( tagToEnumKey )
 import Rules            ( lookupRule, getRules )
-import TysPrim          ( realWorldStatePrimTy )
+import TysPrim          ( realWorldStatePrimTy, intPrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
 import Maybes           ( orElse )
+import Unique           ( hasKey )
 import Control.Monad
 import Data.List        ( mapAccumL )
 import Outputable
@@ -1561,6 +1565,27 @@ tryRules :: SimplEnv -> [CoreRule]
 tryRules env rules fn args call_cont
   | null rules
   = return Nothing
+
+  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]
+  , [_type_arg, val_arg] <- args
+  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont
+  , isDeadBinder bndr
+  = do { dflags <- getDynFlags
+       ; let enum_to_tag :: CoreAlt -> CoreAlt
+                -- Takes   K -> e  into   tagK# -> e
+                -- where tagK# is the tag of constructor K
+             enum_to_tag (DataAlt con, [], rhs) 
+               = ASSERT( isEnumerationTyCon (dataConTyCon con) )
+                (LitAlt tag, [], rhs)
+              where
+                tag = mkMachInt dflags (toInteger (dataConTag con - fIRST_TAG))
+             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)
+ 
+             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts
+             new_bndr = setIdType bndr intPrimTy   
+                 -- The binder is dead, but should have the right type
+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } 
+
   | otherwise
   = do { dflags <- getDynFlags
        ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env) 
@@ -1594,6 +1619,18 @@ tryRules env rules fn args call_cont
       sep [text hdr, nest 4 details]
 \end{code}
 
+Note [Optimising tagToEnum#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to transform
+   case tagToEnum# x of   ==>    case x of
+     True -> e1                    DEFAULT -> e1
+     False -> e2                   0#      -> e2
+
+thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT
+alternative we retain it (remember it comes first).  If not the case must
+be exhaustive, and we reflect that in the transformed version by adding
+a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.
+
 Note [Rules for recursive functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 You might think that we shouldn't apply rules for a loop breaker: