Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: aa5dfe67 by Sylvain Henry at 2026-03-26T03:48:56-04:00 Check that shift values are valid In GHC's codebase in non-DEBUG builds we silently substitute shiftL/R with unsafeShiftL/R for performance reasons. However we were not checking that the shift value was valid for unsafeShiftL/R, leading to wrong computations, but only in non-DEBUG builds. This patch adds the necessary checks and reports an error when a wrong shift value is passed. - - - - - c8a7b588 by Sylvain Henry at 2026-03-26T03:48:56-04:00 Implement basic value range analysis (#25718) Perform basic value range analysis to try to determine at compile time the result of the application of some comparison primops (ltWord#, etc.). This subsumes the built-in rewrite rules used previously to check if one of the comparison argument was a bound (e.g. (x :: Word8) <= 255 is always True). Our analysis is more powerful and handles type conversions: e.g. word8ToWord x <= 255 is now detected as always True too. We also use value range analysis to filter unreachable alternatives in case-expressions. To support this, we had to allow case-expressions for primitive types to not have a DEFAULT alternative (as was assumed before and checked in Core lint). - - - - - 24 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - + compiler/GHC/Core/Opt/Range.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Prelude/Basic.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/ghc.cabal.in - libraries/ghc-internal/src/GHC/Internal/Char.hs - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/simplCore/should_compile/T19166.hs - + testsuite/tests/simplCore/should_compile/T19166.stderr - + testsuite/tests/simplCore/should_compile/T25718.hs - + testsuite/tests/simplCore/should_compile/T25718.stderr - + testsuite/tests/simplCore/should_compile/T25718a.hs - + testsuite/tests/simplCore/should_compile/T25718a.stderr - + testsuite/tests/simplCore/should_compile/T25718b.hs - + testsuite/tests/simplCore/should_compile/T25718b.stderr - + testsuite/tests/simplCore/should_compile/T25718c.hs - + testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-32 - + testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64 - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -4,6 +4,7 @@ -} {-# LANGUAGE NoPolyKinds #-} +{-# LANGUAGE LambdaCase #-} -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core ( @@ -36,7 +37,7 @@ module GHC.Core ( mkBinds, - isId, cmpAltCon, cmpAlt, ltAlt, + isId, cmpAltCon, cmpAlt, ltAlt, altsLevity, CaseLevity(..), -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfBinds, rhssOfAlts, @@ -60,7 +61,7 @@ module GHC.Core ( unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, -- ** Predicates and deconstruction on 'Unfolding' - expandUnfolding_maybe, + expandUnfolding_maybe, expandUnfolding_always, maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, @@ -1787,6 +1788,11 @@ expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs }) = Just rhs expandUnfolding_maybe _ = Nothing +-- Expand an unfolding, ignoring if it is expandable or not +expandUnfolding_always :: Unfolding -> Maybe CoreExpr +expandUnfolding_always (CoreUnfolding { uf_tmpl = rhs }) = Just rhs +expandUnfolding_always _ = Nothing + isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src isCompulsoryUnfolding _ = False @@ -2006,6 +2012,25 @@ cmpAltCon (LitAlt _) DEFAULT = GT cmpAltCon con1 con2 = pprPanic "cmpAltCon" (ppr con1 $$ ppr con2) +data CaseLevity + = CaseUnlifted + | CaseLifted + deriving (Eq) + +altCon :: Alt a -> AltCon +altCon (Alt con _ _) = con + +-- | Try to determine the levity of a case-expression (unlifted, lifted) from +-- its alternatives +altsLevity :: [Alt a] -> Maybe CaseLevity +altsLevity = alts_levity . fmap altCon + where + alts_levity = \case + [] -> Nothing + (DEFAULT:xs) -> alts_levity xs + (LitAlt {}:_) -> Just CaseUnlifted + (DataAlt {}:_) -> Just CaseLifted + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1631,16 +1631,21 @@ checkCaseAlts e scrut scrut_ty alts ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) -- See GHC.Core Note [Case expression invariants] item (3) - -- For types Int#, Word# with an infinite (well, large!) number of - -- possible values, there should usually be a DEFAULT case - -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to - -- have *no* case alternatives. - -- In effect, this is a kind of partial test. I suppose it's possible - -- that we might *know* that 'x' was 1 or 2, in which case - -- case x of { 1 -> e1; 2 -> e2 } - -- would be fine. - ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) - (nonExhaustiveAltsMsg e) + -- Historical note: we used to check that primitive types with a large + -- number of possible values (e.g. Int#, Word#...) either had: + -- * no alternatives (see Note [Empty case alternatives] in GHC.Core) + -- * a DEFAULT alternative + -- The rationale was that we can't reasonably enumerate all possible + -- alternatives hence the need for a DEFAULT alternative. Moreover + -- HsToCore introduces a DEFAULT alternative to raise a pattern-match + -- error so there must be at least one. + -- + -- However, since we implemented range analysis (see Note [Value range + -- analysis] in GHC.Core.Range), we're filtering unreachable + -- alternatives, even the DEFAULT one, so this check is no longer valid. + -- E.g. DEFAULT alternative is now removed in: + -- case x .&. 1 of { DEFAULT -> ..; 0 -> ..; 1 -> ..} + -- even if we're matching an Int#. -- Check that the scrutinee is not a floating-point type -- if there are any literal alternatives @@ -1666,7 +1671,7 @@ checkCaseAlts e scrut scrut_ty alts _otherwise -> return () } where - (con_alts, maybe_deflt) = findDefault alts + (con_alts, _maybe_deflt) = findDefault alts -- Check that successive alternatives have strictly increasing tags increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest @@ -1678,10 +1683,6 @@ checkCaseAlts e scrut scrut_ty alts is_lit_alt (Alt (LitAlt _) _ _) = True is_lit_alt _ = False - is_infinite_ty = case tyConAppTyCon_maybe scrut_ty of - Nothing -> False - Just tycon -> isPrimTyCon tycon - lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv lintAltExpr expr ann_ty = do { (actual_ty, ue) <- lintCoreExpr expr @@ -3773,10 +3774,6 @@ mkNonDefltMsg e mkNonIncreasingAltsMsg e = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) -nonExhaustiveAltsMsg :: CoreExpr -> SDoc -nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) - mkBadConMsg :: TyCon -> DataCon -> SDoc mkBadConMsg tycon datacon = vcat [ ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Core import GHC.Core.Make import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) -import GHC.Core.Utils ( cheapEqExpr, exprIsHNF +import GHC.Core.Utils ( cheapEqExpr, exprIsHNF, isDefaultAlt , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Multiplicity import GHC.Core.Rules.Config @@ -54,6 +54,7 @@ import GHC.Core.TyCon ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon ) import GHC.Core.Map.Expr ( eqCoreExpr ) +import GHC.Core.Opt.Range import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey ) import GHC.Builtin.PrimOps.Ids (primOpId) @@ -76,6 +77,7 @@ import Data.Functor (($>)) import qualified Data.ByteString as BS import Data.Ratio import Data.Word +import Data.Char (ord) import Data.Maybe (fromMaybe, fromJust) {- @@ -777,60 +779,60 @@ primOpRules nm = \case -- Relational operators, ordering - Int8GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - Int8GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - Int8LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - Int8LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - Int16GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - Int16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - Int16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - Int16LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - Int32GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - Int32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - Int32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - Int32LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - Int64GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - Int64GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - Int64LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - Int64LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - IntGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - IntGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - IntLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - IntLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - Word8GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - Word8GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - Word8LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - Word8LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - Word16GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - Word16LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - Word32GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - Word32LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - Word64GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - Word64GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - Word64LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - Word64LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - WordGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - WordLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] - - CharGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] - CharGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] - CharLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] - CharLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + Int8GtOp -> mkRelOpRule nm (>) [ boundsCmp (const rangeInt8) Gt ] + Int8GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeInt8) Ge ] + Int8LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeInt8) Le ] + Int8LtOp -> mkRelOpRule nm (<) [ boundsCmp (const rangeInt8) Lt ] + + Int16GtOp -> mkRelOpRule nm (>) [ boundsCmp (const rangeInt16) Gt ] + Int16GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeInt16) Ge ] + Int16LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeInt16) Le ] + Int16LtOp -> mkRelOpRule nm (<) [ boundsCmp (const rangeInt16) Lt ] + + Int32GtOp -> mkRelOpRule nm (>) [ boundsCmp (const rangeInt32) Gt ] + Int32GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeInt32) Ge ] + Int32LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeInt32) Le ] + Int32LtOp -> mkRelOpRule nm (<) [ boundsCmp (const rangeInt32) Lt ] + + Int64GtOp -> mkRelOpRule nm (>) [ boundsCmp (const rangeInt64) Gt ] + Int64GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeInt64) Ge ] + Int64LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeInt64) Le ] + Int64LtOp -> mkRelOpRule nm (<) [ boundsCmp (const rangeInt64) Lt ] + + IntGtOp -> mkRelOpRule nm (>) [ boundsCmp rangeInt Gt ] + IntGeOp -> mkRelOpRule nm (>=) [ boundsCmp rangeInt Ge ] + IntLeOp -> mkRelOpRule nm (<=) [ boundsCmp rangeInt Le ] + IntLtOp -> mkRelOpRule nm (<) [ boundsCmp rangeInt Lt ] + + Word8GtOp -> mkRelOpRule nm (>) [ boundsCmp (const rangeWord8) Gt ] + Word8GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeWord8) Ge ] + Word8LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeWord8) Le ] + Word8LtOp -> mkRelOpRule nm (<) [ boundsCmp (const rangeWord8) Lt ] + + Word16GtOp -> mkRelOpRule nm (>) [ boundsCmp (const rangeWord16) Gt ] + Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeWord16) Ge ] + Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeWord16) Le ] + Word16LtOp -> mkRelOpRule nm (<) [ boundsCmp (const rangeWord16) Lt ] + + Word32GtOp -> mkRelOpRule nm (>) [ boundsCmp (const rangeWord32) Gt ] + Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeWord32) Ge ] + Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeWord32) Le ] + Word32LtOp -> mkRelOpRule nm (<) [ boundsCmp (const rangeWord32) Lt ] + + Word64GtOp -> mkRelOpRule nm (>) [ boundsCmp (const rangeWord64) Gt ] + Word64GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeWord64) Ge ] + Word64LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeWord64) Le ] + Word64LtOp -> mkRelOpRule nm (<) [ boundsCmp (const rangeWord64) Lt ] + + WordGtOp -> mkRelOpRule nm (>) [ boundsCmp rangeWord Gt ] + WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp rangeWord Ge ] + WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp rangeWord Le ] + WordLtOp -> mkRelOpRule nm (<) [ boundsCmp rangeWord Lt ] + + CharGtOp -> mkRelOpRule nm (>) [ boundsCmp rangeChar Gt ] + CharGeOp -> mkRelOpRule nm (>=) [ boundsCmp rangeChar Ge ] + CharLeOp -> mkRelOpRule nm (<=) [ boundsCmp rangeChar Le ] + CharLtOp -> mkRelOpRule nm (<) [ boundsCmp rangeChar Lt ] FloatGtOp -> mkFloatingRelOpRule nm (>) FloatGeOp -> mkFloatingRelOpRule nm (>=) @@ -1401,27 +1403,27 @@ litEq is_eq = msum | otherwise = trueValInt platform --- | Check if there is comparison with minBound or maxBound, that is --- always true or false. For instance, an Int cannot be smaller than its --- minBound, so we can replace such comparison with False. -boundsCmp :: Comparison -> RuleM CoreExpr -boundsCmp op = do +-- | Perform value range analysis to check if can determine the result +-- of a comparison statically. For instance, a Word8 converted into a Word is +-- always smaller than 256. +boundsCmp :: (Platform -> Range) -> Comparison -> RuleM CoreExpr +boundsCmp mk_range op = do platform <- getPlatform [a, b] <- getArgs - liftMaybe $ mkRuleFn platform op a b - -data Comparison = Gt | Ge | Lt | Le - -mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr -mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform -mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt platform -mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt platform -mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform -mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt platform -mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform -mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform -mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt platform -mkRuleFn _ _ _ _ = Nothing + let ty_range = mk_range platform + liftMaybe $ value_range_cmp platform op ty_range a b + +-- | See Note [Value range analysis] in GHC.Core.Opt.Range +value_range_cmp :: Platform -> Comparison -> Range -> CoreExpr -> CoreExpr -> Maybe CoreExpr +value_range_cmp platform cmp ty_range x y = + let rx = ty_range `rangeIntersect` valueRange platform x + ry = ty_range `rangeIntersect` valueRange platform y + to_bool = \case + Nothing -> Nothing + Just True -> Just (trueValInt platform) + Just False -> Just (falseValInt platform) + res = rangeCmp cmp rx ry + in to_bool res -- | Create an Int literal expression while ensuring the given Integer is in the -- target Int range @@ -3188,8 +3190,8 @@ is_binop op e = case e of is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr) is_op op e = case e of - App (OpVal op') x | op == op' -> Just x - _ -> Nothing + App (PrimOpVar op') x | op == op' -> Just x + _ -> Nothing is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (CoreArg, CoreArg) is_add num_ops e = is_binop (numAdd num_ops) e @@ -3249,12 +3251,12 @@ is_expr_mul num_ops x e = if -- | Match the application of a binary primop pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr -pattern BinOpApp x op y = OpVal op `App` x `App` y +pattern BinOpApp x op y = PrimOpVar op `App` x `App` y -- | Match a primop -pattern OpVal:: PrimOp -> Arg CoreBndr -pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where - OpVal op = Var (primOpId op) +pattern PrimOpVar:: PrimOp -> Arg CoreBndr +pattern PrimOpVar op <- Var (isPrimOpId_maybe -> Just op) where + PrimOpVar op = Var (primOpId op) -- | Match a literal pattern L :: Integer -> Arg CoreBndr @@ -3478,11 +3480,12 @@ caseRules _ _ = Nothing -- -- It's important that occurrence info are present, hence the use of In* types. caseRules2 - :: InExpr -- ^ Scutinee - -> InId -- ^ Case-binder - -> [InAlt] -- ^ Alternatives in standard (increasing) order + :: Platform -- ^ Target platform + -> InExpr -- ^ Scrutinee + -> InId -- ^ Case-binder + -> [InAlt] -- ^ Alternatives in standard (increasing) order -> Maybe (InExpr, InId, [InAlt]) -caseRules2 scrut bndr alts +caseRules2 platform scrut bndr alts -- case quotRem# x y of -- (# q, _ #) -> body @@ -3507,6 +3510,46 @@ caseRules2 scrut bndr alts | dead_r -> Just $ (BinOpApp x quot y, q, [Alt DEFAULT [] body]) | otherwise -> Nothing + -- filter alternatives that are not in the scrutinee's inferred range + -- See (VRA1) in Note [Value range analysis] in GHC.Core.Opt.Range + | Just CaseUnlifted <- altsLevity alts + , range <- valueRange platform scrut + , range /= noRange + = let + -- filters alternatives that aren't in range + alt_in_range = \case + Alt DEFAULT _ _ -> True + Alt (LitAlt (LitNumber _ n)) _ _ -> n `inRange` range + Alt (LitAlt (LitChar c)) _ _ -> fromIntegral (ord c) `inRange` range + Alt (LitAlt LitNullAddr) _ _ -> 0 `inRange` range + Alt _ _ _ -> True -- defaults to True to be safe + + rebuild_alts alt (b,n,alts') + -- `n` is the number of remaining alternatives, hence alternatives which + -- are in range. If there are as many alternatives in range as the range + -- size, it means we can remove the DEFAULT one (it is dead code). + -- + -- Note that this works as written because we use `foldr` below and the + -- DEFAULT alternative is always at the head of the list of alternatives + -- when it is present (invariant). + | isDefaultAlt alt + , Just sz <- rangeSize range + , n == sz + = (True,n,alts') + + -- filter alternatives that aren't in range + | not (alt_in_range alt) + = (True,n,alts') + + | otherwise + = (b,n+1,alt:alts') + + (alts_changed,_nalts,final_alts) = foldr rebuild_alts (False,0,[]) alts + + in case alts_changed of + True -> Just (scrut,bndr,final_alts) + False -> Nothing + | otherwise = Nothing @@ -3678,3 +3721,5 @@ an alternative that is unreachable. You may wonder how this can happen: check out #15436. -} + + ===================================== compiler/GHC/Core/Opt/Range.hs ===================================== @@ -0,0 +1,451 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CPP #-} + +-- | Range analysis +-- +-- See Note [Value range analysis] +module GHC.Core.Opt.Range + ( Comparison(..) + , Range(..) + , noRange + , valueRange + , rangeIntersect + , rangeCastFrom + , inRange + , rangeSize + , rangeCmp + , rangeLe + , rangeGe + , rangeLt + , rangeGt + , rangeOf + , rangeWord + , rangeWord8 + , rangeWord16 + , rangeWord32 + , rangeWord64 + , rangeChar + , rangeInt + , rangeInt8 + , rangeInt16 + , rangeInt32 + , rangeInt64 + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Core +import GHC.Builtin.PrimOps ( PrimOp(..) ) +import GHC.Builtin.PrimOps.Ids (primOpId) +import GHC.Types.Literal +import GHC.Types.Id +#if defined(DEBUG) +import GHC.Utils.Outputable +import GHC.Utils.Panic +#endif + +import Data.Word +import Data.Int +import Data.Char (ord) +import Data.Maybe + +{- +Note [Value range analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To perform some constant-folding optimisations, it is sometimes enough to know +the range (interval) of what an expression will evaluate to. For example, +consider the following expression: + + word8ToWord x < 256 + +Even without knowing the value of 'x', we know that: + + - x is in range [0,255] because it is of type Word8 + - `word8ToWord x` is in range [0,255] despite being of type Word + - `word8ToWord x < 256` is always `True` + +When a comparison primop is applied to two expressions (e.g. `ltWord# e1 e2`), +we infer the ranges of `e1` and `e2` and use them to try to statically compute +the result of the comparison (see `rangeCmp` function in this module). + +Value range analysis consists in inferring the range of a CoreExpr. + valueRange :: Platform -> CoreExpr -> Range +is the workhorse function doing this analysis in this module. It traverses a +CoreExpr recursively to infer a range as precise as possible. It takes into +account: + + - literals: a literal 'n' implies a range [n,n] + - narrowing primops (e.g. Narrow8IntOp) + - conversion primops (e.g. WordToIntOp) + - addition and subtraction primops (e.g. Word32AddOp) + - logical AND primops + - variable unfoldings: for example, consider: + case word8ToWord# x of y { ... case ltWord# y 256## { ... }} + the value range analysis is triggered in a rewrite-rule for ltWord# on + both `y` and `256##`. `y` is a variable so the analysis looks into its + unfolding (here `word8ToWord# x`) to infer its range. It's obviously only + possible when the variable has an unfolding. This unfolding, however, isn't + required to be expandable as we're not expanding/inlining the unfolding, + just computing its value range. + +VRA1: Filtering unreachable alternatives based on range analysis +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + + case word8ToWord# x of + 123456# -> ... + ... + +By applying value range analysis to the scrutinee, GHC infers that the 123456# +alternative is unreachable because it's out of the range [0,255] of the +scrutinee, hence it will never match. + +This filtering is done in GHC.Core.Opt.ConstantFold.caseRules2. See also T25718b + + +Limitation 1: no disjoint ranges +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The current implementation doesn't support disjoint ranges hence it can't +precisely track some ranges. In these cases it falls back to a wider range. +For example: range analysis for `word8ToInt8 x` where x is in [100,130] would +need a disjoint range union to be represented as [100,127] U [-128,-126] because +of the overflow (130 > 127). See `rangeCastFrom` function in this module for the +implementation. + +Similarly, additions and subtractions may overflow/underflow. In these cases, we +would also need disjoint ranges to represent the resulting range. For example, +`x+1` where (x :: Word8) and x is in [100,255] would require a disjoint range +union: [0,0] U [101,255]. +We use `rangeCastFrom` to handle these cases too: e.g. `x+1` (as described +above) is first computed to be in range [101,256] (ignoring the Word8 type), but +this range isn't in Word8's range [0,255], so conservatively we assume a range +[0,255] for `x+1` expression + +Limitation 2: limited top-down range information in alternatives +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The value range analysis for a variable currently consists in applying the +analysis to the variable's unfolding (when it is available). This approach +doesn't return the most precise range possible in some cases. For example +consider: + + case x ># 0# of + 1# -> {- Here we should know that x's range is > 0 -} + 0# -> {- ... and here <= 0 -} + +In both alternatives `x`'s unfolding (if any) is the same, yet we should be able +to infer a different range for `x` as a consequence of the pattern matching on +the comparison operator application. + +Possible future work: we could imagine extending the unfolding information to +include range information. Then a top-down pass could compute and store more +precise range information in cases like this one. Implementing this should +change the output of the T25718a test. + +-} + +data Comparison = Gt | Ge | Lt | Le deriving (Show) + + +-- | A range (minBound,maxBound) +-- +-- Bounds may not be known. +data Range + = MkRange {-# UNPACK #-} !(Maybe Integer) -- ^ Lower bound: Nothing means unbounded below + {-# UNPACK #-} !(Maybe Integer) -- ^ Upper bound: Nothing means unbounded above + deriving (Eq,Show) + +pattern Range :: Maybe Integer -> Maybe Integer -> Range +pattern Range x y <- MkRange x y + where + Range x y = mkRange x y + +{-# COMPLETE Range #-} + +mkRange :: Maybe Integer -> Maybe Integer -> Range +mkRange = \cases +#if defined(DEBUG) + -- check that the bounds of the range are well ordered. + (Just x) (Just y) | x > y -> pprPanic "Invalid range" (ppr (x,y)) +#endif + x y -> MkRange x y + + +-- | Compute the intersection of two overlapping ranges. +-- +-- If the two ranges don't overlap, result is undefined. +rangeIntersect :: Range -> Range -> Range +rangeIntersect (Range mi1 ma1) (Range mi2 ma2) = Range mi ma + where + merge op = \cases + Nothing Nothing -> Nothing + Nothing v -> v + v Nothing -> v + (Just a) (Just b) -> Just (op a b) + mi = merge max mi1 mi2 + ma = merge min ma1 ma2 + +-- | Used for casts that share representation over a sub-range (e.g. [0,127] for +-- Word8# ([0,255]) and Int8# ([-128,127])) +-- +-- If from_range isn't fully included into to_range, then we return to_range. +-- That's because for now we don't have a way to track disjoined ranges. +-- E.g. if we wanted to cast [-1,10] (Int8) into [0,255] (Word8), we would +-- need to represent a range union: [0,10] U [255,255] (Word8) +-- +-- We also use this function to ensure that the result of an arithmetic +-- operation on ranges didn't overflow/underflow. +rangeCastFrom :: Range -> Range -> Range +rangeCastFrom to_range from_range = case from_range of + Range (Just mi) (Just ma) + | mi `inRange` to_range + , ma `inRange` to_range + -> from_range + _ -> to_range + +inRange :: Integer -> Range -> Bool +inRange x = \case + Range Nothing Nothing -> True + Range (Just mi) Nothing -> x >= mi + Range (Just mi) (Just ma) -> x >= mi && x <= ma + Range Nothing (Just ma) -> x <= ma + +rangeSize :: Range -> Maybe Integer +rangeSize = \case + Range (Just mi) (Just ma) -> Just (ma-mi+1) + _ -> Nothing + +-- | Addition of two ranges +rangeAdd :: Range -> Range -> Range +rangeAdd (Range mi1 ma1) (Range mi2 ma2) = Range (add mi1 mi2) (add ma1 ma2) + where + add = \cases + (Just v) (Just u) -> Just (v+u) + _ _ -> Nothing + +-- | Subtraction of two ranges +rangeSub :: Range -> Range -> Range +rangeSub (Range mi1 ma1) (Range mi2 ma2) = Range (sub mi1 ma2) (sub ma1 mi2) + where + sub = \cases + (Just v) (Just u) -> Just (v-u) + _ _ -> Nothing + +-- | Logical AND of two ranges at the given type +{-# NOINLINE rangeAnd #-} +rangeAnd :: forall a. (FiniteBits a, Bounded a, Integral a) => Range -> Range -> Range +rangeAnd (Range mi1' ma1') (Range mi2' ma2') = final_range + where + -- convert the Integer range bounds into the given type with FiniteBits + -- because we need to work on the actual representation, not on the Integer + -- value. We also take the minBound/maxBound when a bound is missing. + mi1, mi2, ma1, ma2 :: a + mi1 = fromMaybe minBound (fromInteger <$> mi1') + mi2 = fromMaybe minBound (fromInteger <$> mi2') + ma1 = fromMaybe maxBound (fromInteger <$> ma1') + ma2 = fromMaybe maxBound (fromInteger <$> ma2') + + -- we compute the minimal number of leading zeros for each range. + -- Then we take the maximum of both values: this is the number of leading + -- bits that will always be set to zero in the resulting range. + clz1 = min (countLeadingZeros mi1) (countLeadingZeros ma1) + clz2 = min (countLeadingZeros mi2) (countLeadingZeros ma2) + clzr = max clz1 clz2 + + -- we generate a mask for the bits that might be set to 1 in the resulting + -- range and apply it to every bound. It may reorder the bounds: e.g. + -- ([-1,1] :: Int8) .&. 0xF ==> [15,1] ==> [1,15] + -- so we have to be careful when we reconstruct the final range + mask :: a + mask = if + | clzr == finiteBitSize mi1 -> zeroBits + | clzr == 0 -> complement zeroBits + | otherwise -> (1 `unsafeShiftL` (finiteBitSize mi1 - clzr)) - 1 + -- we can't use: complement zeroBits `shiftR` clzr + -- because shiftR performs sign-extension for signed types + mk_final_bound x = toInteger (x .&. mask) + + fmi1 = mk_final_bound mi1 + fmi2 = mk_final_bound mi2 + fma1 = mk_final_bound ma1 + fma2 = mk_final_bound ma2 + fmi = fmi1 `min` fmi2 `min` fma1 `min` fma2 + fma = fmi1 `max` fmi2 `max` fma1 `max` fma2 + final_range = Range (Just fmi) (Just fma) + + +noRange :: Range +noRange = Range Nothing Nothing + +rangeOf :: forall a. (Bounded a, Integral a) => Range +rangeOf = Range (Just (toInteger (minBound :: a))) (Just (toInteger (maxBound :: a))) + +rangeWord8, rangeWord16, rangeWord32, rangeWord64 :: Range +rangeWord8 = rangeOf @Word8 +rangeWord16 = rangeOf @Word16 +rangeWord32 = rangeOf @Word32 +rangeWord64 = rangeOf @Word64 + +rangeInt8, rangeInt16, rangeInt32, rangeInt64 :: Range +rangeInt8 = rangeOf @Int8 +rangeInt16 = rangeOf @Int16 +rangeInt32 = rangeOf @Int32 +rangeInt64 = rangeOf @Int64 + +rangeWord, rangeInt, rangeChar :: Platform -> Range +rangeWord p = case platformWordSize p of + PW4 -> rangeWord32 + PW8 -> rangeWord64 +rangeInt p = case platformWordSize p of + PW4 -> rangeInt32 + PW8 -> rangeInt64 + +rangeChar = rangeInt -- a Char# is represented internally as an Int# + +-- | Compare two ranges +-- +-- See Note [Value range analysis] +rangeCmp :: Comparison -> Range -> Range -> Maybe Bool +rangeCmp cmp rx ry = case cmp of + Gt -> rx `rangeGt` ry + Ge -> rx `rangeGe` ry + Le -> rx `rangeLe` ry + Lt -> rx `rangeLt` ry + +rangeGt :: Range -> Range -> Maybe Bool +rangeGt = \cases + (Range (Just mi) _) (Range _ (Just ma)) | mi > ma -> Just True + (Range _ (Just ma)) (Range (Just mi) _) | ma <= mi -> Just False + _ _ -> Nothing + +rangeLt :: Range -> Range -> Maybe Bool +rangeLt = \cases + (Range _ (Just ma)) (Range (Just mi) _) | ma < mi -> Just True + (Range (Just mi) _) (Range _ (Just ma)) | mi >= ma -> Just False + _ _ -> Nothing + +rangeGe :: Range -> Range -> Maybe Bool +rangeGe = \cases + (Range (Just mi) _) (Range _ (Just ma)) | mi >= ma -> Just True + (Range _ (Just ma)) (Range (Just mi) _) | ma < mi -> Just False + _ _ -> Nothing + +rangeLe :: Range -> Range -> Maybe Bool +rangeLe = \cases + (Range _ (Just ma)) (Range (Just mi) _) | ma <= mi -> Just True + (Range (Just mi) _) (Range _ (Just ma)) | mi > ma -> Just False + _ _ -> Nothing + + +-- | Return the Integer range of an expression +valueRange :: Platform -> CoreExpr -> Range +valueRange platform = value_range 10 + where + -- we use some fuel value to avoid recursing infinitely + value_range :: Word -> CoreExpr -> Range + value_range fuel expr + | fuel == 0 = noRange + | otherwise = case expr of + Lit (LitNumber _ n) -> Range (Just n) (Just n) + Lit (LitChar c) -> let n = fromIntegral (ord c) in Range (Just n) (Just n) + Lit _ -> noRange + Var v + | Just ebody <- expandUnfolding_always (idUnfolding v) + -> value_range (fuel-1) ebody + | otherwise + -> noRange + PrimOpVar op `App` x -> + let sub_range = value_range (fuel-1) x + in case op of + Word8ToWordOp -> rangeWord8 `rangeIntersect` sub_range + Word16ToWordOp -> rangeWord16 `rangeIntersect` sub_range + Word32ToWordOp -> rangeWord32 `rangeIntersect` sub_range + Word64ToWordOp -> rangeWord platform `rangeIntersect` sub_range + WordToWord8Op -> rangeWord8 `rangeIntersect` sub_range + WordToWord16Op -> rangeWord16 `rangeIntersect` sub_range + WordToWord32Op -> rangeWord32 `rangeIntersect` sub_range + WordToWord64Op -> rangeWord platform `rangeIntersect` sub_range + + Word8ToInt8Op -> rangeInt8 `rangeCastFrom` (rangeWord8 `rangeIntersect` sub_range) + Word16ToInt16Op -> rangeInt16 `rangeCastFrom` (rangeWord16 `rangeIntersect` sub_range) + Word32ToInt32Op -> rangeInt32 `rangeCastFrom` (rangeWord32 `rangeIntersect` sub_range) + Word64ToInt64Op -> rangeInt64 `rangeCastFrom` (rangeWord64 `rangeIntersect` sub_range) + WordToIntOp -> rangeInt platform `rangeCastFrom` (rangeWord platform `rangeIntersect` sub_range) + + Int8ToWord8Op -> rangeWord8 `rangeCastFrom` (rangeInt8 `rangeIntersect` sub_range) + Int16ToWord16Op -> rangeWord16 `rangeCastFrom` (rangeInt16 `rangeIntersect` sub_range) + Int32ToWord32Op -> rangeWord32 `rangeCastFrom` (rangeInt32 `rangeIntersect` sub_range) + Int64ToWord64Op -> rangeWord64 `rangeCastFrom` (rangeInt64 `rangeIntersect` sub_range) + IntToWordOp -> rangeWord platform `rangeCastFrom` (rangeInt platform `rangeIntersect` sub_range) + + Narrow8IntOp -> rangeInt8 `rangeIntersect` sub_range + Narrow16IntOp -> rangeInt16 `rangeIntersect` sub_range + Narrow32IntOp -> rangeInt32 `rangeIntersect` sub_range + Narrow8WordOp -> rangeWord8 `rangeIntersect` sub_range + Narrow16WordOp -> rangeWord16 `rangeIntersect` sub_range + Narrow32WordOp -> rangeWord32 `rangeIntersect` sub_range + + OrdOp -> sub_range + ChrOp -> sub_range + + _ -> noRange + + PrimOpVar op `App` x `App` y -> + let range_x = value_range (fuel-1) x + range_y = value_range (fuel-1) y + in case op of + Word8AddOp -> rangeWord8 `rangeCastFrom` rangeAdd range_x range_y + Word16AddOp -> rangeWord16 `rangeCastFrom` rangeAdd range_x range_y + Word32AddOp -> rangeWord32 `rangeCastFrom` rangeAdd range_x range_y + Word64AddOp -> rangeWord64 `rangeCastFrom` rangeAdd range_x range_y + WordAddOp -> rangeWord platform `rangeCastFrom` rangeAdd range_x range_y + Int8AddOp -> rangeInt8 `rangeCastFrom` rangeAdd range_x range_y + Int16AddOp -> rangeInt16 `rangeCastFrom` rangeAdd range_x range_y + Int32AddOp -> rangeInt32 `rangeCastFrom` rangeAdd range_x range_y + Int64AddOp -> rangeInt64 `rangeCastFrom` rangeAdd range_x range_y + IntAddOp -> rangeInt platform `rangeCastFrom` rangeAdd range_x range_y + + Word8SubOp -> rangeWord8 `rangeCastFrom` rangeSub range_x range_y + Word16SubOp -> rangeWord16 `rangeCastFrom` rangeSub range_x range_y + Word32SubOp -> rangeWord32 `rangeCastFrom` rangeSub range_x range_y + Word64SubOp -> rangeWord64 `rangeCastFrom` rangeSub range_x range_y + WordSubOp -> rangeWord platform `rangeCastFrom` rangeSub range_x range_y + Int8SubOp -> rangeInt8 `rangeCastFrom` rangeSub range_x range_y + Int16SubOp -> rangeInt16 `rangeCastFrom` rangeSub range_x range_y + Int32SubOp -> rangeInt32 `rangeCastFrom` rangeSub range_x range_y + Int64SubOp -> rangeInt64 `rangeCastFrom` rangeSub range_x range_y + IntSubOp -> rangeInt platform `rangeCastFrom` rangeSub range_x range_y + + IntAndOp -> case platformWordSize platform of + PW4 -> rangeAnd @Int32 range_x range_y + PW8 -> rangeAnd @Int64 range_x range_y + WordAndOp -> case platformWordSize platform of + PW4 -> rangeAnd @Word32 range_x range_y + PW8 -> rangeAnd @Word64 range_x range_y + Word8AndOp -> rangeAnd @Word8 range_x range_y + Word16AndOp -> rangeAnd @Word16 range_x range_y + Word32AndOp -> rangeAnd @Word32 range_x range_y + Word64AndOp -> rangeAnd @Word64 range_x range_y + + -- TODO: shifts, or, clz, ctz, negate... + _ -> noRange + + App {} -> noRange + Lam {} -> noRange + Let {} -> noRange + Case {} -> noRange + Cast e _ -> value_range fuel e + Tick _ e -> value_range fuel e + Type {} -> noRange + Coercion {} -> noRange + +-- | Match a primop +pattern PrimOpVar:: PrimOp -> Arg CoreBndr +pattern PrimOpVar op <- Var (isPrimOpId_maybe -> Just op) where + PrimOpVar op = Var (primOpId op) + ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -3232,18 +3232,19 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont' Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + where + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + +rebuildCase env scrut case_bndr alts cont -------------------------------------------------- -- 3. Primop-related case-rules -------------------------------------------------- - |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts + | Just (scrut', case_bndr', alts') <- caseRules2 (sePlatform env) scrut case_bndr alts = reallyRebuildCase env scrut' case_bndr' alts' cont - where - all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] - is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect - -rebuildCase env scrut case_bndr alts cont + | otherwise = reallyRebuildCase env scrut case_bndr alts cont doCaseToLet :: OutExpr -- Scrutinee ===================================== compiler/GHC/Prelude/Basic.hs ===================================== @@ -68,9 +68,6 @@ import qualified GHC.Data.List.NonEmpty as NE import GHC.Stack.Types (HasCallStack) import GHC.Bits as Bits hiding (bit, shiftL, shiftR, setBit, clearBit) -# if defined(DEBUG) -import qualified GHC.Bits as Bits (shiftL, shiftR) -# endif {- Note [Default to unsafe shifts inside GHC] @@ -99,11 +96,29 @@ See also #19618 -- We always want the Data.Bits method to show up for rules etc. {-# INLINE shiftL #-} {-# INLINE shiftR #-} -shiftL, shiftR :: Bits.Bits a => a -> Int -> a #if defined(DEBUG) -shiftL = Bits.shiftL -shiftR = Bits.shiftR +-- In debug mode we explicitly check that the shift value is valid for +-- unsafeShiftL/R. Otherwise we may have bugs only showing up in non-DEBUG +-- builds. +shiftL, shiftR :: (HasCallStack, Bits.Bits a) => a -> Int -> a +shiftL x n + | n < 0 + = error ("shiftL: negative shift value: " ++ show n) + | Just s <- bitSizeMaybe x + , n >= s + = error ("shiftL: shift value greater than bitSize: " ++ show n ++ " >= " ++ show s) + | otherwise + = Bits.unsafeShiftL x n +shiftR x n + | n < 0 + = error ("shiftR: negative shift value: " ++ show n) + | Just s <- bitSizeMaybe x + , n >= s + = error ("shiftR: shift value greater than bitSize: " ++ show n ++ " >= " ++ show s) + | otherwise + = Bits.unsafeShiftR x n #else +shiftL, shiftR :: Bits.Bits a => a -> Int -> a shiftL = Bits.unsafeShiftL shiftR = Bits.unsafeShiftR #endif ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -729,15 +729,13 @@ cgAlts gc_plan bndr (PrimAlt _) alts ; tagged_cmms <- cgAltRhss gc_plan bndr alts ; let bndr_reg = CmmLocal (idToReg platform bndr) - deflt = case tagged_cmms of - (DEFAULT,deflt):_ -> deflt - _ -> panic "cgAlts PrimAlt" - -- PrimAlts always have a DEFAULT case - -- and it always comes first + mdeflt = case tagged_cmms of + (DEFAULT,deflt):_ -> Just deflt + _ -> Nothing tagged_cmms' = [(lit,code) | (LitAlt lit, code) <- tagged_cmms] - ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt + ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' mdeflt ; return AssignedDirectly } cgAlts gc_plan bndr (AlgAlt tycon) alts ===================================== compiler/GHC/StgToCmm/Utils.hs ===================================== @@ -478,41 +478,49 @@ divideBranches branches = (lo_branches, mid, hi_branches) -------------- emitCmmLitSwitch :: CmmExpr -- Tag to switch on -> [(Literal, CmmAGraphScoped)] -- Tagged branches - -> CmmAGraphScoped -- Default branch (always) + -> Maybe CmmAGraphScoped -- Default branch -> FCode () -- Emit the code -emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt -emitCmmLitSwitch scrut branches@(branch:_) deflt = do +emitCmmLitSwitch _scrut [] (Just deflt) = emit $ fst deflt +emitCmmLitSwitch _scrut [] Nothing = panic "emitCmmLitSwitch: expected DEFAULT branch (no alts)" +emitCmmLitSwitch scrut branches@(branch:_) mdeflt = do scrut' <- assignTemp' scrut join_lbl <- newBlockId - deflt_lbl <- label_code join_lbl deflt branches_lbls <- label_branches join_lbl branches platform <- getPlatform let cmm_ty = cmmExprType platform scrut rep = typeWidth cmm_ty - -- We find the necessary type information in the literals in the branches - let (signed,range) = case branch of - (LitNumber nt _, _) -> (signed,range) - where - signed = litNumIsSigned nt - range = case litNumRange platform nt of - (Just mi, Just ma) -> (mi,ma) - -- unbounded literals (Natural and - -- Integer) must have been - -- lowered at this point - partial_bounds -> pprPanic "Unexpected unbounded literal range" - (ppr partial_bounds) - -- assuming native word range - _ -> (False, (0, platformMaxWord platform)) - if isFloatType cmm_ty - then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls - else emit $ mk_discrete_switch + then do + deflt_lbl <- case mdeflt of + Nothing -> panic "emitCmmLitSwitch: expected DEFAULT branch (float switch)" + Just deflt -> label_code join_lbl deflt + emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls + else do + -- We find the necessary type information in the literals in the branches + let (signed,range) = case branch of + (LitNumber nt _, _) -> (signed,range) + where + signed = litNumIsSigned nt + range = case litNumRange platform nt of + (Just mi, Just ma) -> (mi,ma) + -- unbounded literals (Natural and + -- Integer) must have been + -- lowered at this point + partial_bounds -> pprPanic "Unexpected unbounded literal range" + (ppr partial_bounds) + -- assuming native word range + _ -> (False, (0, platformMaxWord platform)) + + mdeflt_lbl <- case mdeflt of + Nothing -> pure Nothing + Just deflt -> Just <$> label_code join_lbl deflt + emit $ mk_discrete_switch signed scrut' [(litValue lit,l) | (lit,l) <- branches_lbls] - (Just deflt_lbl) + mdeflt_lbl range emitLabel join_lbl ===================================== compiler/ghc.cabal.in ===================================== @@ -384,6 +384,7 @@ Library GHC.Core.Opt.OccurAnal GHC.Core.Opt.Pipeline GHC.Core.Opt.Pipeline.Types + GHC.Core.Opt.Range GHC.Core.Opt.SetLevels GHC.Core.Opt.Simplify GHC.Core.Opt.Simplify.Env ===================================== libraries/ghc-internal/src/GHC/Internal/Char.hs ===================================== @@ -14,13 +14,19 @@ import GHC.Internal.Classes (eqChar, neChar) import GHC.Internal.Base (otherwise, (++)) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Show -import GHC.Internal.Prim (chr#, int2Word#, leWord#) +import GHC.Internal.Prim (chr#, int2Word#, leWord#, Int#, Char#) import GHC.Internal.Types (Char(..), Int(..), isTrue#) -- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'. chr :: Int -> Char -chr i@(I# i#) - | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = C# (chr# i#) - | otherwise - = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "") +chr (I# i#) = C# (safe_chr# i#) +{-# INLINABLE safe_chr# #-} +safe_chr# :: Int# -> Char# +safe_chr# i# + | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = chr# i# + | otherwise = chr_error i# + +{-# NOINLINE chr_error #-} +chr_error :: Int# -> Char# +chr_error i# = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) (I# i#) "") ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -30,6 +30,7 @@ GHC.Core.Opt.Arity GHC.Core.Opt.CallerCC.Types GHC.Core.Opt.ConstantFold GHC.Core.Opt.OccurAnal +GHC.Core.Opt.Range GHC.Core.PatSyn GHC.Core.Ppr GHC.Core.Predicate ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -30,6 +30,7 @@ GHC.Core.Opt.Arity GHC.Core.Opt.CallerCC.Types GHC.Core.Opt.ConstantFold GHC.Core.Opt.OccurAnal +GHC.Core.Opt.Range GHC.Core.PatSyn GHC.Core.Ppr GHC.Core.Predicate ===================================== testsuite/tests/simplCore/should_compile/T19166.hs ===================================== @@ -0,0 +1,12 @@ +module T19166 where + +import Data.Bits + +foo :: Int -> Int +foo x = case x .&. 0x3 of + 0 -> 0 + 1 -> 1 + 2 -> 2 + 3 -> 3 + 4 -> 4 -- unreachable branch but not removed + _ -> undefined -- required for the PM checker but unreachable too ===================================== testsuite/tests/simplCore/should_compile/T19166.stderr ===================================== @@ -0,0 +1,26 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 29, types: 10, coercions: 0, joins: 0/0} + +foo4 = I# 0# + +foo3 = I# 1# + +foo2 = I# 2# + +foo1 = I# 3# + +foo + = \ x -> + case x of { I# x# -> + case andI# x# 3# of { + 0# -> foo4; + 1# -> foo3; + 2# -> foo2; + 3# -> foo1 + } + } + + + ===================================== testsuite/tests/simplCore/should_compile/T25718.hs ===================================== @@ -0,0 +1,16 @@ +module T25718 where + +import Data.Char +import Data.Word + +word8ToChar :: Word8 -> Char +word8ToChar = chr . fromIntegral + +isAsciiChar :: Char -> Bool +isAsciiChar = (< 256) . ord + +foo :: Word8 -> Bool +foo = isAsciiChar . word8ToChar + +bar :: Word8 -> Bool +bar x = fromIntegral x <= 255 ===================================== testsuite/tests/simplCore/should_compile/T25718.stderr ===================================== @@ -0,0 +1,18 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 28, types: 18, coercions: 0, joins: 0/0} + +isAsciiChar + = \ x -> case x of { C# c# -> tagToEnum# (<# (ord# c#) 256#) } + +bar = \ x -> case x of { W8# x# -> True } + +word8ToChar + = \ x -> + case x of { W8# x# -> C# (chr# (word2Int# (word8ToWord# x#))) } + +foo = bar + + + ===================================== testsuite/tests/simplCore/should_compile/T25718a.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE MagicHash #-} +module T25718a where + +import GHC.Exts + +-- Test a limitation of range analysis: if we improve the analysis, it could +-- become a constant function `\_ -> True` +foo :: Int# -> Bool +foo x = case isTrue# (x ># 0#) of + True -> {- Here we should know that x's range is > 0 -} + not (isTrue# (x <=# 0#)) -- we write it this way to avoid CSE for `x ># 0#` to kick in + False -> {- ... and here <= 0 -} + isTrue# (x <=# 0#) ===================================== testsuite/tests/simplCore/should_compile/T25718a.stderr ===================================== @@ -0,0 +1,18 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 20, types: 6, coercions: 0, joins: 0/0} + +foo + = \ x -> + case ># x 0# of { + __DEFAULT -> tagToEnum# (<=# x 0#); + 1# -> + case <=# x 0# of { + __DEFAULT -> True; + 1# -> False + } + } + + + ===================================== testsuite/tests/simplCore/should_compile/T25718b.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash #-} +module T25718a where + +import GHC.Exts + +-- Test that value range analysis is used to remove unreachable alternatives + +foo :: Word8# -> Bool +foo x = case word8ToWord# x of + 123456## -> False + 456789## -> False + 42## -> False + _ -> True + +bar :: Word# -> Bool +bar x = case x `and#` 0xF## of + 123456## -> False + 456789## -> False + 0xF0## -> False + 0x05## -> False + _ -> True ===================================== testsuite/tests/simplCore/should_compile/T25718b.stderr ===================================== @@ -0,0 +1,21 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 19, types: 8, coercions: 0, joins: 0/0} + +foo + = \ x -> + case word8ToWord# x of { + __DEFAULT -> True; + 42## -> False + } + +bar + = \ x -> + case and# x 15## of { + __DEFAULT -> True; + 5## -> False + } + + + ===================================== testsuite/tests/simplCore/should_compile/T25718c.hs ===================================== @@ -0,0 +1,261 @@ +{-# LANGUAGE CPP, MagicHash #-} +module T25718c where + +#include "MachDeps.h" + +import GHC.Exts + +-- Test that value range analysis handles all conversion/narrow/arithmetic primops. +-- Each section tests a different op from `valueRange` in GHC.Core.Opt.Range. +-- +-- Already tested in T25718/T25718b: Word8ToWordOp, WordAndOp. +-- Here we test the remaining ops: +-- +-- (1) Narrow8IntOp (narrow8Int#): result in Int8 range [-128, 127] +-- (2) Narrow16IntOp (narrow16Int#): result in Int16 range [-32768,32767] +-- (3) Narrow8WordOp (narrow8Word#): result in Word8 range [0, 255] +-- (4) Narrow16WordOp (narrow16Word#):result in Word16 range [0, 65535] +-- (5) Word16ToWordOp (word16ToWord#):result in Word16 range [0, 65535] +-- (6) WordToWord8Op (wordToWord8#): result in Word8 range [0, 255] +-- (7) WordToWord16Op (wordToWord16#):result in Word16 range [0, 65535] +-- (8) Word8ToInt8Op (word8ToInt8#): rangeCastFrom -> Int8 range [-128, 127] +-- (9) Word16ToInt16Op(word16ToInt16#):rangeCastFrom -> Int16 range [-32768,32767] +-- (10) Int8ToWord8Op (int8ToWord8#): rangeCastFrom -> Word8 range [0, 255] +-- (11) Int16ToWord16Op(int16ToWord16#):rangeCastFrom -> Word16 range [0, 65535] +-- (12) Word8AddOp (plusWord8#): rangeCastFrom fallback -> Word8 range [0, 255] +-- (13) VRA1 for Word16 (unreachable alt removal) +-- (14) VRA1 for narrow8Int# (unreachable alt removal) +-- (15) Word8SubOp (subWord8#): result in Word8 range [0, 255] +-- (16) Word16AddOp (plusWord16#):result in Word16 range [0, 65535] +-- (17) Word16SubOp (subWord16#): result in Word16 range [0, 65535] +-- (18) Int8AddOp (plusInt8#): result in Int8 range [-128, 127] +-- (19) Int8SubOp (subInt8#): result in Int8 range [-128, 127] +-- (20) Int16AddOp (plusInt16#): result in Int16 range [-32768,32767] +-- (21) Int16SubOp (subInt16#): result in Int16 range [-32768,32767] +-- (22) Narrow32IntOp (narrow32Int#): result in Int32 range [-2147483648,2147483647] +-- (23) Word32ToInt32Op (word32ToInt32#): rangeCastFrom -> Int32 range [-2147483648,2147483647] +-- (24) Int32ToWord32Op (int32ToWord32#): rangeCastFrom -> Word32 range [0,4294967295] +-- (25) Int32AddOp (plusInt32#): result in Int32 range [-2147483648,2147483647] +-- (26) Int32SubOp (subInt32#): result in Int32 range [-2147483648,2147483647] +-- (27) Word8AndOp (andWord8#): rangeAnd -> [0, mask] +-- (28) Word16AndOp (andWord16#): rangeAnd -> [0, mask] +-- (29) Word32AndOp (andWord32#): rangeAnd -> [0, mask] +-- (30) Word64AndOp (and64#): rangeAnd -> [0, mask] +-- (31) IntAndOp (andI#): rangeAnd -> [0, mask] +-- Sections (32)-(38) require 64-bit literals; guarded with CPP: +-- (32) Narrow32WordOp (narrow32Word#): on 64-bit, result in Word32 range [0,4294967295] +-- (33) Word32ToWordOp (word32ToWord#): on 64-bit, result in Word32 range [0,4294967295] +-- (34) WordToWord32Op (wordToWord32#): on 64-bit, composed chain in [0,4294967295] +-- (35) Word32AddOp (plusWord32#): on 64-bit, result in Word32 range [0,4294967295] +-- (36) Word32SubOp (subWord32#): on 64-bit, result in Word32 range [0,4294967295] +-- (37) VRA1 for narrow32Int# (unreachable alts > 2147483647) +-- (38) VRA1 for word32ToWord# (unreachable alts > 4294967295) + +-- (1) Narrow8IntOp: narrow8Int# x is always in [-128, 127] +narrow8_ge_lb :: Int# -> Bool +narrow8_ge_lb x = isTrue# (narrow8Int# x >=# -128#) -- True + +narrow8_le_ub :: Int# -> Bool +narrow8_le_ub x = isTrue# (narrow8Int# x <=# 127#) -- True + +narrow8_gt_ub_false :: Int# -> Bool +narrow8_gt_ub_false x = isTrue# (narrow8Int# x >=# 128#) -- False + +-- (2) Narrow16IntOp: narrow16Int# x is always in [-32768, 32767] +narrow16_ge_lb :: Int# -> Bool +narrow16_ge_lb x = isTrue# (narrow16Int# x >=# -32768#) -- True + +narrow16_le_ub :: Int# -> Bool +narrow16_le_ub x = isTrue# (narrow16Int# x <=# 32767#) -- True + +-- (3) Narrow8WordOp: narrow8Word# x is always in [0, 255] +narrow8w_lt_ub :: Word# -> Bool +narrow8w_lt_ub x = isTrue# (narrow8Word# x `ltWord#` 256##) -- True + +-- (4) Narrow16WordOp: narrow16Word# x is always in [0, 65535] +narrow16w_lt_ub :: Word# -> Bool +narrow16w_lt_ub x = isTrue# (narrow16Word# x `ltWord#` 65536##) -- True + +-- (5) Word16ToWordOp: word16ToWord# x is always in [0, 65535] +word16_lt_ub :: Word16# -> Bool +word16_lt_ub x = isTrue# (word16ToWord# x `ltWord#` 65536##) -- True + +word16_ge_ub_false :: Word16# -> Bool +word16_ge_ub_false x = isTrue# (word16ToWord# x `geWord#` 65536##) -- False + +-- (6) WordToWord8Op: word8ToWord# (wordToWord8# x) is in [0, 255] +word_to_word8_lt :: Word# -> Bool +word_to_word8_lt x = isTrue# (word8ToWord# (wordToWord8# x) `ltWord#` 256##) -- True + +-- (7) WordToWord16Op: word16ToWord# (wordToWord16# x) is in [0, 65535] +word_to_word16_lt :: Word# -> Bool +word_to_word16_lt x = isTrue# (word16ToWord# (wordToWord16# x) `ltWord#` 65536##) -- True + +-- (8) Word8ToInt8Op: word8ToInt8# x has range Int8 [-128, 127] (via rangeCastFrom) +word8_to_int8_ge :: Word8# -> Bool +word8_to_int8_ge x = isTrue# (geInt8# (word8ToInt8# x) (intToInt8# -128#)) -- True + +-- (9) Word16ToInt16Op: word16ToInt16# x has range Int16 [-32768, 32767] +word16_to_int16_ge :: Word16# -> Bool +word16_to_int16_ge x = isTrue# (geInt16# (word16ToInt16# x) (intToInt16# -32768#)) -- True + +-- (10) Int8ToWord8Op: int8ToWord8# x has range Word8 [0, 255] (via rangeCastFrom) +int8_to_word8_le :: Int8# -> Bool +int8_to_word8_le x = isTrue# (leWord8# (int8ToWord8# x) (wordToWord8# 255##)) -- True + +-- (11) Int16ToWord16Op: int16ToWord16# x has range Word16 [0, 65535] +int16_to_word16_le :: Int16# -> Bool +int16_to_word16_le x = isTrue# (leWord16# (int16ToWord16# x) (wordToWord16# 65535##)) -- True + +-- (12) Word8AddOp: plusWord8# result stays in [0, 255] (rangeCastFrom fallback) +word8_add_lt_256 :: Word8# -> Word8# -> Bool +word8_add_lt_256 x y = isTrue# (word8ToWord# (plusWord8# x y) `ltWord#` 256##) -- True + +-- (13) VRA1: unreachable alts for Word16 range [0, 65535] +word16_alts :: Word16# -> Bool +word16_alts x = case word16ToWord# x of + 100000## -> False -- unreachable: 100000 > 65535 + 65536## -> False -- unreachable: 65536 > 65535 + 42## -> False -- reachable + _ -> True + +-- (14) VRA1: unreachable alts for narrow8Int# range [-128, 127] +narrow8_alts :: Int# -> Bool +narrow8_alts x = case narrow8Int# x of + 200# -> False -- unreachable: 200 > 127 + 128# -> False -- unreachable: 128 > 127 + 42# -> False -- reachable + _ -> True + +-- (15) Word8SubOp: subWord8# result stays in [0, 255] +word8_sub_lt_256 :: Word8# -> Word8# -> Bool +word8_sub_lt_256 x y = isTrue# (word8ToWord# (subWord8# x y) `ltWord#` 256##) -- True + +-- (16) Word16AddOp: plusWord16# result stays in [0, 65535] +word16_add_lt_ub :: Word16# -> Word16# -> Bool +word16_add_lt_ub x y = isTrue# (word16ToWord# (plusWord16# x y) `ltWord#` 65536##) -- True + +-- (17) Word16SubOp: subWord16# result stays in [0, 65535] +word16_sub_lt_ub :: Word16# -> Word16# -> Bool +word16_sub_lt_ub x y = isTrue# (word16ToWord# (subWord16# x y) `ltWord#` 65536##) -- True + +-- (18) Int8AddOp: plusInt8# result stays in [-128, 127] +int8_add_ge_lb :: Int8# -> Int8# -> Bool +int8_add_ge_lb x y = isTrue# (geInt8# (plusInt8# x y) (intToInt8# -128#)) -- True + +-- (19) Int8SubOp: subInt8# result stays in [-128, 127] +int8_sub_le_ub :: Int8# -> Int8# -> Bool +int8_sub_le_ub x y = isTrue# (leInt8# (subInt8# x y) (intToInt8# 127#)) -- True + +-- (20) Int16AddOp: plusInt16# result stays in [-32768, 32767] +int16_add_ge_lb :: Int16# -> Int16# -> Bool +int16_add_ge_lb x y = isTrue# (geInt16# (plusInt16# x y) (intToInt16# -32768#)) -- True + +-- (21) Int16SubOp: subInt16# result stays in [-32768, 32767] +int16_sub_le_ub :: Int16# -> Int16# -> Bool +int16_sub_le_ub x y = isTrue# (leInt16# (subInt16# x y) (intToInt16# 32767#)) -- True + +-- (22) Narrow32IntOp: narrow32Int# result stays in [-2147483648, 2147483647] +-- (literals fit on 32-bit: -2147483648 = minInt32, 2147483647 = maxInt32) +narrow32_ge_lb :: Int# -> Bool +narrow32_ge_lb x = isTrue# (narrow32Int# x >=# -2147483648#) -- True + +narrow32_le_ub :: Int# -> Bool +narrow32_le_ub x = isTrue# (narrow32Int# x <=# 2147483647#) -- True + +-- (23) Word32ToInt32Op: word32ToInt32# result has range Int32 [-2147483648, 2147483647] +word32_to_int32_ge :: Word32# -> Bool +word32_to_int32_ge x = isTrue# (geInt32# (word32ToInt32# x) (intToInt32# -2147483648#)) -- True + +-- (24) Int32ToWord32Op: int32ToWord32# result has range Word32 [0, 4294967295] +-- (4294967295## = maxWord32 = maxWord on 32-bit, valid literal on any platform) +int32_to_word32_le :: Int32# -> Bool +int32_to_word32_le x = isTrue# (leWord32# (int32ToWord32# x) (wordToWord32# 4294967295##)) -- True + +-- (25) Int32AddOp: plusInt32# result stays in [-2147483648, 2147483647] +int32_add_ge_lb :: Int32# -> Int32# -> Bool +int32_add_ge_lb x y = isTrue# (geInt32# (plusInt32# x y) (intToInt32# -2147483648#)) -- True + +-- (26) Int32SubOp: subInt32# result stays in [-2147483648, 2147483647] +int32_sub_le_ub :: Int32# -> Int32# -> Bool +int32_sub_le_ub x y = isTrue# (leInt32# (subInt32# x y) (intToInt32# 2147483647#)) -- True + +-- (27) Word8AndOp: andWord8# with constant mask gives bounded range [0, mask] +word8_and_lt :: Word8# -> Bool +word8_and_lt x = isTrue# (word8ToWord# (andWord8# x (wordToWord8# 0xF##)) `ltWord#` 16##) -- True + +word8_and_alts :: Word8# -> Bool +word8_and_alts x = case word8ToWord# (andWord8# x (wordToWord8# 0xF##)) of + 100## -> False -- unreachable: 100 > 15 + 20## -> False -- unreachable: 20 > 15 + 5## -> False -- reachable + _ -> True + +-- (28) Word16AndOp: andWord16# with constant mask gives bounded range [0, mask] +word16_and_lt :: Word16# -> Bool +word16_and_lt x = isTrue# (word16ToWord# (andWord16# x (wordToWord16# 0xFF##)) `ltWord#` 256##) -- True + +-- (29) Word32AndOp: andWord32# with constant mask gives bounded range [0, mask] +-- (65536## = 2^16, valid on any platform as Word# literal) +word32_and_lt :: Word32# -> Bool +word32_and_lt x = isTrue# (word32ToWord# (andWord32# x (wordToWord32# 0xFFFF##)) `ltWord#` 65536##) -- True + +-- (30) Word64AndOp (and64#): with constant mask gives bounded range [0, mask] +word64_and_le :: Word64# -> Bool +word64_and_le x = isTrue# (leWord64# (and64# x (wordToWord64# 0xFFFF##)) (wordToWord64# 65535##)) -- True + +-- (31) IntAndOp (andI#): with non-negative constant mask gives range [0, mask] +int_and_ge :: Int# -> Bool +int_and_ge x = isTrue# (andI# x 0xFF# >=# 0#) -- True + +int_and_alts :: Int# -> Bool +int_and_alts x = case andI# x 0xFF# of + 256# -> False -- unreachable: 256 > 255 + 42# -> False -- reachable + _ -> True + +#if WORD_SIZE_IN_BITS >= 64 +-- On 64-bit platforms, Word# is 64-bit so 4294967296## (= 2^32) is a valid literal +-- and Word32 ops produce a proper sub-range of Word#. + +-- (32) Narrow32WordOp: narrow32Word# result in [0, 4294967295] on 64-bit +narrow32w_lt_ub :: Word# -> Bool +narrow32w_lt_ub x = isTrue# (narrow32Word# x `ltWord#` 4294967296##) -- True + +-- (33) Word32ToWordOp: word32ToWord# result in [0, 4294967295] on 64-bit +word32_lt_ub :: Word32# -> Bool +word32_lt_ub x = isTrue# (word32ToWord# x `ltWord#` 4294967296##) -- True + +word32_ge_ub_false :: Word32# -> Bool +word32_ge_ub_false x = isTrue# (word32ToWord# x `geWord#` 4294967296##) -- False + +-- (34) WordToWord32Op: word32ToWord# (wordToWord32# x) in [0, 4294967295] on 64-bit +word_to_word32_lt :: Word# -> Bool +word_to_word32_lt x = isTrue# (word32ToWord# (wordToWord32# x) `ltWord#` 4294967296##) -- True + +-- (35) Word32AddOp: plusWord32# result in [0, 4294967295] on 64-bit +word32_add_lt_ub :: Word32# -> Word32# -> Bool +word32_add_lt_ub x y = isTrue# (word32ToWord# (plusWord32# x y) `ltWord#` 4294967296##) -- True + +-- (36) Word32SubOp: subWord32# result in [0, 4294967295] on 64-bit +word32_sub_lt_ub :: Word32# -> Word32# -> Bool +word32_sub_lt_ub x y = isTrue# (word32ToWord# (subWord32# x y) `ltWord#` 4294967296##) -- True + +-- (37) VRA1 for narrow32Int# (unreachable alts outside [-2147483648, 2147483647]) +-- (literals 2147483648# and 3000000000# overflow Int# on 32-bit, so guarded by CPP) +narrow32_alts :: Int# -> Bool +narrow32_alts x = case narrow32Int# x of + 3000000000# -> False -- unreachable: 3000000000 > 2147483647 + 2147483648# -> False -- unreachable: 2147483648 > 2147483647 + 42# -> False -- reachable + _ -> True + +-- (38) VRA1 for word32ToWord# (unreachable alts outside [0, 4294967295]) +-- (literals 4294967296## etc. overflow Word# on 32-bit, so guarded by CPP) +word32_alts :: Word32# -> Bool +word32_alts x = case word32ToWord# x of + 5000000000## -> False -- unreachable: 5000000000 > 4294967295 + 4294967296## -> False -- unreachable: 4294967296 > 4294967295 + 42## -> False -- reachable + _ -> True +#endif ===================================== testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-32 ===================================== @@ -0,0 +1,103 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 128, types: 115, coercions: 0, joins: 0/0} + +narrow8_ge_lb = \ _ -> True + +narrow8_le_ub = narrow8_ge_lb + +narrow8_gt_ub_false = \ _ -> False + +narrow16_ge_lb = narrow8_ge_lb + +narrow16_le_ub = narrow8_ge_lb + +narrow8w_lt_ub = \ _ -> True + +narrow16w_lt_ub = narrow8w_lt_ub + +word16_lt_ub = \ _ -> True + +word16_ge_ub_false = \ _ -> False + +word_to_word8_lt = narrow8w_lt_ub + +word_to_word16_lt = narrow8w_lt_ub + +word8_to_int8_ge = \ _ -> True + +word16_to_int16_ge = word16_lt_ub + +int8_to_word8_le = \ _ -> True + +int16_to_word16_le = \ _ -> True + +word8_add_lt_256 = \ _ _ -> True + +word16_alts + = \ x -> + case word16ToWord# x of { + __DEFAULT -> True; + 42## -> False + } + +narrow8_alts + = \ x -> + case narrow8Int# x of { + __DEFAULT -> True; + 42# -> False + } + +word8_sub_lt_256 = word8_add_lt_256 + +word16_add_lt_ub = \ _ _ -> True + +word16_sub_lt_ub = word16_add_lt_ub + +int8_add_ge_lb = \ _ _ -> True + +int8_sub_le_ub = int8_add_ge_lb + +int16_add_ge_lb = \ _ _ -> True + +int16_sub_le_ub = int16_add_ge_lb + +narrow32_ge_lb = narrow8_ge_lb + +narrow32_le_ub = narrow8_ge_lb + +word32_to_int32_ge = \ _ -> True + +int32_to_word32_le = \ _ -> True + +int32_add_ge_lb = \ _ _ -> True + +int32_sub_le_ub = int32_add_ge_lb + +word8_and_lt = word8_to_int8_ge + +word8_and_alts + = \ x -> + case word8ToWord# (andWord8# x 15#Word8) of { + __DEFAULT -> True; + 5## -> False + } + +word16_and_lt = word16_lt_ub + +word32_and_lt = word32_to_int32_ge + +word64_and_le = \ _ -> True + +int_and_ge = narrow8_ge_lb + +int_and_alts + = \ x -> + case andI# x 255# of { + __DEFAULT -> True; + 42# -> False + } + + + ===================================== testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64 ===================================== @@ -0,0 +1,129 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 161, types: 140, coercions: 0, joins: 0/0} + +narrow8_ge_lb = \ _ -> True + +narrow8_le_ub = narrow8_ge_lb + +narrow8_gt_ub_false = \ _ -> False + +narrow16_ge_lb = narrow8_ge_lb + +narrow16_le_ub = narrow8_ge_lb + +narrow8w_lt_ub = \ _ -> True + +narrow16w_lt_ub = narrow8w_lt_ub + +word16_lt_ub = \ _ -> True + +word16_ge_ub_false = \ _ -> False + +word_to_word8_lt = narrow8w_lt_ub + +word_to_word16_lt = narrow8w_lt_ub + +word8_to_int8_ge = \ _ -> True + +word16_to_int16_ge = word16_lt_ub + +int8_to_word8_le = \ _ -> True + +int16_to_word16_le = \ _ -> True + +word8_add_lt_256 = \ _ _ -> True + +word16_alts + = \ x -> + case word16ToWord# x of { + __DEFAULT -> True; + 42## -> False + } + +narrow8_alts + = \ x -> + case narrow8Int# x of { + __DEFAULT -> True; + 42# -> False + } + +word8_sub_lt_256 = word8_add_lt_256 + +word16_add_lt_ub = \ _ _ -> True + +word16_sub_lt_ub = word16_add_lt_ub + +int8_add_ge_lb = \ _ _ -> True + +int8_sub_le_ub = int8_add_ge_lb + +int16_add_ge_lb = \ _ _ -> True + +int16_sub_le_ub = int16_add_ge_lb + +narrow32_ge_lb = narrow8_ge_lb + +narrow32_le_ub = narrow8_ge_lb + +word32_to_int32_ge = \ _ -> True + +int32_to_word32_le = \ _ -> True + +int32_add_ge_lb = \ _ _ -> True + +int32_sub_le_ub = int32_add_ge_lb + +word8_and_lt = word8_to_int8_ge + +word8_and_alts + = \ x -> + case word8ToWord# (andWord8# x 15#Word8) of { + __DEFAULT -> True; + 5## -> False + } + +word16_and_lt = word16_lt_ub + +word32_and_lt = word32_to_int32_ge + +word64_and_le = \ _ -> True + +int_and_ge = narrow8_ge_lb + +int_and_alts + = \ x -> + case andI# x 255# of { + __DEFAULT -> True; + 42# -> False + } + +narrow32w_lt_ub = narrow8w_lt_ub + +word32_lt_ub = word32_to_int32_ge + +word32_ge_ub_false = \ _ -> False + +word_to_word32_lt = narrow8w_lt_ub + +word32_add_lt_ub = \ _ _ -> True + +word32_sub_lt_ub = word32_add_lt_ub + +narrow32_alts + = \ x -> + case narrow32Int# x of { + __DEFAULT -> True; + 42# -> False + } + +word32_alts + = \ x -> + case word32ToWord# x of { + __DEFAULT -> True; + 42## -> False + } + + + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -594,3 +594,8 @@ test('T26805', [grep_errmsg(r'fromInteger')], compile, ['-O -dno-typeable-binds test('T26826', normal, compile, ['-O']) test('T26903', [grep_errmsg(r'reverse')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques -dsuppress-all']) test('T18032', normal, compile, ['-O -dsuppress-all -dsuppress-uniques -dno-typeable-binds -ddump-simpl']) +test('T25718', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) +test('T25718a', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) +test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) +test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) +test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c6d262aaea235dc142fe8d56704150b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c6d262aaea235dc142fe8d56704150b... You're receiving this email because of your account on gitlab.haskell.org.