Scrutinee Constant Folding

This patch introduces new rules to perform constant folding through
case-expressions.

E.g.,
```
case t -# 10# of _ {  ===> case t of _ {
         5#      -> e1              15#     -> e1
         8#      -> e2              18#     -> e2
         DEFAULT -> e               DEFAULT -> e
```

The initial motivation is that it allows "Merge Nested Cases"
optimization to kick in and to further simplify the code
(see Trac #12877).

Currently we recognize the following operations for Word# and Int#: Add,
Sub, Xor, Not and Negate (for Int# only).

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie

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

GHC Trac Issues: #12877

1 files changed, 56 insertions, 1 deletions

diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 8868047005..e98fd9f6a3 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -15,7 +15,12 @@ ToDo:
 {-# LANGUAGE CPP, RankNTypes #-}
 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
 
-module PrelRules ( primOpRules, builtinRules ) where
+module PrelRules
+   ( primOpRules
+   , builtinRules
+   , caseRules
+   )
+where
 
 #include "HsVersions.h"
 #include "../includes/MachDeps.h"
@@ -1385,3 +1390,53 @@ match_smallIntegerTo primOp _ _ _ [App (Var x) y]
   | idName x == smallIntegerName
   = Just $ App (Var (mkPrimOpId primOp)) y
 match_smallIntegerTo _ _ _ _ _ = Nothing
+
+
+
+--------------------------------------------------------
+-- Constant folding through case-expressions
+--
+-- cf Scrutinee Constant Folding in simplCore/SimplUtils
+--------------------------------------------------------
+
+-- | Match the scrutinee of a case and potentially return a new scrutinee and a
+-- function to apply to each literal alternative.
+caseRules :: CoreExpr -> Maybe (CoreExpr, Integer -> Integer)
+caseRules scrut = case scrut of
+
+   -- v `op` x#
+   App (App (Var f) v) (Lit l)
+      | Just op <- isPrimOpId_maybe f
+      , Just x  <- isLitValue_maybe l ->
+      case op of
+         WordAddOp -> Just (v, \y -> y-x      )
+         IntAddOp  -> Just (v, \y -> y-x      )
+         WordSubOp -> Just (v, \y -> y+x      )
+         IntSubOp  -> Just (v, \y -> y+x      )
+         XorOp     -> Just (v, \y -> y `xor` x)
+         XorIOp    -> Just (v, \y -> y `xor` x)
+         _         -> Nothing
+
+   -- x# `op` v
+   App (App (Var f) (Lit l)) v
+      | Just op <- isPrimOpId_maybe f
+      , Just x  <- isLitValue_maybe l ->
+      case op of
+         WordAddOp -> Just (v, \y -> y-x      )
+         IntAddOp  -> Just (v, \y -> y-x      )
+         WordSubOp -> Just (v, \y -> x-y      )
+         IntSubOp  -> Just (v, \y -> x-y      )
+         XorOp     -> Just (v, \y -> y `xor` x)
+         XorIOp    -> Just (v, \y -> y `xor` x)
+         _         -> Nothing
+
+   -- op v
+   App (Var f) v
+      | Just op <- isPrimOpId_maybe f ->
+      case op of
+         NotOp     -> Just (v, \y -> complement y)
+         NotIOp    -> Just (v, \y -> complement y)
+         IntNegOp  -> Just (v, \y -> negate y    )
+         _         -> Nothing
+
+   _ -> Nothing