diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-03-08 10:26:47 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2017-03-08 10:26:47 +0000 |
commit | e49f3154a5ceb1894414f4635579aeb3aa84054f (patch) | |
tree | b8158d4d8121a1000e7566ef99f6bf1a809c17a1 | |
parent | cdfa1ec6a24e882a0a78400497766e0c147e7c59 (diff) | |
download | haskell-e49f3154a5ceb1894414f4635579aeb3aa84054f.tar.gz |
Re-engineer caseRules to add tagToEnum/dataToTag
See Note [Scrutinee Constant Folding] in SimplUtils
* Add cases for tagToEnum and dataToTag. This is the main new
bit. It allows the simplifier to remove the pervasive uses
of case tagToEnum (a > b) of
False -> e1
True -> e2
and replace it by the simpler
case a > b of
DEFAULT -> e1
1# -> e2
See Note [caseRules for tagToEnum]
and Note [caseRules for dataToTag] in PrelRules.
* This required some changes to the API of caseRules, and hence
to code in SimplUtils. See Note [Scrutinee Constant Folding]
in SimplUtils.
* Avoid duplication of work in the (unusual) case of
case BIG + 3# of b
DEFAULT -> e1
6# -> e2
Previously we got
case BIG of
DEFAULT -> let b = BIG + 3# in e1
3# -> let b = 6# in e2
Now we get
case BIG of b#
DEFAULT -> let b = b' + 3# in e1
3# -> let b = 6# in e2
* Avoid duplicated code in caseRules
A knock-on refactoring:
* Move Note [Word/Int underflow/overflow] to Literal, as
documentation to accompany mkMachIntWrap etc; and get
rid of PrelRuls.intResult' in favour of mkMachIntWrap
-rw-r--r-- | compiler/basicTypes/Literal.hs | 21 | ||||
-rw-r--r-- | compiler/coreSyn/CoreSyn.hs | 2 | ||||
-rw-r--r-- | compiler/prelude/PrelRules.hs | 231 | ||||
-rw-r--r-- | compiler/simplCore/SimplUtils.hs | 177 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T3772.stdout | 10 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T4930.stderr | 30 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/spec-inline.stderr | 152 |
7 files changed, 391 insertions, 232 deletions
diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index cc53b47833..f14606e8cf 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -222,6 +222,24 @@ instance Ord Literal where ~~~~~~~~~~~~ -} +{- Note [Word/Int underflow/overflow] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and +unsigned integral types): "All arithmetic is performed modulo 2^n, where n is +the number of bits in the type." + +GHC stores Word# and Int# constant values as Integer. Core optimizations such +as constant folding must ensure that the Integer value remains in the valid +target Word/Int range (see #13172). The following functions are used to +ensure this. + +Note that we *don't* warn the user about overflow. It's not done at runtime +either, and compilation of completely harmless things like + ((124076834 :: Word32) + (2147483647 :: Word32)) +doesn't yield a warning. Instead we simply squash the value into the *target* +Int/Word range. +-} + -- | Creates a 'Literal' of type @Int#@ mkMachInt :: DynFlags -> Integer -> Literal mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x ) @@ -229,6 +247,7 @@ mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x ) -- | Creates a 'Literal' of type @Int#@. -- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] mkMachIntWrap :: DynFlags -> Integer -> Literal mkMachIntWrap dflags i = MachInt $ case platformWordSize (targetPlatform dflags) of @@ -243,6 +262,7 @@ mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x ) -- | Creates a 'Literal' of type @Word#@. -- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] mkMachWordWrap :: DynFlags -> Integer -> Literal mkMachWordWrap dflags i = MachWord $ case platformWordSize (targetPlatform dflags) of @@ -336,6 +356,7 @@ isLitValue_maybe _ = Nothing -- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For -- fixed-size integral literals, the result will be wrapped in -- accordance with the semantics of the target type. +-- See Note [Word/Int underflow/overflow] mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal mapLitValue _ f (MachChar c) = mkMachChar (fchar c) where fchar = chr . fromInteger . f . toInteger . ord diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 31fbd12979..aafbdace2b 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -1642,6 +1642,8 @@ ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT cmpAltCon :: AltCon -> AltCon -> Ordering -- ^ Compares 'AltCon's within a single list of alternatives +-- DEFAULT comes out smallest, so that sorting by AltCon +-- puts alternatives in the order required by #case_invariants# cmpAltCon DEFAULT DEFAULT = EQ cmpAltCon DEFAULT _ = LT diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 2b1bf76571..fcd0adbef5 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -35,8 +35,9 @@ import CoreSubst ( exprIsLiteral_maybe ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn import TysPrim -import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe ) -import DataCon ( dataConTag, dataConTyCon, dataConWorkId ) +import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon + , unwrapNewTyCon_maybe, tyConDataCons ) +import DataCon ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId ) import CoreUtils ( cheapEqExpr, exprIsHNF ) import CoreUnfold ( exprIsConApp_maybe ) import Type @@ -538,51 +539,15 @@ isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64) isMaxBound _ _ = False - --- Note [Word/Int underflow/overflow] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and --- unsigned integral types): "All arithmetic is performed modulo 2^n, where n is --- the number of bits in the type." --- --- GHC stores Word# and Int# constant values as Integer. Core optimizations such --- as constant folding must ensure that the Integer value remains in the valid --- target Word/Int range (see #13172). The following functions are used to --- ensure this. --- --- Note that we *don't* warn the user about overflow. It's not done at runtime --- either, and compilation of completely harmless things like --- ((124076834 :: Word32) + (2147483647 :: Word32)) --- doesn't yield a warning. Instead we simply squash the value into the *target* --- Int/Word range. - --- | Ensure the given Integer is in the target Int range -intResult' :: DynFlags -> Integer -> Integer -intResult' dflags result = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (fromInteger result :: Int32) - 8 -> toInteger (fromInteger result :: Int64) - w -> panic ("intResult: Unknown platformWordSize: " ++ show w) - --- | Ensure the given Integer is in the target Word range -wordResult' :: DynFlags -> Integer -> Integer -wordResult' dflags result = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (fromInteger result :: Word32) - 8 -> toInteger (fromInteger result :: Word64) - w -> panic ("wordResult: Unknown platformWordSize: " ++ show w) - -- | Create an Int literal expression while ensuring the given Integer is in the -- target Int range intResult :: DynFlags -> Integer -> Maybe CoreExpr -intResult dflags result = Just (mkIntVal dflags (intResult' dflags result)) +intResult dflags result = Just (Lit (mkMachIntWrap dflags result)) -- | Create a Word literal expression while ensuring the given Integer is in the -- target Word range wordResult :: DynFlags -> Integer -> Maybe CoreExpr -wordResult dflags result = Just (mkWordVal dflags (wordResult' dflags result)) - - - +wordResult dflags result = Just (Lit (mkMachWordWrap dflags result)) inversePrimOp :: PrimOp -> RuleM CoreExpr inversePrimOp primop = do @@ -872,8 +837,6 @@ gtVal = Var gtDataConId mkIntVal :: DynFlags -> Integer -> Expr CoreBndr mkIntVal dflags i = Lit (mkMachInt dflags i) -mkWordVal :: DynFlags -> Integer -> Expr CoreBndr -mkWordVal dflags w = Lit (mkMachWord dflags w) mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f)) mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr @@ -921,7 +884,7 @@ tagToEnumRule = do case splitTyConApp_maybe ty of Just (tycon, tc_args) | isEnumerationTyCon tycon -> do let tag = fromInteger i - correct_tag dc = (dataConTag dc - fIRST_TAG) == tag + correct_tag dc = (dataConTagZ dc) == tag (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) ASSERT(null rest) return () return $ mkTyApps (Var (dataConWorkId dc)) tc_args @@ -951,7 +914,7 @@ dataToTagRule = a `mplus` b in_scope <- getInScopeEnv (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () - return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG)) + return $ mkIntVal dflags (toInteger (dataConTagZ dc)) {- ************************************************************************ @@ -1183,7 +1146,7 @@ match_append_lit _ _ _ _ = Nothing --------------------------------------------------- -- The rule is this: --- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 match_eq_string :: RuleFun match_eq_string _ id_unf _ @@ -1432,46 +1395,150 @@ match_smallIntegerTo _ _ _ _ _ = Nothing -- | Match the scrutinee of a case and potentially return a new scrutinee and a -- function to apply to each literal alternative. -caseRules :: DynFlags -> CoreExpr -> Maybe (CoreExpr, Integer -> Integer) -caseRules dflags scrut = case scrut of - - -- We need to call wordResult' and intResult' to ensure that the literal - -- alternatives remain in Word/Int target ranges (cf Note [Word/Int - -- underflow/overflow] and #13172). - - -- 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 -> wordResult' dflags $ y-x ) - IntAddOp -> Just (v, \y -> intResult' dflags $ y-x ) - WordSubOp -> Just (v, \y -> wordResult' dflags $ y+x ) - IntSubOp -> Just (v, \y -> intResult' dflags $ y+x ) - XorOp -> Just (v, \y -> wordResult' dflags $ y `xor` x) - XorIOp -> Just (v, \y -> intResult' dflags $ y `xor` x) +caseRules :: DynFlags + -> CoreExpr -- Scrutinee + -> Maybe ( CoreExpr -- New scrutinee + , AltCon -> AltCon -- How to fix up the alt pattern + , Id -> CoreExpr) -- How to reconstruct the original scrutinee + -- from the new case-binder +-- e.g case e of b { +-- ...; +-- con bs -> rhs; +-- ... } +-- ==> +-- case e' of b' { +-- ...; +-- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; +-- ... } + +caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x# + | Just op <- isPrimOpId_maybe f + , Just x <- isLitValue_maybe l + , Just adjust_lit <- adjustDyadicRight op x + = Just (v, tx_lit_con dflags adjust_lit + , \v -> (App (App (Var f) (Var v)) (Lit l))) + +caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v + | Just op <- isPrimOpId_maybe f + , Just x <- isLitValue_maybe l + , Just adjust_lit <- adjustDyadicLeft x op + = Just (v, tx_lit_con dflags adjust_lit + , \v -> (App (App (Var f) (Var v)) (Lit l))) + + +caseRules dflags (App (Var f) v ) -- op v + | Just op <- isPrimOpId_maybe f + , Just adjust_lit <- adjustUnary op + = Just (v, tx_lit_con dflags adjust_lit + , \v -> App (Var f) (Var v)) + +-- See Note [caseRules for tagToEnum] +caseRules dflags (App (App (Var f) type_arg) v) + | Just TagToEnumOp <- isPrimOpId_maybe f + = Just (v, tx_con_tte dflags + , \v -> (App (App (Var f) type_arg) (Var v))) + +-- See Note [caseRules for dataToTag] +caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x + | Just DataToTagOp <- isPrimOpId_maybe f + = Just (v, tx_con_dtt ty + , \v -> App (App (Var f) (Type ty)) (Var v)) + +caseRules _ _ = Nothing + + +tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> AltCon +tx_lit_con _ _ DEFAULT = DEFAULT +tx_lit_con dflags adjust (LitAlt l) = LitAlt (mapLitValue dflags adjust l) +tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) + -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the + -- literal alternatives remain in Word/Int target ranges + -- (See Note [Word/Int underflow/overflow] in Literal and #13172). + +adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) +-- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x +adjustDyadicRight op lit + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> y+lit ) + IntSubOp -> Just (\y -> y+lit ) + XorOp -> Just (\y -> y `xor` lit) + XorIOp -> Just (\y -> y `xor` lit) _ -> 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 -> wordResult' dflags $ y-x ) - IntAddOp -> Just (v, \y -> intResult' dflags $ y-x ) - WordSubOp -> Just (v, \y -> wordResult' dflags $ x-y ) - IntSubOp -> Just (v, \y -> intResult' dflags $ x-y ) - XorOp -> Just (v, \y -> wordResult' dflags $ y `xor` x) - XorIOp -> Just (v, \y -> intResult' dflags $ y `xor` x) +adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer) +-- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x +adjustDyadicLeft lit op + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> lit-y ) + IntSubOp -> Just (\y -> lit-y ) + XorOp -> Just (\y -> y `xor` lit) + XorIOp -> Just (\y -> y `xor` lit) _ -> Nothing - -- op v - App (Var f) v - | Just op <- isPrimOpId_maybe f -> - case op of - NotOp -> Just (v, \y -> wordResult' dflags $ complement y) - NotIOp -> Just (v, \y -> intResult' dflags $ complement y) - IntNegOp -> Just (v, \y -> intResult' dflags $ negate y ) + +adjustUnary :: PrimOp -> Maybe (Integer -> Integer) +-- Given (op x) return a function 'f' s.t. f (op x) = x +adjustUnary op + = case op of + NotOp -> Just (\y -> complement y) + NotIOp -> Just (\y -> complement y) + IntNegOp -> Just (\y -> negate y ) _ -> Nothing - _ -> Nothing +tx_con_tte :: DynFlags -> AltCon -> AltCon +tx_con_tte _ DEFAULT = DEFAULT +tx_con_tte dflags (DataAlt dc) + | tag == 0 = DEFAULT -- See Note [caseRules for tagToEnum] + | otherwise = LitAlt (mkMachInt dflags (toInteger tag)) + where + tag = dataConTagZ dc +tx_con_tte _ alt = pprPanic "caseRules" (ppr alt) + +tx_con_dtt :: Type -> AltCon -> AltCon +tx_con_dtt _ DEFAULT = DEFAULT +tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i)) +tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) + +get_con :: Type -> ConTagZ -> DataCon +get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag + +{- Note [caseRules for tagToEnum] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to transform + case tagToEnum x of + False -> e1 + True -> e2 +into + case x of + 0# -> e1 + 1# -> e1 + +This rule elimiantes a lot of boilerplate. For + if (x>y) then e1 else e2 +we generate + case tagToEnum (x ># y) of + False -> e2 + True -> e1 +and it is nice to then get rid of the tagToEnum. + +NB: in SimplUtils, where we invoke caseRules, + we convert that 0# to DEFAULT + +Note [caseRules for dataToTag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to transform + case dataToTag x of + DEFAULT -> e1 + 1# -> e2 +into + case x of + DEFAULT -> e1 + (:) _ _ -> e2 + +Note the need for some wildcard binders in +the 'cons' case. +-}
\ No newline at end of file diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 0fe262b2c7..824e6786b5 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -53,7 +53,7 @@ import Demand import SimplMonad import Type hiding( substTy ) import Coercion hiding( substCo ) -import DataCon ( dataConWorkId ) +import DataCon ( dataConWorkId, isNullaryRepDataCon ) import VarEnv import VarSet import BasicTypes @@ -62,7 +62,7 @@ import MonadUtils import Outputable import Pair import PrelRules -import Literal +import FastString ( fsLit ) import Control.Monad ( when ) import Data.List ( sortBy ) @@ -1762,8 +1762,12 @@ prepareAlts scrut case_bndr' alts mkCase tries these things -1. Merge Nested Cases +* Note [Nerge nested cases] +* Note [Elimiante identity case] +* Note [Scrutinee constant folding] +Note [Merge Nested Cases] +~~~~~~~~~~~~~~~~~~~~~~~~~ case e of b { ==> case e of b { p1 -> rhs1 p1 -> rhs1 ... ... @@ -1775,21 +1779,21 @@ mkCase tries these things _ -> rhsd } - which merges two cases in one case when -- the default alternative of - the outer case scrutises the same variable as the outer case. This - transformation is called Case Merging. It avoids that the same - variable is scrutinised multiple times. - -2. Eliminate Identity Case +which merges two cases in one case when -- the default alternative of +the outer case scrutises the same variable as the outer case. This +transformation is called Case Merging. It avoids that the same +variable is scrutinised multiple times. +Note [Eliminate Identity Case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case e of ===> e True -> True; False -> False - and similar friends. - -3. Scrutinee Constant Folding +and similar friends. +Note [Scrutinee Constant Folding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case x op# k# of _ { ===> case x of _ { a1# -> e1 (a1# inv_op# k#) -> e1 a2# -> e2 (a2# inv_op# k#) -> e2 @@ -1798,32 +1802,66 @@ mkCase tries these things where (x op# k#) inv_op# k# == x - And similarly for commuted arguments and for some unary operations. - - The purpose of this transformation is not only to avoid an arithmetic - operation at runtime but to allow other transformations to apply in cascade. - - Example with the "Merge Nested Cases" optimization (from #12877): - - main = case t of t0 - 0## -> ... - DEFAULT -> case t0 `minusWord#` 1## of t1 - 0## -> ... - DEFAUT -> case t1 `minusWord#` 1## of t2 - 0## -> ... - DEFAULT -> case t2 `minusWord#` 1## of _ - 0## -> ... - DEFAULT -> ... - - becomes: - - main = case t of _ - 0## -> ... - 1## -> ... - 2## -> ... - 3## -> ... - DEFAULT -> ... - +And similarly for commuted arguments and for some unary operations. + +The purpose of this transformation is not only to avoid an arithmetic +operation at runtime but to allow other transformations to apply in cascade. + +Example with the "Merge Nested Cases" optimization (from #12877): + + main = case t of t0 + 0## -> ... + DEFAULT -> case t0 `minusWord#` 1## of t1 + 0## -> ... + DEFAUT -> case t1 `minusWord#` 1## of t2 + 0## -> ... + DEFAULT -> case t2 `minusWord#` 1## of _ + 0## -> ... + DEFAULT -> ... + + becomes: + + main = case t of _ + 0## -> ... + 1## -> ... + 2## -> ... + 3## -> ... + DEFAULT -> ... + +There are some wrinkles + +* Do not apply caseRules if there is just a single DEFAULT alternative + case e +# 3# of b { DEFAULT -> rhs } + If we applied the transformation here we would (stupidly) get + case a of b' { DEFAULT -> let b = e +# 3# in rhs } + and now the process may repeat, because that let will really + be a case. + +* The type of the scrutinee might change. E.g. + case tagToEnum (x :: Int#) of (b::Bool) + False -> e1 + True -> e2 + ==> + case x of (b'::Int#) + DEFAULT -> e1 + 1# -> e2 + +* The case binder may be used in the right hand sides, so we need + to make a local binding for it, if it is alive. e.g. + case e +# 10# of b + DEFAULT -> blah...b... + 44# -> blah2...b... + ===> + case e of b' + DEFAULT -> let b = b' +# 10# in blah...b... + 34# -> let b = 44# in blah2...b... + + Note that in the non-DEFAULT cases we know what to bind 'b' to, + whereas in the DEFAULT case we must reconstruct the original value. + But NB: we use b'; we do not duplicate 'e'. + +* In dataToTag we might need to make up some fake binders; + see Note [caseRules for dataToTag] in PrelRules -} mkCase, mkCase1, mkCase2, mkCase3 @@ -1924,9 +1962,18 @@ mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts -------------------------------------------------- mkCase2 dflags scrut bndr alts_ty alts - | gopt Opt_CaseFolding dflags - , Just (scrut',f) <- caseRules dflags scrut - = mkCase3 dflags scrut' bndr alts_ty (new_alts f) + | -- See Note [Scrutinee Constant Folding] + case alts of -- Not if there is just a DEFAULT alterantive + [(DEFAULT,_,_)] -> False + _ -> True + , gopt Opt_CaseFolding dflags + , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut + = do { bndr' <- newId (fsLit "lwild") (exprType scrut') + ; alts' <- mapM (tx_alt tx_con mk_orig bndr') alts + ; mkCase3 dflags scrut' bndr' alts_ty $ + add_default (re_sort alts') + } + | otherwise = mkCase3 dflags scrut bndr alts_ty alts where @@ -1942,19 +1989,41 @@ mkCase2 dflags scrut bndr alts_ty alts -- 10 -> let y = 20 in e1 -- DEFAULT -> let y = y' + 10 in e2 -- - wrap_rhs l rhs - | isDeadBinder bndr = rhs - | otherwise = Let (NonRec bndr l) rhs - - -- We need to re-sort the alternatives to preserve the #case_invariants# - new_alts f = sortBy cmpAlt (map (mapAlt f) alts) - - mapAlt f alt@(c,bs,e) = case c of - DEFAULT -> (c, bs, wrap_rhs scrut e) - LitAlt l - | isLitValue l -> (LitAlt (mapLitValue dflags f l), - bs, wrap_rhs (Lit l) e) - _ -> pprPanic "Unexpected alternative (mkCase2)" (ppr alt) + -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, + -- to construct an expression equivalent to the original one, for use + -- in the DEFAULT case + + tx_alt tx_con mk_orig new_bndr (con, bs, rhs) + | DataAlt dc <- con', not (isNullaryRepDataCon dc) + = -- For non-nullary data cons we must invent some fake binders + -- See Note [caseRules for dataToTag] in PrelRules + do { us <- getUniquesM + ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc + (tyConAppArgs (idType new_bndr)) + ; return (con', ex_tvs ++ arg_ids, rhs') } + | otherwise + = return (con', [], rhs') + where + con' = tx_con con + + rhs' | isDeadBinder bndr = rhs + | otherwise = bindNonRec bndr orig_val rhs + + orig_val = case con of + DEFAULT -> mk_orig new_bndr + LitAlt l -> Lit l + DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs + + + re_sort :: [CoreAlt] -> [CoreAlt] -- Re-sort the alternatives to + re_sort alts = sortBy cmpAlt alts -- preserve the #case_invariants# + + add_default :: [CoreAlt] -> [CoreAlt] + -- TagToEnum may change a boolean True/False set of alternatives + -- to LitAlt 0#/1# alterantives. But literal alternatives always + -- have a DEFAULT (I think). So add it. + add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts + add_default alts = alts -------------------------------------------------- -- Catch-all diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index 44aee7b69e..a4ab97da38 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 44, types: 19, coercions: 0, joins: 0/0} + = {terms: 43, types: 18, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T3772.$trModule4 :: GHC.Prim.Addr# @@ -59,14 +59,14 @@ $wxs } end Rec } --- RHS size: {terms: 11, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> () [GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>] T3772.$wfoo = \ (ww :: GHC.Prim.Int#) -> - case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0# ww) of { - False -> GHC.Tuple.(); - True -> $wxs ww + case GHC.Prim.<# 0# ww of { + __DEFAULT -> GHC.Tuple.(); + 1# -> $wxs ww } -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 9db97a5e1f..4d569485b3 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 44, types: 17, coercions: 0, joins: 0/0} + = {terms: 43, types: 16, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T4930.$trModule4 :: GHC.Prim.Addr# @@ -44,20 +44,20 @@ T4930.$trModule :: GHC.Types.Module Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] -T4930.$trModule = - GHC.Types.Module T4930.$trModule3 T4930.$trModule1 +T4930.$trModule + = GHC.Types.Module T4930.$trModule3 T4930.$trModule1 Rec { --- RHS size: {terms: 18, types: 4, coercions: 0, joins: 0/0} +-- RHS size: {terms: 17, types: 3, coercions: 0, joins: 0/0} T4930.$wfoo [InlPrag=[0], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# [GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>] -T4930.$wfoo = - \ (ww :: GHC.Prim.Int#) -> - case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# ww 5#) of { - False -> GHC.Prim.+# ww 5#; - True -> case T4930.$wfoo ww of { __DEFAULT -> GHC.Prim.+# ww 5# } - } +T4930.$wfoo + = \ (ww :: GHC.Prim.Int#) -> + case GHC.Prim.<# ww 5# of { + __DEFAULT -> GHC.Prim.+# ww 5#; + 1# -> case T4930.$wfoo ww of { __DEFAULT -> GHC.Prim.+# ww 5# } + } end Rec } -- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0} @@ -73,11 +73,11 @@ foo [InlPrag=INLINE[0]] :: Int -> Int case w of { GHC.Types.I# ww1 [Occ=Once] -> case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } }}] -foo = - \ (w :: Int) -> - case w of { GHC.Types.I# ww1 -> - case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } - } +foo + = \ (w :: Int) -> + case w of { GHC.Types.I# ww1 -> + case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } + } diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index dda28c8926..53b315dc9c 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 178, types: 68, coercions: 0, joins: 0/2} + = {terms: 172, types: 62, coercions: 0, joins: 0/2} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Roman.$trModule4 :: GHC.Prim.Addr# @@ -44,8 +44,8 @@ Roman.$trModule :: GHC.Types.Module Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] -Roman.$trModule = - GHC.Types.Module Roman.$trModule3 Roman.$trModule1 +Roman.$trModule + = GHC.Types.Module Roman.$trModule3 Roman.$trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} lvl :: GHC.Prim.Addr# @@ -55,83 +55,83 @@ lvl = "spec-inline.hs:(19,5)-(29,25)|function go"# -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} Roman.foo3 :: Int [GblId, Str=x] -Roman.foo3 = - Control.Exception.Base.patError @ 'GHC.Types.LiftedRep @ Int lvl +Roman.foo3 + = Control.Exception.Base.patError @ 'GHC.Types.LiftedRep @ Int lvl Rec { --- RHS size: {terms: 55, types: 9, coercions: 0, joins: 0/1} +-- RHS size: {terms: 52, types: 6, coercions: 0, joins: 0/1} Roman.foo_$s$wgo [Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId, Arity=2, Caf=NoCafRefs, Str=<S,U><S,U>] -Roman.foo_$s$wgo = - \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) -> - let { - m :: GHC.Prim.Int# - [LclId] - m = - GHC.Prim.+# - (GHC.Prim.+# - (GHC.Prim.+# - (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# sc sc) sc) sc) sc) - sc) - sc } in - case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# sc1 0#) of { - False -> - case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc1 100#) of { - False -> - case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc1 500#) of { - False -> Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# sc1 1#); - True -> Roman.foo_$s$wgo m (GHC.Prim.-# sc1 3#) - }; - True -> Roman.foo_$s$wgo sc (GHC.Prim.-# sc1 2#) - }; - True -> 0# - } +Roman.foo_$s$wgo + = \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) -> + let { + m :: GHC.Prim.Int# + [LclId] + m = GHC.Prim.+# + (GHC.Prim.+# + (GHC.Prim.+# + (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# sc sc) sc) sc) sc) + sc) + sc } in + case GHC.Prim.<=# sc1 0# of { + __DEFAULT -> + case GHC.Prim.<# sc1 100# of { + __DEFAULT -> + case GHC.Prim.<# sc1 500# of { + __DEFAULT -> + Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# sc1 1#); + 1# -> Roman.foo_$s$wgo m (GHC.Prim.-# sc1 3#) + }; + 1# -> Roman.foo_$s$wgo sc (GHC.Prim.-# sc1 2#) + }; + 1# -> 0# + } end Rec } --- RHS size: {terms: 74, types: 22, coercions: 0, joins: 0/1} +-- RHS size: {terms: 71, types: 19, coercions: 0, joins: 0/1} Roman.$wgo [InlPrag=[0]] :: Maybe Int -> Maybe Int -> GHC.Prim.Int# [GblId, Arity=2, Str=<S,1*U><S,1*U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 30] 256 0}] -Roman.$wgo = - \ (w :: Maybe Int) (w1 :: Maybe Int) -> - case w1 of { - Nothing -> case Roman.foo3 of wild1 { }; - Just x -> - case x of { GHC.Types.I# ipv -> - let { - m :: GHC.Prim.Int# - [LclId] - m = - GHC.Prim.+# - (GHC.Prim.+# - (GHC.Prim.+# - (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# ipv ipv) ipv) ipv) ipv) - ipv) - ipv } in - case w of { - Nothing -> Roman.foo_$s$wgo m 10#; - Just n -> - case n of { GHC.Types.I# x2 -> - case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# x2 0#) of { - False -> - case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 100#) of { - False -> - case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 500#) of { - False -> Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# x2 1#); - True -> Roman.foo_$s$wgo m (GHC.Prim.-# x2 3#) - }; - True -> Roman.foo_$s$wgo ipv (GHC.Prim.-# x2 2#) - }; - True -> 0# - } - } - } - } - } + WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 30] 253 0}] +Roman.$wgo + = \ (w :: Maybe Int) (w1 :: Maybe Int) -> + case w1 of { + Nothing -> case Roman.foo3 of wild1 { }; + Just x -> + case x of { GHC.Types.I# ipv -> + let { + m :: GHC.Prim.Int# + [LclId] + m = GHC.Prim.+# + (GHC.Prim.+# + (GHC.Prim.+# + (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# ipv ipv) ipv) ipv) ipv) + ipv) + ipv } in + case w of { + Nothing -> Roman.foo_$s$wgo m 10#; + Just n -> + case n of { GHC.Types.I# x2 -> + case GHC.Prim.<=# x2 0# of { + __DEFAULT -> + case GHC.Prim.<# x2 100# of { + __DEFAULT -> + case GHC.Prim.<# x2 500# of { + __DEFAULT -> + Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# x2 1#); + 1# -> Roman.foo_$s$wgo m (GHC.Prim.-# x2 3#) + }; + 1# -> Roman.foo_$s$wgo ipv (GHC.Prim.-# x2 2#) + }; + 1# -> 0# + } + } + } + } + } -- RHS size: {terms: 9, types: 5, coercions: 0, joins: 0/0} Roman.foo_go [InlPrag=INLINE[0]] :: Maybe Int -> Maybe Int -> Int @@ -143,9 +143,9 @@ Roman.foo_go [InlPrag=INLINE[0]] :: Maybe Int -> Maybe Int -> Int Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once] :: Maybe Int) (w1 [Occ=Once] :: Maybe Int) -> case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }}] -Roman.foo_go = - \ (w :: Maybe Int) (w1 :: Maybe Int) -> - case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww } +Roman.foo_go + = \ (w :: Maybe Int) (w1 :: Maybe Int) -> + case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Roman.foo2 :: Int @@ -178,11 +178,11 @@ foo :: Int -> Int case n of n1 { GHC.Types.I# _ [Occ=Dead] -> Roman.foo_go (GHC.Base.Just @ Int n1) Roman.foo1 }}] -foo = - \ (n :: Int) -> - case n of { GHC.Types.I# ipv -> - case Roman.foo_$s$wgo 6# ipv of ww { __DEFAULT -> GHC.Types.I# ww } - } +foo + = \ (n :: Int) -> + case n of { GHC.Types.I# ipv -> + case Roman.foo_$s$wgo 6# ipv of ww { __DEFAULT -> GHC.Types.I# ww } + } ------ Local rules for imported ids -------- |