Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

24 changed files:

Changes:

  • compiler/GHC/Core.hs
    ... ... @@ -4,6 +4,7 @@
    4 4 
     -}
    5 5
    6 6 
     {-# LANGUAGE NoPolyKinds #-}
    7 
    +{-# LANGUAGE LambdaCase #-}
    7 8
    8 9 
     -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection
    9 10 
     module GHC.Core (
    ... ... @@ -36,7 +37,7 @@ module GHC.Core (
    36 37
    37 38 
             mkBinds,
    38 39
    39 
    -        isId, cmpAltCon, cmpAlt, ltAlt,
    40 
    +        isId, cmpAltCon, cmpAlt, ltAlt, altsLevity, CaseLevity(..),
    40 41
    41 42 
             -- ** Simple 'Expr' access functions and predicates
    42 43 
             bindersOf, bindersOfBinds, rhssOfBind, rhssOfBinds, rhssOfAlts,
    ... ... @@ -60,7 +61,7 @@ module GHC.Core (
    60 61 
             unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
    61 62
    62 63 
             -- ** Predicates and deconstruction on 'Unfolding'
    63 
    -        expandUnfolding_maybe,
    64 
    +        expandUnfolding_maybe, expandUnfolding_always,
    64 65 
             maybeUnfoldingTemplate, otherCons,
    65 66 
             isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
    66 67 
             isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
    ... ... @@ -1787,6 +1788,11 @@ expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs })
    1787 1788 
         = Just rhs
    1788 1789 
     expandUnfolding_maybe _ = Nothing
    1789 1790
    1791 
    +-- Expand an unfolding, ignoring if it is expandable or not
    1792 
    +expandUnfolding_always :: Unfolding -> Maybe CoreExpr
    1793 
    +expandUnfolding_always (CoreUnfolding { uf_tmpl = rhs }) = Just rhs
    1794 
    +expandUnfolding_always _ = Nothing
    1795 
    +
    1790 1796 
     isCompulsoryUnfolding :: Unfolding -> Bool
    1791 1797 
     isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src
    1792 1798 
     isCompulsoryUnfolding _                                = False
    ... ... @@ -2006,6 +2012,25 @@ cmpAltCon (LitAlt _) DEFAULT = GT
    2006 2012
    2007 2013 
     cmpAltCon con1 con2 = pprPanic "cmpAltCon" (ppr con1 $$ ppr con2)
    2008 2014
    2015 
    +data CaseLevity
    2016 
    +  = CaseUnlifted
    2017 
    +  | CaseLifted
    2018 
    +  deriving (Eq)
    2019 
    +
    2020 
    +altCon :: Alt a -> AltCon
    2021 
    +altCon (Alt con _ _) = con
    2022 
    +
    2023 
    +-- | Try to determine the levity of a case-expression (unlifted, lifted) from
    2024 
    +-- its alternatives
    2025 
    +altsLevity :: [Alt a] -> Maybe CaseLevity
    2026 
    +altsLevity = alts_levity . fmap altCon
    2027 
    +  where
    2028 
    +    alts_levity = \case
    2029 
    +      []              -> Nothing
    2030 
    +      (DEFAULT:xs)    -> alts_levity xs
    2031 
    +      (LitAlt {}:_)   -> Just CaseUnlifted
    2032 
    +      (DataAlt {}:_)  -> Just CaseLifted
    2033 
    +
    2009 2034 
     {-
    2010 2035 
     ************************************************************************
    2011 2036 
     *                                                                      *

  • compiler/GHC/Core/Lint.hs
    ... ... @@ -1631,16 +1631,21 @@ checkCaseAlts e scrut scrut_ty alts
    1631 1631 
            ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
    1632 1632 
                -- See GHC.Core Note [Case expression invariants] item (3)
    1633 1633
    1634 
    -            -- For types Int#, Word# with an infinite (well, large!) number of
    1635 
    -            -- possible values, there should usually be a DEFAULT case
    1636 
    -            -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to
    1637 
    -            -- have *no* case alternatives.
    1638 
    -            -- In effect, this is a kind of partial test. I suppose it's possible
    1639 
    -            -- that we might *know* that 'x' was 1 or 2, in which case
    1640 
    -            --   case x of { 1 -> e1; 2 -> e2 }
    1641 
    -            -- would be fine.
    1642 
    -       ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)
    1643 
    -                (nonExhaustiveAltsMsg e)
    1634 
    +       -- Historical note: we used to check that primitive types with a large
    1635 
    +       -- number of possible values (e.g. Int#, Word#...) either had:
    1636 
    +       --   * no alternatives (see Note [Empty case alternatives] in GHC.Core)
    1637 
    +       --   * a DEFAULT alternative
    1638 
    +       -- The rationale was that we can't reasonably enumerate all possible
    1639 
    +       -- alternatives hence the need for a DEFAULT alternative. Moreover
    1640 
    +       -- HsToCore introduces a DEFAULT alternative to raise a pattern-match
    1641 
    +       -- error so there must be at least one.
    1642 
    +       --
    1643 
    +       -- However, since we implemented range analysis (see Note [Value range
    1644 
    +       -- analysis] in GHC.Core.Range), we're filtering unreachable
    1645 
    +       -- alternatives, even the DEFAULT one, so this check is no longer valid.
    1646 
    +       -- E.g. DEFAULT alternative is now removed in:
    1647 
    +       --   case x .&. 1 of { DEFAULT -> ..; 0 -> ..; 1 -> ..}
    1648 
    +       -- even if we're matching an Int#.
    1644 1649
    1645 1650 
            -- Check that the scrutinee is not a floating-point type
    1646 1651 
            -- if there are any literal alternatives
    ... ... @@ -1666,7 +1671,7 @@ checkCaseAlts e scrut scrut_ty alts
    1666 1671 
                _otherwise -> return ()
    1667 1672 
             }
    1668 1673 
       where
    1669 
    -    (con_alts, maybe_deflt) = findDefault alts
    1674 
    +    (con_alts, _maybe_deflt) = findDefault alts
    1670 1675
    1671 1676 
             -- Check that successive alternatives have strictly increasing tags
    1672 1677 
         increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
    ... ... @@ -1678,10 +1683,6 @@ checkCaseAlts e scrut scrut_ty alts
    1678 1683 
         is_lit_alt (Alt (LitAlt _) _  _) = True
    1679 1684 
         is_lit_alt _                     = False
    1680 1685
    1681 
    -    is_infinite_ty = case tyConAppTyCon_maybe scrut_ty of
    1682 
    -                        Nothing    -> False
    1683 
    -                        Just tycon -> isPrimTyCon tycon
    1684 
    -
    1685 1686 
     lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv
    1686 1687 
     lintAltExpr expr ann_ty
    1687 1688 
       = do { (actual_ty, ue) <- lintCoreExpr expr
    ... ... @@ -3773,10 +3774,6 @@ mkNonDefltMsg e
    3773 3774 
     mkNonIncreasingAltsMsg e
    3774 3775 
       = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
    3775 3776
    3776 
    -nonExhaustiveAltsMsg :: CoreExpr -> SDoc
    3777 
    -nonExhaustiveAltsMsg e
    3778 
    -  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
    3779 
    -
    3780 3777 
     mkBadConMsg :: TyCon -> DataCon -> SDoc
    3781 3778 
     mkBadConMsg tycon datacon
    3782 3779 
       = vcat [

  • compiler/GHC/Core/Opt/ConstantFold.hs
    ... ... @@ -44,7 +44,7 @@ import GHC.Core
    44 44 
     import GHC.Core.Make
    45 45 
     import GHC.Core.SimpleOpt (  exprIsConApp_maybe, exprIsLiteral_maybe )
    46 46 
     import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
    47 
    -import GHC.Core.Utils  ( cheapEqExpr, exprIsHNF
    47 
    +import GHC.Core.Utils  ( cheapEqExpr, exprIsHNF, isDefaultAlt
    48 48 
                            , stripTicksTop, stripTicksTopT, mkTicks )
    49 49 
     import GHC.Core.Multiplicity
    50 50 
     import GHC.Core.Rules.Config
    ... ... @@ -54,6 +54,7 @@ import GHC.Core.TyCon
    54 54 
        ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize
    55 55 
        , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon )
    56 56 
     import GHC.Core.Map.Expr ( eqCoreExpr )
    57 
    +import GHC.Core.Opt.Range
    57 58
    58 59 
     import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )
    59 60 
     import GHC.Builtin.PrimOps.Ids (primOpId)
    ... ... @@ -76,6 +77,7 @@ import Data.Functor (($>))
    76 77 
     import qualified Data.ByteString as BS
    77 78 
     import Data.Ratio
    78 79 
     import Data.Word
    80 
    +import Data.Char (ord)
    79 81 
     import Data.Maybe (fromMaybe, fromJust)
    80 82
    81 83 
     {-
    ... ... @@ -777,60 +779,60 @@ primOpRules nm = \case
    777 779
    778 780 
        -- Relational operators, ordering
    779 781
    780 
    -   Int8GtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    781 
    -   Int8GeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    782 
    -   Int8LeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    783 
    -   Int8LtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    784 
    -
    785 
    -   Int16GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    786 
    -   Int16GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    787 
    -   Int16LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    788 
    -   Int16LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    789 
    -
    790 
    -   Int32GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    791 
    -   Int32GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    792 
    -   Int32LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    793 
    -   Int32LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    794 
    -
    795 
    -   Int64GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    796 
    -   Int64GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    797 
    -   Int64LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    798 
    -   Int64LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    799 
    -
    800 
    -   IntGtOp    -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    801 
    -   IntGeOp    -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    802 
    -   IntLeOp    -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    803 
    -   IntLtOp    -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    804 
    -
    805 
    -   Word8GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    806 
    -   Word8GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    807 
    -   Word8LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    808 
    -   Word8LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    809 
    -
    810 
    -   Word16GtOp -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    811 
    -   Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    812 
    -   Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    813 
    -   Word16LtOp -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    814 
    -
    815 
    -   Word32GtOp -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    816 
    -   Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    817 
    -   Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    818 
    -   Word32LtOp -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    819 
    -
    820 
    -   Word64GtOp -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    821 
    -   Word64GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    822 
    -   Word64LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    823 
    -   Word64LtOp -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    824 
    -
    825 
    -   WordGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    826 
    -   WordGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    827 
    -   WordLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    828 
    -   WordLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    829 
    -
    830 
    -   CharGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
    831 
    -   CharGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
    832 
    -   CharLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]
    833 
    -   CharLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
    782 
    +   Int8GtOp   -> mkRelOpRule nm (>)  [ boundsCmp (const rangeInt8) Gt ]
    783 
    +   Int8GeOp   -> mkRelOpRule nm (>=) [ boundsCmp (const rangeInt8) Ge ]
    784 
    +   Int8LeOp   -> mkRelOpRule nm (<=) [ boundsCmp (const rangeInt8) Le ]
    785 
    +   Int8LtOp   -> mkRelOpRule nm (<)  [ boundsCmp (const rangeInt8) Lt ]
    786 
    +
    787 
    +   Int16GtOp  -> mkRelOpRule nm (>)  [ boundsCmp (const rangeInt16) Gt ]
    788 
    +   Int16GeOp  -> mkRelOpRule nm (>=) [ boundsCmp (const rangeInt16) Ge ]
    789 
    +   Int16LeOp  -> mkRelOpRule nm (<=) [ boundsCmp (const rangeInt16) Le ]
    790 
    +   Int16LtOp  -> mkRelOpRule nm (<)  [ boundsCmp (const rangeInt16) Lt ]
    791 
    +
    792 
    +   Int32GtOp  -> mkRelOpRule nm (>)  [ boundsCmp (const rangeInt32) Gt ]
    793 
    +   Int32GeOp  -> mkRelOpRule nm (>=) [ boundsCmp (const rangeInt32) Ge ]
    794 
    +   Int32LeOp  -> mkRelOpRule nm (<=) [ boundsCmp (const rangeInt32) Le ]
    795 
    +   Int32LtOp  -> mkRelOpRule nm (<)  [ boundsCmp (const rangeInt32) Lt ]
    796 
    +
    797 
    +   Int64GtOp  -> mkRelOpRule nm (>)  [ boundsCmp (const rangeInt64) Gt ]
    798 
    +   Int64GeOp  -> mkRelOpRule nm (>=) [ boundsCmp (const rangeInt64) Ge ]
    799 
    +   Int64LeOp  -> mkRelOpRule nm (<=) [ boundsCmp (const rangeInt64) Le ]
    800 
    +   Int64LtOp  -> mkRelOpRule nm (<)  [ boundsCmp (const rangeInt64) Lt ]
    801 
    +
    802 
    +   IntGtOp    -> mkRelOpRule nm (>)  [ boundsCmp rangeInt Gt ]
    803 
    +   IntGeOp    -> mkRelOpRule nm (>=) [ boundsCmp rangeInt Ge ]
    804 
    +   IntLeOp    -> mkRelOpRule nm (<=) [ boundsCmp rangeInt Le ]
    805 
    +   IntLtOp    -> mkRelOpRule nm (<)  [ boundsCmp rangeInt Lt ]
    806 
    +
    807 
    +   Word8GtOp  -> mkRelOpRule nm (>)  [ boundsCmp (const rangeWord8) Gt ]
    808 
    +   Word8GeOp  -> mkRelOpRule nm (>=) [ boundsCmp (const rangeWord8) Ge ]
    809 
    +   Word8LeOp  -> mkRelOpRule nm (<=) [ boundsCmp (const rangeWord8) Le ]
    810 
    +   Word8LtOp  -> mkRelOpRule nm (<)  [ boundsCmp (const rangeWord8) Lt ]
    811 
    +
    812 
    +   Word16GtOp -> mkRelOpRule nm (>)  [ boundsCmp (const rangeWord16) Gt ]
    813 
    +   Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeWord16) Ge ]
    814 
    +   Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeWord16) Le ]
    815 
    +   Word16LtOp -> mkRelOpRule nm (<)  [ boundsCmp (const rangeWord16) Lt ]
    816 
    +
    817 
    +   Word32GtOp -> mkRelOpRule nm (>)  [ boundsCmp (const rangeWord32) Gt ]
    818 
    +   Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeWord32) Ge ]
    819 
    +   Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeWord32) Le ]
    820 
    +   Word32LtOp -> mkRelOpRule nm (<)  [ boundsCmp (const rangeWord32) Lt ]
    821 
    +
    822 
    +   Word64GtOp -> mkRelOpRule nm (>)  [ boundsCmp (const rangeWord64) Gt ]
    823 
    +   Word64GeOp -> mkRelOpRule nm (>=) [ boundsCmp (const rangeWord64) Ge ]
    824 
    +   Word64LeOp -> mkRelOpRule nm (<=) [ boundsCmp (const rangeWord64) Le ]
    825 
    +   Word64LtOp -> mkRelOpRule nm (<)  [ boundsCmp (const rangeWord64) Lt ]
    826 
    +
    827 
    +   WordGtOp   -> mkRelOpRule nm (>)  [ boundsCmp rangeWord Gt ]
    828 
    +   WordGeOp   -> mkRelOpRule nm (>=) [ boundsCmp rangeWord Ge ]
    829 
    +   WordLeOp   -> mkRelOpRule nm (<=) [ boundsCmp rangeWord Le ]
    830 
    +   WordLtOp   -> mkRelOpRule nm (<)  [ boundsCmp rangeWord Lt ]
    831 
    +
    832 
    +   CharGtOp   -> mkRelOpRule nm (>)  [ boundsCmp rangeChar Gt ]
    833 
    +   CharGeOp   -> mkRelOpRule nm (>=) [ boundsCmp rangeChar Ge ]
    834 
    +   CharLeOp   -> mkRelOpRule nm (<=) [ boundsCmp rangeChar Le ]
    835 
    +   CharLtOp   -> mkRelOpRule nm (<)  [ boundsCmp rangeChar Lt ]
    834 836
    835 837 
        FloatGtOp  -> mkFloatingRelOpRule nm (>)
    836 838 
        FloatGeOp  -> mkFloatingRelOpRule nm (>=)
    ... ... @@ -1401,27 +1403,27 @@ litEq is_eq = msum
    1401 1403 
                        | otherwise = trueValInt  platform
    1402 1404
    1403 1405
    1404 
    --- | Check if there is comparison with minBound or maxBound, that is
    1405 
    --- always true or false. For instance, an Int cannot be smaller than its
    1406 
    --- minBound, so we can replace such comparison with False.
    1407 
    -boundsCmp :: Comparison -> RuleM CoreExpr
    1408 
    -boundsCmp op = do
    1406 
    +-- | Perform value range analysis to check if can determine the result
    1407 
    +-- of a comparison statically. For instance, a Word8 converted into a Word is
    1408 
    +-- always smaller than 256.
    1409 
    +boundsCmp :: (Platform -> Range) -> Comparison -> RuleM CoreExpr
    1410 
    +boundsCmp mk_range op = do
    1409 1411 
       platform <- getPlatform
    1410 1412 
       [a, b] <- getArgs
    1411 
    -  liftMaybe $ mkRuleFn platform op a b
    1412 
    -
    1413 
    -data Comparison = Gt | Ge | Lt | Le
    1414 
    -
    1415 
    -mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
    1416 
    -mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform
    1417 
    -mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt  platform
    1418 
    -mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt  platform
    1419 
    -mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform
    1420 
    -mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt  platform
    1421 
    -mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform
    1422 
    -mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform
    1423 
    -mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt  platform
    1424 
    -mkRuleFn _ _ _ _                                           = Nothing
    1413 
    +  let ty_range = mk_range platform
    1414 
    +  liftMaybe $ value_range_cmp platform op ty_range a b
    1415 
    +
    1416 
    +-- | See Note [Value range analysis] in GHC.Core.Opt.Range
    1417 
    +value_range_cmp :: Platform -> Comparison -> Range -> CoreExpr -> CoreExpr -> Maybe CoreExpr
    1418 
    +value_range_cmp platform cmp ty_range x y =
    1419 
    +  let rx = ty_range `rangeIntersect` valueRange platform x
    1420 
    +      ry = ty_range `rangeIntersect` valueRange platform y
    1421 
    +      to_bool = \case
    1422 
    +        Nothing    -> Nothing
    1423 
    +        Just True  -> Just (trueValInt platform)
    1424 
    +        Just False -> Just (falseValInt platform)
    1425 
    +      res = rangeCmp cmp rx ry
    1426 
    +  in to_bool res
    1425 1427
    1426 1428 
     -- | Create an Int literal expression while ensuring the given Integer is in the
    1427 1429 
     -- target Int range
    ... ... @@ -3188,8 +3190,8 @@ is_binop op e = case e of
    3188 3190
    3189 3191 
     is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr)
    3190 3192 
     is_op op e = case e of
    3191 
    - App (OpVal op') x | op == op' -> Just x
    3192 
    - _                             -> Nothing
    3193 
    + App (PrimOpVar op') x | op == op' -> Just x
    3194 
    + _                                 -> Nothing
    3193 3195
    3194 3196 
     is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (CoreArg, CoreArg)
    3195 3197 
     is_add num_ops e = is_binop (numAdd num_ops) e
    ... ... @@ -3249,12 +3251,12 @@ is_expr_mul num_ops x e = if
    3249 3251
    3250 3252 
     -- | Match the application of a binary primop
    3251 3253 
     pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
    3252 
    -pattern BinOpApp x op y = OpVal op `App` x `App` y
    3254 
    +pattern BinOpApp x op y = PrimOpVar op `App` x `App` y
    3253 3255
    3254 3256 
     -- | Match a primop
    3255 
    -pattern OpVal:: PrimOp  -> Arg CoreBndr
    3256 
    -pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where
    3257 
    -   OpVal op = Var (primOpId op)
    3257 
    +pattern PrimOpVar:: PrimOp -> Arg CoreBndr
    3258 
    +pattern PrimOpVar op <- Var (isPrimOpId_maybe -> Just op) where
    3259 
    +   PrimOpVar op = Var (primOpId op)
    3258 3260
    3259 3261 
     -- | Match a literal
    3260 3262 
     pattern L :: Integer -> Arg CoreBndr
    ... ... @@ -3478,11 +3480,12 @@ caseRules _ _ = Nothing
    3478 3480 
     --
    3479 3481 
     -- It's important that occurrence info are present, hence the use of In* types.
    3480 3482 
     caseRules2
    3481 
    -   :: InExpr  -- ^ Scutinee
    3482 
    -   -> InId    -- ^ Case-binder
    3483 
    -   -> [InAlt] -- ^ Alternatives in standard (increasing) order
    3483 
    +   :: Platform  -- ^ Target platform
    3484 
    +   -> InExpr    -- ^ Scrutinee
    3485 
    +   -> InId      -- ^ Case-binder
    3486 
    +   -> [InAlt]   -- ^ Alternatives in standard (increasing) order
    3484 3487 
        -> Maybe (InExpr, InId, [InAlt])
    3485 
    -caseRules2 scrut bndr alts
    3488 
    +caseRules2 platform scrut bndr alts
    3486 3489
    3487 3490 
       -- case quotRem# x y of
    3488 3491 
       --    (# q, _ #) -> body
    ... ... @@ -3507,6 +3510,46 @@ caseRules2 scrut bndr alts
    3507 3510 
           | dead_r    -> Just $ (BinOpApp x quot y, q, [Alt DEFAULT [] body])
    3508 3511 
           | otherwise -> Nothing
    3509 3512
    3513 
    +  -- filter alternatives that are not in the scrutinee's inferred range
    3514 
    +  -- See (VRA1) in Note [Value range analysis] in GHC.Core.Opt.Range
    3515 
    +  | Just CaseUnlifted <- altsLevity alts
    3516 
    +  , range <- valueRange platform scrut
    3517 
    +  , range /= noRange
    3518 
    +  = let
    3519 
    +      -- filters alternatives that aren't in range
    3520 
    +      alt_in_range = \case
    3521 
    +          Alt DEFAULT _ _                  -> True
    3522 
    +          Alt (LitAlt (LitNumber _ n)) _ _ -> n `inRange` range
    3523 
    +          Alt (LitAlt (LitChar c)) _ _     -> fromIntegral (ord c) `inRange` range
    3524 
    +          Alt (LitAlt LitNullAddr) _ _     -> 0 `inRange` range
    3525 
    +          Alt _ _ _                        -> True -- defaults to True to be safe
    3526 
    +
    3527 
    +      rebuild_alts alt (b,n,alts')
    3528 
    +        -- `n` is the number of remaining alternatives, hence alternatives which
    3529 
    +        -- are in range. If there are as many alternatives in range as the range
    3530 
    +        -- size, it means we can remove the DEFAULT one (it is dead code).
    3531 
    +        --
    3532 
    +        -- Note that this works as written because we use `foldr` below and the
    3533 
    +        -- DEFAULT alternative is always at the head of the list of alternatives
    3534 
    +        -- when it is present (invariant).
    3535 
    +        | isDefaultAlt alt
    3536 
    +        , Just sz <- rangeSize range
    3537 
    +        , n == sz
    3538 
    +        = (True,n,alts')
    3539 
    +
    3540 
    +        -- filter alternatives that aren't in range
    3541 
    +        | not (alt_in_range alt)
    3542 
    +        = (True,n,alts')
    3543 
    +
    3544 
    +        | otherwise
    3545 
    +        = (b,n+1,alt:alts')
    3546 
    +
    3547 
    +      (alts_changed,_nalts,final_alts) = foldr rebuild_alts (False,0,[]) alts
    3548 
    +
    3549 
    +    in case alts_changed of
    3550 
    +        True  -> Just (scrut,bndr,final_alts)
    3551 
    +        False -> Nothing
    3552 
    +
    3510 3553 
       | otherwise
    3511 3554 
       = Nothing
    3512 3555
    ... ... @@ -3678,3 +3721,5 @@ an alternative that is unreachable.
    3678 3721
    3679 3722 
     You may wonder how this can happen: check out #15436.
    3680 3723 
     -}
    3724 
    +
    3725 
    +

  • compiler/GHC/Core/Opt/Range.hs
    1 
    +{-# LANGUAGE LambdaCase #-}
    2 
    +{-# LANGUAGE TypeApplications #-}
    3 
    +{-# LANGUAGE PatternSynonyms #-}
    4 
    +{-# LANGUAGE ViewPatterns #-}
    5 
    +{-# LANGUAGE AllowAmbiguousTypes #-}
    6 
    +{-# LANGUAGE MultiWayIf #-}
    7 
    +{-# LANGUAGE CPP #-}
    8 
    +
    9 
    +-- | Range analysis
    10 
    +--
    11 
    +-- See Note [Value range analysis]
    12 
    +module GHC.Core.Opt.Range
    13 
    +  ( Comparison(..)
    14 
    +  , Range(..)
    15 
    +  , noRange
    16 
    +  , valueRange
    17 
    +  , rangeIntersect
    18 
    +  , rangeCastFrom
    19 
    +  , inRange
    20 
    +  , rangeSize
    21 
    +  , rangeCmp
    22 
    +  , rangeLe
    23 
    +  , rangeGe
    24 
    +  , rangeLt
    25 
    +  , rangeGt
    26 
    +  , rangeOf
    27 
    +  , rangeWord
    28 
    +  , rangeWord8
    29 
    +  , rangeWord16
    30 
    +  , rangeWord32
    31 
    +  , rangeWord64
    32 
    +  , rangeChar
    33 
    +  , rangeInt
    34 
    +  , rangeInt8
    35 
    +  , rangeInt16
    36 
    +  , rangeInt32
    37 
    +  , rangeInt64
    38 
    +  )
    39 
    +where
    40 
    +
    41 
    +import GHC.Prelude
    42 
    +import GHC.Platform
    43 
    +import GHC.Core
    44 
    +import GHC.Builtin.PrimOps ( PrimOp(..) )
    45 
    +import GHC.Builtin.PrimOps.Ids (primOpId)
    46 
    +import GHC.Types.Literal
    47 
    +import GHC.Types.Id
    48 
    +#if defined(DEBUG)
    49 
    +import GHC.Utils.Outputable
    50 
    +import GHC.Utils.Panic
    51 
    +#endif
    52 
    +
    53 
    +import Data.Word
    54 
    +import Data.Int
    55 
    +import Data.Char (ord)
    56 
    +import Data.Maybe
    57 
    +
    58 
    +{-
    59 
    +Note [Value range analysis]
    60 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~
    61 
    +To perform some constant-folding optimisations, it is sometimes enough to know
    62 
    +the range (interval) of what an expression will evaluate to. For example,
    63 
    +consider the following expression:
    64 
    +
    65 
    +  word8ToWord x < 256
    66 
    +
    67 
    +Even without knowing the value of 'x', we know that:
    68 
    +
    69 
    +  - x is in range [0,255] because it is of type Word8
    70 
    +  - `word8ToWord x` is in range [0,255] despite being of type Word
    71 
    +  - `word8ToWord x < 256` is always `True`
    72 
    +
    73 
    +When a comparison primop is applied to two expressions (e.g. `ltWord# e1 e2`),
    74 
    +we infer the ranges of `e1` and `e2` and use them to try to statically compute
    75 
    +the result of the comparison (see `rangeCmp` function in this module).
    76 
    +
    77 
    +Value range analysis consists in inferring the range of a CoreExpr.
    78 
    +    valueRange :: Platform -> CoreExpr -> Range
    79 
    +is the workhorse function doing this analysis in this module. It traverses a
    80 
    +CoreExpr recursively to infer a range as precise as possible. It takes into
    81 
    +account:
    82 
    +
    83 
    +  - literals: a literal 'n' implies a range [n,n]
    84 
    +  - narrowing primops (e.g. Narrow8IntOp)
    85 
    +  - conversion primops (e.g. WordToIntOp)
    86 
    +  - addition and subtraction primops (e.g. Word32AddOp)
    87 
    +  - logical AND primops
    88 
    +  - variable unfoldings: for example, consider:
    89 
    +        case word8ToWord# x of y { ... case ltWord# y 256## { ... }}
    90 
    +    the value range analysis is triggered in a rewrite-rule for ltWord# on
    91 
    +    both `y` and `256##`. `y` is a variable so the analysis looks into its
    92 
    +    unfolding (here `word8ToWord# x`) to infer its range. It's obviously only
    93 
    +    possible when the variable has an unfolding. This unfolding, however, isn't
    94 
    +    required to be expandable as we're not expanding/inlining the unfolding,
    95 
    +    just computing its value range.
    96 
    +
    97 
    +VRA1: Filtering unreachable alternatives based on range analysis
    98 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    99 
    +Consider the following example:
    100 
    +
    101 
    +  case word8ToWord# x of
    102 
    +    123456# -> ...
    103 
    +    ...
    104 
    +
    105 
    +By applying value range analysis to the scrutinee, GHC infers that the 123456#
    106 
    +alternative is unreachable because it's out of the range [0,255] of the
    107 
    +scrutinee, hence it will never match.
    108 
    +
    109 
    +This filtering is done in GHC.Core.Opt.ConstantFold.caseRules2. See also T25718b
    110 
    +
    111 
    +
    112 
    +Limitation 1: no disjoint ranges
    113 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    114 
    +The current implementation doesn't support disjoint ranges hence it can't
    115 
    +precisely track some ranges. In these cases it falls back to a wider range.
    116 
    +For example: range analysis for `word8ToInt8 x` where x is in [100,130] would
    117 
    +need a disjoint range union to be represented as [100,127] U [-128,-126] because
    118 
    +of the overflow (130 > 127). See `rangeCastFrom` function in this module for the
    119 
    +implementation.
    120 
    +
    121 
    +Similarly, additions and subtractions may overflow/underflow. In these cases, we
    122 
    +would also need disjoint ranges to represent the resulting range. For example,
    123 
    +`x+1` where (x :: Word8) and x is in [100,255] would require a disjoint range
    124 
    +union: [0,0] U [101,255].
    125 
    +We use `rangeCastFrom` to handle these cases too: e.g. `x+1` (as described
    126 
    +above) is first computed to be in range [101,256] (ignoring the Word8 type), but
    127 
    +this range isn't in Word8's range [0,255], so conservatively we assume a range
    128 
    +[0,255] for `x+1` expression
    129 
    +
    130 
    +Limitation 2: limited top-down range information in alternatives
    131 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    132 
    +The value range analysis for a variable currently consists in applying the
    133 
    +analysis to the variable's unfolding (when it is available). This approach
    134 
    +doesn't return the most precise range possible in some cases. For example
    135 
    +consider:
    136 
    +
    137 
    +  case x ># 0# of
    138 
    +    1# -> {- Here we should know that x's range is > 0 -}
    139 
    +    0# -> {- ... and here <= 0 -}
    140 
    +
    141 
    +In both alternatives `x`'s unfolding (if any) is the same, yet we should be able
    142 
    +to infer a different range for `x` as a consequence of the pattern matching on
    143 
    +the comparison operator application.
    144 
    +
    145 
    +Possible future work: we could imagine extending the unfolding information to
    146 
    +include range information. Then a top-down pass could compute and store more
    147 
    +precise range information in cases like this one. Implementing this should
    148 
    +change the output of the T25718a test.
    149 
    +
    150 
    +-}
    151 
    +
    152 
    +data Comparison = Gt | Ge | Lt | Le deriving (Show)
    153 
    +
    154 
    +
    155 
    +-- | A range (minBound,maxBound)
    156 
    +--
    157 
    +-- Bounds may not be known.
    158 
    +data Range
    159 
    +  = MkRange {-# UNPACK #-} !(Maybe Integer) -- ^ Lower bound: Nothing means unbounded below
    160 
    +            {-# UNPACK #-} !(Maybe Integer) -- ^ Upper bound: Nothing means unbounded above
    161 
    +  deriving (Eq,Show)
    162 
    +
    163 
    +pattern Range :: Maybe Integer -> Maybe Integer -> Range
    164 
    +pattern Range x y <- MkRange x y
    165 
    +  where
    166 
    +    Range x y = mkRange x y
    167 
    +
    168 
    +{-# COMPLETE Range #-}
    169 
    +
    170 
    +mkRange :: Maybe Integer -> Maybe Integer -> Range
    171 
    +mkRange = \cases
    172 
    +#if defined(DEBUG)
    173 
    +  -- check that the bounds of the range are well ordered.
    174 
    +  (Just x) (Just y) | x > y -> pprPanic "Invalid range" (ppr (x,y))
    175 
    +#endif
    176 
    +  x y -> MkRange x y
    177 
    +
    178 
    +
    179 
    +-- | Compute the intersection of two overlapping ranges.
    180 
    +--
    181 
    +-- If the two ranges don't overlap, result is undefined.
    182 
    +rangeIntersect :: Range -> Range -> Range
    183 
    +rangeIntersect (Range mi1 ma1) (Range mi2 ma2) = Range mi ma
    184 
    +  where
    185 
    +    merge op = \cases
    186 
    +      Nothing  Nothing  -> Nothing
    187 
    +      Nothing  v        -> v
    188 
    +      v        Nothing  -> v
    189 
    +      (Just a) (Just b) -> Just (op a b)
    190 
    +    mi = merge max mi1 mi2
    191 
    +    ma = merge min ma1 ma2
    192 
    +
    193 
    +-- | Used for casts that share representation over a sub-range (e.g. [0,127] for
    194 
    +-- Word8# ([0,255]) and Int8# ([-128,127]))
    195 
    +--
    196 
    +-- If from_range isn't fully included into to_range, then we return to_range.
    197 
    +-- That's because for now we don't have a way to track disjoined ranges.
    198 
    +--    E.g. if we wanted to cast [-1,10] (Int8) into [0,255] (Word8), we would
    199 
    +--    need to represent a range union: [0,10] U [255,255] (Word8)
    200 
    +--
    201 
    +-- We also use this function to ensure that the result of an arithmetic
    202 
    +-- operation on ranges didn't overflow/underflow.
    203 
    +rangeCastFrom :: Range -> Range -> Range
    204 
    +rangeCastFrom to_range from_range = case from_range of
    205 
    +  Range (Just mi) (Just ma)
    206 
    +    | mi `inRange` to_range
    207 
    +    , ma `inRange` to_range
    208 
    +    -> from_range
    209 
    +  _ -> to_range
    210 
    +
    211 
    +inRange :: Integer -> Range -> Bool
    212 
    +inRange x = \case
    213 
    +  Range Nothing   Nothing   -> True
    214 
    +  Range (Just mi) Nothing   -> x >= mi
    215 
    +  Range (Just mi) (Just ma) -> x >= mi && x <= ma
    216 
    +  Range Nothing   (Just ma) -> x <= ma
    217 
    +
    218 
    +rangeSize :: Range -> Maybe Integer
    219 
    +rangeSize = \case
    220 
    +  Range (Just mi) (Just ma) -> Just (ma-mi+1)
    221 
    +  _                         -> Nothing
    222 
    +
    223 
    +-- | Addition of two ranges
    224 
    +rangeAdd :: Range -> Range -> Range
    225 
    +rangeAdd (Range mi1 ma1) (Range mi2 ma2) = Range (add mi1 mi2) (add ma1 ma2)
    226 
    +  where
    227 
    +    add = \cases
    228 
    +      (Just v) (Just u) -> Just (v+u)
    229 
    +      _        _        -> Nothing
    230 
    +
    231 
    +-- | Subtraction of two ranges
    232 
    +rangeSub :: Range -> Range -> Range
    233 
    +rangeSub (Range mi1 ma1) (Range mi2 ma2) = Range (sub mi1 ma2) (sub ma1 mi2)
    234 
    +  where
    235 
    +    sub = \cases
    236 
    +      (Just v) (Just u) -> Just (v-u)
    237 
    +      _        _        -> Nothing
    238 
    +
    239 
    +-- | Logical AND of two ranges at the given type
    240 
    +{-# NOINLINE rangeAnd #-}
    241 
    +rangeAnd :: forall a. (FiniteBits a, Bounded a, Integral a) => Range -> Range -> Range
    242 
    +rangeAnd (Range mi1' ma1') (Range mi2' ma2') = final_range
    243 
    +  where
    244 
    +    -- convert the Integer range bounds into the given type with FiniteBits
    245 
    +    -- because we need to work on the actual representation, not on the Integer
    246 
    +    -- value. We also take the minBound/maxBound when a bound is missing.
    247 
    +    mi1, mi2, ma1, ma2 :: a
    248 
    +    mi1 = fromMaybe minBound (fromInteger <$> mi1')
    249 
    +    mi2 = fromMaybe minBound (fromInteger <$> mi2')
    250 
    +    ma1 = fromMaybe maxBound (fromInteger <$> ma1')
    251 
    +    ma2 = fromMaybe maxBound (fromInteger <$> ma2')
    252 
    +
    253 
    +    -- we compute the minimal number of leading zeros for each range.
    254 
    +    -- Then we take the maximum of both values: this is the number of leading
    255 
    +    -- bits that will always be set to zero in the resulting range.
    256 
    +    clz1 = min (countLeadingZeros mi1) (countLeadingZeros ma1)
    257 
    +    clz2 = min (countLeadingZeros mi2) (countLeadingZeros ma2)
    258 
    +    clzr = max clz1 clz2
    259 
    +
    260 
    +    -- we generate a mask for the bits that might be set to 1 in the resulting
    261 
    +    -- range and apply it to every bound. It may reorder the bounds: e.g.
    262 
    +    --    ([-1,1] :: Int8) .&. 0xF ==> [15,1] ==> [1,15]
    263 
    +    -- so we have to be careful when we reconstruct the final range
    264 
    +    mask :: a
    265 
    +    mask = if
    266 
    +      | clzr == finiteBitSize mi1 -> zeroBits
    267 
    +      | clzr == 0                 -> complement zeroBits
    268 
    +      | otherwise                 -> (1 `unsafeShiftL` (finiteBitSize mi1 - clzr)) - 1
    269 
    +              -- we can't use: complement zeroBits `shiftR` clzr
    270 
    +              -- because shiftR performs sign-extension for signed types
    271 
    +    mk_final_bound x = toInteger (x .&. mask)
    272 
    +
    273 
    +    fmi1 = mk_final_bound mi1
    274 
    +    fmi2 = mk_final_bound mi2
    275 
    +    fma1 = mk_final_bound ma1
    276 
    +    fma2 = mk_final_bound ma2
    277 
    +    fmi = fmi1 `min` fmi2 `min` fma1 `min` fma2
    278 
    +    fma = fmi1 `max` fmi2 `max` fma1 `max` fma2
    279 
    +    final_range = Range (Just fmi) (Just fma)
    280 
    +
    281 
    +
    282 
    +noRange :: Range
    283 
    +noRange = Range Nothing Nothing
    284 
    +
    285 
    +rangeOf :: forall a. (Bounded a, Integral a) => Range
    286 
    +rangeOf = Range (Just (toInteger (minBound :: a))) (Just (toInteger (maxBound :: a)))
    287 
    +
    288 
    +rangeWord8, rangeWord16, rangeWord32, rangeWord64 :: Range
    289 
    +rangeWord8  = rangeOf @Word8
    290 
    +rangeWord16 = rangeOf @Word16
    291 
    +rangeWord32 = rangeOf @Word32
    292 
    +rangeWord64 = rangeOf @Word64
    293 
    +
    294 
    +rangeInt8, rangeInt16, rangeInt32, rangeInt64 :: Range
    295 
    +rangeInt8  = rangeOf @Int8
    296 
    +rangeInt16 = rangeOf @Int16
    297 
    +rangeInt32 = rangeOf @Int32
    298 
    +rangeInt64 = rangeOf @Int64
    299 
    +
    300 
    +rangeWord, rangeInt, rangeChar :: Platform -> Range
    301 
    +rangeWord p = case platformWordSize p of
    302 
    +  PW4 -> rangeWord32
    303 
    +  PW8 -> rangeWord64
    304 
    +rangeInt p = case platformWordSize p of
    305 
    +  PW4 -> rangeInt32
    306 
    +  PW8 -> rangeInt64
    307 
    +
    308 
    +rangeChar = rangeInt -- a Char# is represented internally as an Int#
    309 
    +
    310 
    +-- | Compare two ranges
    311 
    +--
    312 
    +-- See Note [Value range analysis]
    313 
    +rangeCmp :: Comparison -> Range -> Range -> Maybe Bool
    314 
    +rangeCmp cmp rx ry = case cmp of
    315 
    +  Gt -> rx `rangeGt` ry
    316 
    +  Ge -> rx `rangeGe` ry
    317 
    +  Le -> rx `rangeLe` ry
    318 
    +  Lt -> rx `rangeLt` ry
    319 
    +
    320 
    +rangeGt :: Range -> Range -> Maybe Bool
    321 
    +rangeGt = \cases
    322 
    +  (Range (Just mi) _) (Range _ (Just ma)) | mi > ma  -> Just True
    323 
    +  (Range _ (Just ma)) (Range (Just mi) _) | ma <= mi -> Just False
    324 
    +  _ _ -> Nothing
    325 
    +
    326 
    +rangeLt :: Range -> Range -> Maybe Bool
    327 
    +rangeLt = \cases
    328 
    +  (Range _ (Just ma)) (Range (Just mi) _) | ma < mi  -> Just True
    329 
    +  (Range (Just mi) _) (Range _ (Just ma)) | mi >= ma -> Just False
    330 
    +  _ _ -> Nothing
    331 
    +
    332 
    +rangeGe :: Range -> Range -> Maybe Bool
    333 
    +rangeGe = \cases
    334 
    +  (Range (Just mi) _) (Range _ (Just ma)) | mi >= ma -> Just True
    335 
    +  (Range _ (Just ma)) (Range (Just mi) _) | ma < mi  -> Just False
    336 
    +  _ _ -> Nothing
    337 
    +
    338 
    +rangeLe :: Range -> Range -> Maybe Bool
    339 
    +rangeLe = \cases
    340 
    +  (Range _ (Just ma)) (Range (Just mi) _) | ma <= mi -> Just True
    341 
    +  (Range (Just mi) _) (Range _ (Just ma)) | mi > ma  -> Just False
    342 
    +  _ _ -> Nothing
    343 
    +
    344 
    +
    345 
    +-- | Return the Integer range of an expression
    346 
    +valueRange :: Platform -> CoreExpr -> Range
    347 
    +valueRange platform = value_range 10
    348 
    +  where
    349 
    +    -- we use some fuel value to avoid recursing infinitely
    350 
    +    value_range :: Word -> CoreExpr -> Range
    351 
    +    value_range fuel expr
    352 
    +      | fuel == 0 = noRange
    353 
    +      | otherwise = case expr of
    354 
    +          Lit (LitNumber _ n) -> Range (Just n) (Just n)
    355 
    +          Lit (LitChar c) -> let n = fromIntegral (ord c) in Range (Just n) (Just n)
    356 
    +          Lit _ -> noRange
    357 
    +          Var v
    358 
    +            | Just ebody <- expandUnfolding_always (idUnfolding v)
    359 
    +            -> value_range (fuel-1) ebody
    360 
    +            | otherwise
    361 
    +            -> noRange
    362 
    +          PrimOpVar op `App` x ->
    363 
    +            let sub_range = value_range (fuel-1) x
    364 
    +            in case op of
    365 
    +              Word8ToWordOp  -> rangeWord8  `rangeIntersect` sub_range
    366 
    +              Word16ToWordOp -> rangeWord16 `rangeIntersect` sub_range
    367 
    +              Word32ToWordOp -> rangeWord32 `rangeIntersect` sub_range
    368 
    +              Word64ToWordOp -> rangeWord platform `rangeIntersect` sub_range
    369 
    +              WordToWord8Op  -> rangeWord8  `rangeIntersect` sub_range
    370 
    +              WordToWord16Op -> rangeWord16 `rangeIntersect` sub_range
    371 
    +              WordToWord32Op -> rangeWord32 `rangeIntersect` sub_range
    372 
    +              WordToWord64Op -> rangeWord platform `rangeIntersect` sub_range
    373 
    +
    374 
    +              Word8ToInt8Op   -> rangeInt8  `rangeCastFrom` (rangeWord8  `rangeIntersect` sub_range)
    375 
    +              Word16ToInt16Op -> rangeInt16 `rangeCastFrom` (rangeWord16 `rangeIntersect` sub_range)
    376 
    +              Word32ToInt32Op -> rangeInt32 `rangeCastFrom` (rangeWord32 `rangeIntersect` sub_range)
    377 
    +              Word64ToInt64Op -> rangeInt64 `rangeCastFrom` (rangeWord64 `rangeIntersect` sub_range)
    378 
    +              WordToIntOp     -> rangeInt platform `rangeCastFrom` (rangeWord platform  `rangeIntersect` sub_range)
    379 
    +
    380 
    +              Int8ToWord8Op   -> rangeWord8  `rangeCastFrom` (rangeInt8  `rangeIntersect` sub_range)
    381 
    +              Int16ToWord16Op -> rangeWord16 `rangeCastFrom` (rangeInt16 `rangeIntersect` sub_range)
    382 
    +              Int32ToWord32Op -> rangeWord32 `rangeCastFrom` (rangeInt32 `rangeIntersect` sub_range)
    383 
    +              Int64ToWord64Op -> rangeWord64 `rangeCastFrom` (rangeInt64 `rangeIntersect` sub_range)
    384 
    +              IntToWordOp     -> rangeWord platform `rangeCastFrom` (rangeInt platform `rangeIntersect` sub_range)
    385 
    +
    386 
    +              Narrow8IntOp   -> rangeInt8 `rangeIntersect` sub_range
    387 
    +              Narrow16IntOp  -> rangeInt16 `rangeIntersect` sub_range
    388 
    +              Narrow32IntOp  -> rangeInt32 `rangeIntersect` sub_range
    389 
    +              Narrow8WordOp  -> rangeWord8 `rangeIntersect` sub_range
    390 
    +              Narrow16WordOp -> rangeWord16 `rangeIntersect` sub_range
    391 
    +              Narrow32WordOp -> rangeWord32 `rangeIntersect` sub_range
    392 
    +
    393 
    +              OrdOp          -> sub_range
    394 
    +              ChrOp          -> sub_range
    395 
    +
    396 
    +              _              -> noRange
    397 
    +
    398 
    +          PrimOpVar op `App` x `App` y ->
    399 
    +            let range_x = value_range (fuel-1) x
    400 
    +                range_y = value_range (fuel-1) y
    401 
    +            in case op of
    402 
    +              Word8AddOp  -> rangeWord8 `rangeCastFrom` rangeAdd range_x range_y
    403 
    +              Word16AddOp -> rangeWord16 `rangeCastFrom` rangeAdd range_x range_y
    404 
    +              Word32AddOp -> rangeWord32 `rangeCastFrom` rangeAdd range_x range_y
    405 
    +              Word64AddOp -> rangeWord64 `rangeCastFrom` rangeAdd range_x range_y
    406 
    +              WordAddOp   -> rangeWord platform `rangeCastFrom` rangeAdd range_x range_y
    407 
    +              Int8AddOp   -> rangeInt8 `rangeCastFrom` rangeAdd range_x range_y
    408 
    +              Int16AddOp  -> rangeInt16 `rangeCastFrom` rangeAdd range_x range_y
    409 
    +              Int32AddOp  -> rangeInt32 `rangeCastFrom` rangeAdd range_x range_y
    410 
    +              Int64AddOp  -> rangeInt64 `rangeCastFrom` rangeAdd range_x range_y
    411 
    +              IntAddOp    -> rangeInt platform `rangeCastFrom` rangeAdd range_x range_y
    412 
    +
    413 
    +              Word8SubOp  -> rangeWord8 `rangeCastFrom` rangeSub range_x range_y
    414 
    +              Word16SubOp -> rangeWord16 `rangeCastFrom` rangeSub range_x range_y
    415 
    +              Word32SubOp -> rangeWord32 `rangeCastFrom` rangeSub range_x range_y
    416 
    +              Word64SubOp -> rangeWord64 `rangeCastFrom` rangeSub range_x range_y
    417 
    +              WordSubOp   -> rangeWord platform `rangeCastFrom` rangeSub range_x range_y
    418 
    +              Int8SubOp   -> rangeInt8 `rangeCastFrom` rangeSub range_x range_y
    419 
    +              Int16SubOp  -> rangeInt16 `rangeCastFrom` rangeSub range_x range_y
    420 
    +              Int32SubOp  -> rangeInt32 `rangeCastFrom` rangeSub range_x range_y
    421 
    +              Int64SubOp  -> rangeInt64 `rangeCastFrom` rangeSub range_x range_y
    422 
    +              IntSubOp    -> rangeInt platform `rangeCastFrom` rangeSub range_x range_y
    423 
    +
    424 
    +              IntAndOp -> case platformWordSize platform of
    425 
    +                PW4 -> rangeAnd @Int32 range_x range_y
    426 
    +                PW8 -> rangeAnd @Int64 range_x range_y
    427 
    +              WordAndOp -> case platformWordSize platform of
    428 
    +                PW4 -> rangeAnd @Word32 range_x range_y
    429 
    +                PW8 -> rangeAnd @Word64 range_x range_y
    430 
    +              Word8AndOp  -> rangeAnd @Word8  range_x range_y
    431 
    +              Word16AndOp -> rangeAnd @Word16 range_x range_y
    432 
    +              Word32AndOp -> rangeAnd @Word32 range_x range_y
    433 
    +              Word64AndOp -> rangeAnd @Word64 range_x range_y
    434 
    +
    435 
    +              -- TODO: shifts, or, clz, ctz, negate...
    436 
    +              _ -> noRange
    437 
    +
    438 
    +          App {}      -> noRange
    439 
    +          Lam {}      -> noRange
    440 
    +          Let {}      -> noRange
    441 
    +          Case {}     -> noRange
    442 
    +          Cast e _    -> value_range fuel e
    443 
    +          Tick _ e    -> value_range fuel e
    444 
    +          Type {}     -> noRange
    445 
    +          Coercion {} -> noRange
    446 
    +
    447 
    +-- | Match a primop
    448 
    +pattern PrimOpVar:: PrimOp -> Arg CoreBndr
    449 
    +pattern PrimOpVar op <- Var (isPrimOpId_maybe -> Just op) where
    450 
    +   PrimOpVar op = Var (primOpId op)
    451 
    +

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -3232,18 +3232,19 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont
    3232 3232 
                Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont'
    3233 3233 
                Nothing                -> reallyRebuildCase env scrut case_bndr alts cont }
    3234 3234
    3235 
    +  where
    3236 
    +    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]
    3237 
    +    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
    3238 
    +
    3239 
    +rebuildCase env scrut case_bndr alts cont
    3235 3240 
     --------------------------------------------------
    3236 3241 
     --      3. Primop-related case-rules
    3237 3242 
     --------------------------------------------------
    3238 3243
    3239 
    -  |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts
    3244 
    +  | Just (scrut', case_bndr', alts') <- caseRules2 (sePlatform env) scrut case_bndr alts
    3240 3245 
       = reallyRebuildCase env scrut' case_bndr' alts' cont
    3241 3246
    3242 
    -  where
    3243 
    -    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]
    3244 
    -    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
    3245 
    -
    3246 
    -rebuildCase env scrut case_bndr alts cont
    3247 
    +  | otherwise
    3247 3248 
       = reallyRebuildCase env scrut case_bndr alts cont
    3248 3249
    3249 3250 
     doCaseToLet :: OutExpr          -- Scrutinee

  • compiler/GHC/Prelude/Basic.hs
    ... ... @@ -68,9 +68,6 @@ import qualified GHC.Data.List.NonEmpty as NE
    68 68 
     import GHC.Stack.Types (HasCallStack)
    69 69
    70 70 
     import GHC.Bits as Bits hiding (bit, shiftL, shiftR, setBit, clearBit)
    71 
    -# if defined(DEBUG)
    72 
    -import qualified GHC.Bits as Bits (shiftL, shiftR)
    73 
    -# endif
    74 71
    75 72
    76 73 
     {- Note [Default to unsafe shifts inside GHC]
    ... ... @@ -99,11 +96,29 @@ See also #19618
    99 96 
     -- We always want the Data.Bits method to show up for rules etc.
    100 97 
     {-# INLINE shiftL #-}
    101 98 
     {-# INLINE shiftR #-}
    102 
    -shiftL, shiftR :: Bits.Bits a => a -> Int -> a
    103 99 
     #if defined(DEBUG)
    104 
    -shiftL = Bits.shiftL
    105 
    -shiftR = Bits.shiftR
    100 
    +-- In debug mode we explicitly check that the shift value is valid for
    101 
    +-- unsafeShiftL/R. Otherwise we may have bugs only showing up in non-DEBUG
    102 
    +-- builds.
    103 
    +shiftL, shiftR :: (HasCallStack, Bits.Bits a) => a -> Int -> a
    104 
    +shiftL x n
    105 
    +  | n < 0
    106 
    +  = error ("shiftL: negative shift value: " ++ show n)
    107 
    +  | Just s <- bitSizeMaybe x
    108 
    +  , n >= s
    109 
    +  = error ("shiftL: shift value greater than bitSize: " ++ show n ++ " >= " ++ show s)
    110 
    +  | otherwise
    111 
    +  = Bits.unsafeShiftL x n
    112 
    +shiftR x n
    113 
    +  | n < 0
    114 
    +  = error ("shiftR: negative shift value: " ++ show n)
    115 
    +  | Just s <- bitSizeMaybe x
    116 
    +  , n >= s
    117 
    +  = error ("shiftR: shift value greater than bitSize: " ++ show n ++ " >= " ++ show s)
    118 
    +  | otherwise
    119 
    +  = Bits.unsafeShiftR x n
    106 120 
     #else
    121 
    +shiftL, shiftR :: Bits.Bits a => a -> Int -> a
    107 122 
     shiftL = Bits.unsafeShiftL
    108 123 
     shiftR = Bits.unsafeShiftR
    109 124 
     #endif

  • compiler/GHC/StgToCmm/Expr.hs
    ... ... @@ -729,15 +729,13 @@ cgAlts gc_plan bndr (PrimAlt _) alts
    729 729 
             ; tagged_cmms <- cgAltRhss gc_plan bndr alts
    730 730
    731 731 
             ; let bndr_reg = CmmLocal (idToReg platform bndr)
    732 
    -              deflt = case tagged_cmms of
    733 
    -                  (DEFAULT,deflt):_ -> deflt
    734 
    -                  _ -> panic "cgAlts PrimAlt"
    735 
    -                -- PrimAlts always have a DEFAULT case
    736 
    -                -- and it always comes first
    732 
    +              mdeflt = case tagged_cmms of
    733 
    +                  (DEFAULT,deflt):_ -> Just deflt
    734 
    +                  _ -> Nothing
    737 735
    738 736 
                   tagged_cmms' = [(lit,code)
    739 737 
                                  | (LitAlt lit, code) <- tagged_cmms]
    740 
    -        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt
    738 
    +        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' mdeflt
    741 739 
             ; return AssignedDirectly }
    742 740
    743 741 
     cgAlts gc_plan bndr (AlgAlt tycon) alts

  • compiler/GHC/StgToCmm/Utils.hs
    ... ... @@ -478,41 +478,49 @@ divideBranches branches = (lo_branches, mid, hi_branches)
    478 478 
     --------------
    479 479 
     emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
    480 480 
                    -> [(Literal, CmmAGraphScoped)] -- Tagged branches
    481 
    -               -> CmmAGraphScoped              -- Default branch (always)
    481 
    +               -> Maybe CmmAGraphScoped        -- Default branch
    482 482 
                    -> FCode ()                     -- Emit the code
    483 
    -emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
    484 
    -emitCmmLitSwitch scrut branches@(branch:_) deflt = do
    483 
    +emitCmmLitSwitch _scrut [] (Just deflt) = emit $ fst deflt
    484 
    +emitCmmLitSwitch _scrut [] Nothing      = panic "emitCmmLitSwitch: expected DEFAULT branch (no alts)"
    485 
    +emitCmmLitSwitch scrut branches@(branch:_) mdeflt = do
    485 486 
         scrut' <- assignTemp' scrut
    486 487 
         join_lbl <- newBlockId
    487 
    -    deflt_lbl <- label_code join_lbl deflt
    488 488 
         branches_lbls <- label_branches join_lbl branches
    489 489
    490 490 
         platform <- getPlatform
    491 491 
         let cmm_ty = cmmExprType platform scrut
    492 492 
             rep = typeWidth cmm_ty
    493 493
    494 
    -    -- We find the necessary type information in the literals in the branches
    495 
    -    let (signed,range) = case branch of
    496 
    -          (LitNumber nt _, _) -> (signed,range)
    497 
    -            where
    498 
    -              signed = litNumIsSigned nt
    499 
    -              range  = case litNumRange platform nt of
    500 
    -                        (Just mi, Just ma) -> (mi,ma)
    501 
    -                                              -- unbounded literals (Natural and
    502 
    -                                              -- Integer) must have been
    503 
    -                                              -- lowered at this point
    504 
    -                        partial_bounds     -> pprPanic "Unexpected unbounded literal range"
    505 
    -                                                       (ppr partial_bounds)
    506 
    -               -- assuming native word range
    507 
    -          _ -> (False, (0, platformMaxWord platform))
    508 
    -
    509 494 
         if isFloatType cmm_ty
    510 
    -    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
    511 
    -    else emit $ mk_discrete_switch
    495 
    +    then do
    496 
    +      deflt_lbl <- case mdeflt of
    497 
    +                    Nothing    -> panic "emitCmmLitSwitch: expected DEFAULT branch (float switch)"
    498 
    +                    Just deflt -> label_code join_lbl deflt
    499 
    +      emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
    500 
    +    else do
    501 
    +      -- We find the necessary type information in the literals in the branches
    502 
    +      let (signed,range) = case branch of
    503 
    +            (LitNumber nt _, _) -> (signed,range)
    504 
    +              where
    505 
    +                signed = litNumIsSigned nt
    506 
    +                range  = case litNumRange platform nt of
    507 
    +                          (Just mi, Just ma) -> (mi,ma)
    508 
    +                                                -- unbounded literals (Natural and
    509 
    +                                                -- Integer) must have been
    510 
    +                                                -- lowered at this point
    511 
    +                          partial_bounds     -> pprPanic "Unexpected unbounded literal range"
    512 
    +                                                         (ppr partial_bounds)
    513 
    +                 -- assuming native word range
    514 
    +            _ -> (False, (0, platformMaxWord platform))
    515 
    +
    516 
    +      mdeflt_lbl <- case mdeflt of
    517 
    +        Nothing    -> pure Nothing
    518 
    +        Just deflt -> Just <$> label_code join_lbl deflt
    519 
    +      emit $ mk_discrete_switch
    512 520 
             signed
    513 521 
             scrut'
    514 522 
             [(litValue lit,l) | (lit,l) <- branches_lbls]
    515 
    -        (Just deflt_lbl)
    523 
    +        mdeflt_lbl
    516 524 
             range
    517 525 
         emitLabel join_lbl
    518 526

  • compiler/ghc.cabal.in
    ... ... @@ -384,6 +384,7 @@ Library
    384 384 
             GHC.Core.Opt.OccurAnal
    385 385 
             GHC.Core.Opt.Pipeline
    386 386 
             GHC.Core.Opt.Pipeline.Types
    387 
    +        GHC.Core.Opt.Range
    387 388 
             GHC.Core.Opt.SetLevels
    388 389 
             GHC.Core.Opt.Simplify
    389 390 
             GHC.Core.Opt.Simplify.Env

  • libraries/ghc-internal/src/GHC/Internal/Char.hs
    ... ... @@ -14,13 +14,19 @@ import GHC.Internal.Classes (eqChar, neChar)
    14 14 
     import GHC.Internal.Base (otherwise, (++))
    15 15 
     import GHC.Internal.Err (errorWithoutStackTrace)
    16 16 
     import GHC.Internal.Show
    17 
    -import GHC.Internal.Prim (chr#, int2Word#, leWord#)
    17 
    +import GHC.Internal.Prim (chr#, int2Word#, leWord#, Int#, Char#)
    18 18 
     import GHC.Internal.Types (Char(..), Int(..), isTrue#)
    19 19
    20 20 
     -- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.
    21 21 
     chr :: Int -> Char
    22 
    -chr i@(I# i#)
    23 
    - | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = C# (chr# i#)
    24 
    - | otherwise
    25 
    -    = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")
    22 
    +chr (I# i#) = C# (safe_chr# i#)
    26 23
    24 
    +{-# INLINABLE safe_chr# #-}
    25 
    +safe_chr# :: Int# -> Char#
    26 
    +safe_chr# i#
    27 
    + | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = chr# i#
    28 
    + | otherwise = chr_error i#
    29 
    +
    30 
    +{-# NOINLINE chr_error #-}
    31 
    +chr_error :: Int# -> Char#
    32 
    +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
    30 30 
     GHC.Core.Opt.CallerCC.Types
    31 31 
     GHC.Core.Opt.ConstantFold
    32 32 
     GHC.Core.Opt.OccurAnal
    33 
    +GHC.Core.Opt.Range
    33 34 
     GHC.Core.PatSyn
    34 35 
     GHC.Core.Ppr
    35 36 
     GHC.Core.Predicate

  • testsuite/tests/count-deps/CountDepsParser.stdout
    ... ... @@ -30,6 +30,7 @@ GHC.Core.Opt.Arity
    30 30 
     GHC.Core.Opt.CallerCC.Types
    31 31 
     GHC.Core.Opt.ConstantFold
    32 32 
     GHC.Core.Opt.OccurAnal
    33 
    +GHC.Core.Opt.Range
    33 34 
     GHC.Core.PatSyn
    34 35 
     GHC.Core.Ppr
    35 36 
     GHC.Core.Predicate

  • testsuite/tests/simplCore/should_compile/T19166.hs
    1 
    +module T19166 where
    2 
    +
    3 
    +import Data.Bits
    4 
    +
    5 
    +foo :: Int -> Int
    6 
    +foo x = case x .&. 0x3 of
    7 
    +    0 -> 0
    8 
    +    1 -> 1
    9 
    +    2 -> 2
    10 
    +    3 -> 3
    11 
    +    4 -> 4 -- unreachable branch but not removed
    12 
    +    _ -> undefined -- required for the PM checker but unreachable too

  • testsuite/tests/simplCore/should_compile/T19166.stderr
    1 
    +
    2 
    +==================== Tidy Core ====================
    3 
    +Result size of Tidy Core
    4 
    +  = {terms: 29, types: 10, coercions: 0, joins: 0/0}
    5 
    +
    6 
    +foo4 = I# 0#
    7 
    +
    8 
    +foo3 = I# 1#
    9 
    +
    10 
    +foo2 = I# 2#
    11 
    +
    12 
    +foo1 = I# 3#
    13 
    +
    14 
    +foo
    15 
    +  = \ x ->
    16 
    +      case x of { I# x# ->
    17 
    +      case andI# x# 3# of {
    18 
    +        0# -> foo4;
    19 
    +        1# -> foo3;
    20 
    +        2# -> foo2;
    21 
    +        3# -> foo1
    22 
    +      }
    23 
    +      }
    24 
    +
    25 
    +
    26 
    +

  • testsuite/tests/simplCore/should_compile/T25718.hs
    1 
    +module T25718 where
    2 
    +
    3 
    +import Data.Char
    4 
    +import Data.Word
    5 
    +
    6 
    +word8ToChar :: Word8 -> Char
    7 
    +word8ToChar = chr . fromIntegral
    8 
    +
    9 
    +isAsciiChar :: Char -> Bool
    10 
    +isAsciiChar = (< 256) . ord
    11 
    +
    12 
    +foo :: Word8 -> Bool
    13 
    +foo = isAsciiChar . word8ToChar
    14 
    +
    15 
    +bar :: Word8 -> Bool
    16 
    +bar x = fromIntegral x <= 255

  • testsuite/tests/simplCore/should_compile/T25718.stderr
    1 
    +
    2 
    +==================== Tidy Core ====================
    3 
    +Result size of Tidy Core
    4 
    +  = {terms: 28, types: 18, coercions: 0, joins: 0/0}
    5 
    +
    6 
    +isAsciiChar
    7 
    +  = \ x -> case x of { C# c# -> tagToEnum# (<# (ord# c#) 256#) }
    8 
    +
    9 
    +bar = \ x -> case x of { W8# x# -> True }
    10 
    +
    11 
    +word8ToChar
    12 
    +  = \ x ->
    13 
    +      case x of { W8# x# -> C# (chr# (word2Int# (word8ToWord# x#))) }
    14 
    +
    15 
    +foo = bar
    16 
    +
    17 
    +
    18 
    +

  • testsuite/tests/simplCore/should_compile/T25718a.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +module T25718a where
    3 
    +
    4 
    +import GHC.Exts
    5 
    +
    6 
    +-- Test a limitation of range analysis: if we improve the analysis, it could
    7 
    +-- become a constant function `\_ -> True`
    8 
    +foo :: Int# -> Bool
    9 
    +foo x = case isTrue# (x ># 0#) of
    10 
    +  True  -> {- Here we should know that x's range is > 0 -}
    11 
    +           not (isTrue# (x <=# 0#)) -- we write it this way to avoid CSE for `x ># 0#` to kick in
    12 
    +  False -> {- ... and here <= 0 -}
    13 
    +           isTrue# (x <=# 0#)

  • testsuite/tests/simplCore/should_compile/T25718a.stderr
    1 
    +
    2 
    +==================== Tidy Core ====================
    3 
    +Result size of Tidy Core
    4 
    +  = {terms: 20, types: 6, coercions: 0, joins: 0/0}
    5 
    +
    6 
    +foo
    7 
    +  = \ x ->
    8 
    +      case ># x 0# of {
    9 
    +        __DEFAULT -> tagToEnum# (<=# x 0#);
    10 
    +        1# ->
    11 
    +          case <=# x 0# of {
    12 
    +            __DEFAULT -> True;
    13 
    +            1# -> False
    14 
    +          }
    15 
    +      }
    16 
    +
    17 
    +
    18 
    +

  • testsuite/tests/simplCore/should_compile/T25718b.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +module T25718a where
    3 
    +
    4 
    +import GHC.Exts
    5 
    +
    6 
    +-- Test that value range analysis is used to remove unreachable alternatives
    7 
    +
    8 
    +foo :: Word8# -> Bool
    9 
    +foo x = case word8ToWord# x of
    10 
    +  123456## -> False
    11 
    +  456789## -> False
    12 
    +  42##     -> False
    13 
    +  _        -> True
    14 
    +
    15 
    +bar :: Word# -> Bool
    16 
    +bar x = case x `and#` 0xF## of
    17 
    +  123456## -> False
    18 
    +  456789## -> False
    19 
    +  0xF0##   -> False
    20 
    +  0x05##   -> False
    21 
    +  _        -> True

  • testsuite/tests/simplCore/should_compile/T25718b.stderr
    1 
    +
    2 
    +==================== Tidy Core ====================
    3 
    +Result size of Tidy Core
    4 
    +  = {terms: 19, types: 8, coercions: 0, joins: 0/0}
    5 
    +
    6 
    +foo
    7 
    +  = \ x ->
    8 
    +      case word8ToWord# x of {
    9 
    +        __DEFAULT -> True;
    10 
    +        42## -> False
    11 
    +      }
    12 
    +
    13 
    +bar
    14 
    +  = \ x ->
    15 
    +      case and# x 15## of {
    16 
    +        __DEFAULT -> True;
    17 
    +        5## -> False
    18 
    +      }
    19 
    +
    20 
    +
    21 
    +

  • testsuite/tests/simplCore/should_compile/T25718c.hs
    1 
    +{-# LANGUAGE CPP, MagicHash #-}
    2 
    +module T25718c where
    3 
    +
    4 
    +#include "MachDeps.h"
    5 
    +
    6 
    +import GHC.Exts
    7 
    +
    8 
    +-- Test that value range analysis handles all conversion/narrow/arithmetic primops.
    9 
    +-- Each section tests a different op from `valueRange` in GHC.Core.Opt.Range.
    10 
    +--
    11 
    +-- Already tested in T25718/T25718b: Word8ToWordOp, WordAndOp.
    12 
    +-- Here we test the remaining ops:
    13 
    +--
    14 
    +-- (1)  Narrow8IntOp  (narrow8Int#):   result in Int8  range [-128,  127]
    15 
    +-- (2)  Narrow16IntOp (narrow16Int#):  result in Int16 range [-32768,32767]
    16 
    +-- (3)  Narrow8WordOp  (narrow8Word#): result in Word8  range [0, 255]
    17 
    +-- (4)  Narrow16WordOp (narrow16Word#):result in Word16 range [0, 65535]
    18 
    +-- (5)  Word16ToWordOp (word16ToWord#):result in Word16 range [0, 65535]
    19 
    +-- (6)  WordToWord8Op  (wordToWord8#): result in Word8  range [0, 255]
    20 
    +-- (7)  WordToWord16Op (wordToWord16#):result in Word16 range [0, 65535]
    21 
    +-- (8)  Word8ToInt8Op  (word8ToInt8#): rangeCastFrom -> Int8  range [-128, 127]
    22 
    +-- (9)  Word16ToInt16Op(word16ToInt16#):rangeCastFrom -> Int16 range [-32768,32767]
    23 
    +-- (10) Int8ToWord8Op  (int8ToWord8#): rangeCastFrom -> Word8  range [0, 255]
    24 
    +-- (11) Int16ToWord16Op(int16ToWord16#):rangeCastFrom -> Word16 range [0, 65535]
    25 
    +-- (12) Word8AddOp (plusWord8#): rangeCastFrom fallback -> Word8 range [0, 255]
    26 
    +-- (13) VRA1 for Word16 (unreachable alt removal)
    27 
    +-- (14) VRA1 for narrow8Int# (unreachable alt removal)
    28 
    +-- (15) Word8SubOp  (subWord8#):  result in Word8  range [0, 255]
    29 
    +-- (16) Word16AddOp (plusWord16#):result in Word16 range [0, 65535]
    30 
    +-- (17) Word16SubOp (subWord16#): result in Word16 range [0, 65535]
    31 
    +-- (18) Int8AddOp  (plusInt8#):   result in Int8  range [-128, 127]
    32 
    +-- (19) Int8SubOp  (subInt8#):    result in Int8  range [-128, 127]
    33 
    +-- (20) Int16AddOp (plusInt16#):  result in Int16 range [-32768,32767]
    34 
    +-- (21) Int16SubOp (subInt16#):   result in Int16 range [-32768,32767]
    35 
    +-- (22) Narrow32IntOp (narrow32Int#):  result in Int32 range [-2147483648,2147483647]
    36 
    +-- (23) Word32ToInt32Op (word32ToInt32#): rangeCastFrom -> Int32 range [-2147483648,2147483647]
    37 
    +-- (24) Int32ToWord32Op (int32ToWord32#): rangeCastFrom -> Word32 range [0,4294967295]
    38 
    +-- (25) Int32AddOp (plusInt32#):  result in Int32 range [-2147483648,2147483647]
    39 
    +-- (26) Int32SubOp (subInt32#):   result in Int32 range [-2147483648,2147483647]
    40 
    +-- (27) Word8AndOp  (andWord8#):  rangeAnd -> [0, mask]
    41 
    +-- (28) Word16AndOp (andWord16#): rangeAnd -> [0, mask]
    42 
    +-- (29) Word32AndOp (andWord32#): rangeAnd -> [0, mask]
    43 
    +-- (30) Word64AndOp (and64#):     rangeAnd -> [0, mask]
    44 
    +-- (31) IntAndOp    (andI#):      rangeAnd -> [0, mask]
    45 
    +-- Sections (32)-(38) require 64-bit literals; guarded with CPP:
    46 
    +-- (32) Narrow32WordOp (narrow32Word#): on 64-bit, result in Word32 range [0,4294967295]
    47 
    +-- (33) Word32ToWordOp (word32ToWord#): on 64-bit, result in Word32 range [0,4294967295]
    48 
    +-- (34) WordToWord32Op (wordToWord32#): on 64-bit, composed chain in [0,4294967295]
    49 
    +-- (35) Word32AddOp (plusWord32#): on 64-bit, result in Word32 range [0,4294967295]
    50 
    +-- (36) Word32SubOp (subWord32#):  on 64-bit, result in Word32 range [0,4294967295]
    51 
    +-- (37) VRA1 for narrow32Int# (unreachable alts > 2147483647)
    52 
    +-- (38) VRA1 for word32ToWord# (unreachable alts > 4294967295)
    53 
    +
    54 
    +-- (1) Narrow8IntOp: narrow8Int# x is always in [-128, 127]
    55 
    +narrow8_ge_lb :: Int# -> Bool
    56 
    +narrow8_ge_lb x = isTrue# (narrow8Int# x >=# -128#)     -- True
    57 
    +
    58 
    +narrow8_le_ub :: Int# -> Bool
    59 
    +narrow8_le_ub x = isTrue# (narrow8Int# x <=# 127#)      -- True
    60 
    +
    61 
    +narrow8_gt_ub_false :: Int# -> Bool
    62 
    +narrow8_gt_ub_false x = isTrue# (narrow8Int# x >=# 128#) -- False
    63 
    +
    64 
    +-- (2) Narrow16IntOp: narrow16Int# x is always in [-32768, 32767]
    65 
    +narrow16_ge_lb :: Int# -> Bool
    66 
    +narrow16_ge_lb x = isTrue# (narrow16Int# x >=# -32768#)  -- True
    67 
    +
    68 
    +narrow16_le_ub :: Int# -> Bool
    69 
    +narrow16_le_ub x = isTrue# (narrow16Int# x <=# 32767#)   -- True
    70 
    +
    71 
    +-- (3) Narrow8WordOp: narrow8Word# x is always in [0, 255]
    72 
    +narrow8w_lt_ub :: Word# -> Bool
    73 
    +narrow8w_lt_ub x = isTrue# (narrow8Word# x `ltWord#` 256##)   -- True
    74 
    +
    75 
    +-- (4) Narrow16WordOp: narrow16Word# x is always in [0, 65535]
    76 
    +narrow16w_lt_ub :: Word# -> Bool
    77 
    +narrow16w_lt_ub x = isTrue# (narrow16Word# x `ltWord#` 65536##) -- True
    78 
    +
    79 
    +-- (5) Word16ToWordOp: word16ToWord# x is always in [0, 65535]
    80 
    +word16_lt_ub :: Word16# -> Bool
    81 
    +word16_lt_ub x = isTrue# (word16ToWord# x `ltWord#` 65536##)  -- True
    82 
    +
    83 
    +word16_ge_ub_false :: Word16# -> Bool
    84 
    +word16_ge_ub_false x = isTrue# (word16ToWord# x `geWord#` 65536##) -- False
    85 
    +
    86 
    +-- (6) WordToWord8Op: word8ToWord# (wordToWord8# x) is in [0, 255]
    87 
    +word_to_word8_lt :: Word# -> Bool
    88 
    +word_to_word8_lt x = isTrue# (word8ToWord# (wordToWord8# x) `ltWord#` 256##) -- True
    89 
    +
    90 
    +-- (7) WordToWord16Op: word16ToWord# (wordToWord16# x) is in [0, 65535]
    91 
    +word_to_word16_lt :: Word# -> Bool
    92 
    +word_to_word16_lt x = isTrue# (word16ToWord# (wordToWord16# x) `ltWord#` 65536##) -- True
    93 
    +
    94 
    +-- (8) Word8ToInt8Op: word8ToInt8# x has range Int8 [-128, 127] (via rangeCastFrom)
    95 
    +word8_to_int8_ge :: Word8# -> Bool
    96 
    +word8_to_int8_ge x = isTrue# (geInt8# (word8ToInt8# x) (intToInt8# -128#)) -- True
    97 
    +
    98 
    +-- (9) Word16ToInt16Op: word16ToInt16# x has range Int16 [-32768, 32767]
    99 
    +word16_to_int16_ge :: Word16# -> Bool
    100 
    +word16_to_int16_ge x = isTrue# (geInt16# (word16ToInt16# x) (intToInt16# -32768#)) -- True
    101 
    +
    102 
    +-- (10) Int8ToWord8Op: int8ToWord8# x has range Word8 [0, 255] (via rangeCastFrom)
    103 
    +int8_to_word8_le :: Int8# -> Bool
    104 
    +int8_to_word8_le x = isTrue# (leWord8# (int8ToWord8# x) (wordToWord8# 255##)) -- True
    105 
    +
    106 
    +-- (11) Int16ToWord16Op: int16ToWord16# x has range Word16 [0, 65535]
    107 
    +int16_to_word16_le :: Int16# -> Bool
    108 
    +int16_to_word16_le x = isTrue# (leWord16# (int16ToWord16# x) (wordToWord16# 65535##)) -- True
    109 
    +
    110 
    +-- (12) Word8AddOp: plusWord8# result stays in [0, 255] (rangeCastFrom fallback)
    111 
    +word8_add_lt_256 :: Word8# -> Word8# -> Bool
    112 
    +word8_add_lt_256 x y = isTrue# (word8ToWord# (plusWord8# x y) `ltWord#` 256##) -- True
    113 
    +
    114 
    +-- (13) VRA1: unreachable alts for Word16 range [0, 65535]
    115 
    +word16_alts :: Word16# -> Bool
    116 
    +word16_alts x = case word16ToWord# x of
    117 
    +  100000## -> False   -- unreachable: 100000 > 65535
    118 
    +  65536##  -> False   -- unreachable: 65536 > 65535
    119 
    +  42##     -> False   -- reachable
    120 
    +  _        -> True
    121 
    +
    122 
    +-- (14) VRA1: unreachable alts for narrow8Int# range [-128, 127]
    123 
    +narrow8_alts :: Int# -> Bool
    124 
    +narrow8_alts x = case narrow8Int# x of
    125 
    +  200# -> False   -- unreachable: 200 > 127
    126 
    +  128# -> False   -- unreachable: 128 > 127
    127 
    +  42#  -> False   -- reachable
    128 
    +  _    -> True
    129 
    +
    130 
    +-- (15) Word8SubOp: subWord8# result stays in [0, 255]
    131 
    +word8_sub_lt_256 :: Word8# -> Word8# -> Bool
    132 
    +word8_sub_lt_256 x y = isTrue# (word8ToWord# (subWord8# x y) `ltWord#` 256##) -- True
    133 
    +
    134 
    +-- (16) Word16AddOp: plusWord16# result stays in [0, 65535]
    135 
    +word16_add_lt_ub :: Word16# -> Word16# -> Bool
    136 
    +word16_add_lt_ub x y = isTrue# (word16ToWord# (plusWord16# x y) `ltWord#` 65536##) -- True
    137 
    +
    138 
    +-- (17) Word16SubOp: subWord16# result stays in [0, 65535]
    139 
    +word16_sub_lt_ub :: Word16# -> Word16# -> Bool
    140 
    +word16_sub_lt_ub x y = isTrue# (word16ToWord# (subWord16# x y) `ltWord#` 65536##) -- True
    141 
    +
    142 
    +-- (18) Int8AddOp: plusInt8# result stays in [-128, 127]
    143 
    +int8_add_ge_lb :: Int8# -> Int8# -> Bool
    144 
    +int8_add_ge_lb x y = isTrue# (geInt8# (plusInt8# x y) (intToInt8# -128#)) -- True
    145 
    +
    146 
    +-- (19) Int8SubOp: subInt8# result stays in [-128, 127]
    147 
    +int8_sub_le_ub :: Int8# -> Int8# -> Bool
    148 
    +int8_sub_le_ub x y = isTrue# (leInt8# (subInt8# x y) (intToInt8# 127#)) -- True
    149 
    +
    150 
    +-- (20) Int16AddOp: plusInt16# result stays in [-32768, 32767]
    151 
    +int16_add_ge_lb :: Int16# -> Int16# -> Bool
    152 
    +int16_add_ge_lb x y = isTrue# (geInt16# (plusInt16# x y) (intToInt16# -32768#)) -- True
    153 
    +
    154 
    +-- (21) Int16SubOp: subInt16# result stays in [-32768, 32767]
    155 
    +int16_sub_le_ub :: Int16# -> Int16# -> Bool
    156 
    +int16_sub_le_ub x y = isTrue# (leInt16# (subInt16# x y) (intToInt16# 32767#)) -- True
    157 
    +
    158 
    +-- (22) Narrow32IntOp: narrow32Int# result stays in [-2147483648, 2147483647]
    159 
    +-- (literals fit on 32-bit: -2147483648 = minInt32, 2147483647 = maxInt32)
    160 
    +narrow32_ge_lb :: Int# -> Bool
    161 
    +narrow32_ge_lb x = isTrue# (narrow32Int# x >=# -2147483648#) -- True
    162 
    +
    163 
    +narrow32_le_ub :: Int# -> Bool
    164 
    +narrow32_le_ub x = isTrue# (narrow32Int# x <=# 2147483647#) -- True
    165 
    +
    166 
    +-- (23) Word32ToInt32Op: word32ToInt32# result has range Int32 [-2147483648, 2147483647]
    167 
    +word32_to_int32_ge :: Word32# -> Bool
    168 
    +word32_to_int32_ge x = isTrue# (geInt32# (word32ToInt32# x) (intToInt32# -2147483648#)) -- True
    169 
    +
    170 
    +-- (24) Int32ToWord32Op: int32ToWord32# result has range Word32 [0, 4294967295]
    171 
    +-- (4294967295## = maxWord32 = maxWord on 32-bit, valid literal on any platform)
    172 
    +int32_to_word32_le :: Int32# -> Bool
    173 
    +int32_to_word32_le x = isTrue# (leWord32# (int32ToWord32# x) (wordToWord32# 4294967295##)) -- True
    174 
    +
    175 
    +-- (25) Int32AddOp: plusInt32# result stays in [-2147483648, 2147483647]
    176 
    +int32_add_ge_lb :: Int32# -> Int32# -> Bool
    177 
    +int32_add_ge_lb x y = isTrue# (geInt32# (plusInt32# x y) (intToInt32# -2147483648#)) -- True
    178 
    +
    179 
    +-- (26) Int32SubOp: subInt32# result stays in [-2147483648, 2147483647]
    180 
    +int32_sub_le_ub :: Int32# -> Int32# -> Bool
    181 
    +int32_sub_le_ub x y = isTrue# (leInt32# (subInt32# x y) (intToInt32# 2147483647#)) -- True
    182 
    +
    183 
    +-- (27) Word8AndOp: andWord8# with constant mask gives bounded range [0, mask]
    184 
    +word8_and_lt :: Word8# -> Bool
    185 
    +word8_and_lt x = isTrue# (word8ToWord# (andWord8# x (wordToWord8# 0xF##)) `ltWord#` 16##) -- True
    186 
    +
    187 
    +word8_and_alts :: Word8# -> Bool
    188 
    +word8_and_alts x = case word8ToWord# (andWord8# x (wordToWord8# 0xF##)) of
    189 
    +  100## -> False   -- unreachable: 100 > 15
    190 
    +  20##  -> False   -- unreachable: 20 > 15
    191 
    +  5##   -> False   -- reachable
    192 
    +  _     -> True
    193 
    +
    194 
    +-- (28) Word16AndOp: andWord16# with constant mask gives bounded range [0, mask]
    195 
    +word16_and_lt :: Word16# -> Bool
    196 
    +word16_and_lt x = isTrue# (word16ToWord# (andWord16# x (wordToWord16# 0xFF##)) `ltWord#` 256##) -- True
    197 
    +
    198 
    +-- (29) Word32AndOp: andWord32# with constant mask gives bounded range [0, mask]
    199 
    +-- (65536## = 2^16, valid on any platform as Word# literal)
    200 
    +word32_and_lt :: Word32# -> Bool
    201 
    +word32_and_lt x = isTrue# (word32ToWord# (andWord32# x (wordToWord32# 0xFFFF##)) `ltWord#` 65536##) -- True
    202 
    +
    203 
    +-- (30) Word64AndOp (and64#): with constant mask gives bounded range [0, mask]
    204 
    +word64_and_le :: Word64# -> Bool
    205 
    +word64_and_le x = isTrue# (leWord64# (and64# x (wordToWord64# 0xFFFF##)) (wordToWord64# 65535##)) -- True
    206 
    +
    207 
    +-- (31) IntAndOp (andI#): with non-negative constant mask gives range [0, mask]
    208 
    +int_and_ge :: Int# -> Bool
    209 
    +int_and_ge x = isTrue# (andI# x 0xFF# >=# 0#) -- True
    210 
    +
    211 
    +int_and_alts :: Int# -> Bool
    212 
    +int_and_alts x = case andI# x 0xFF# of
    213 
    +  256# -> False   -- unreachable: 256 > 255
    214 
    +  42#  -> False   -- reachable
    215 
    +  _    -> True
    216 
    +
    217 
    +#if WORD_SIZE_IN_BITS >= 64
    218 
    +-- On 64-bit platforms, Word# is 64-bit so 4294967296## (= 2^32) is a valid literal
    219 
    +-- and Word32 ops produce a proper sub-range of Word#.
    220 
    +
    221 
    +-- (32) Narrow32WordOp: narrow32Word# result in [0, 4294967295] on 64-bit
    222 
    +narrow32w_lt_ub :: Word# -> Bool
    223 
    +narrow32w_lt_ub x = isTrue# (narrow32Word# x `ltWord#` 4294967296##) -- True
    224 
    +
    225 
    +-- (33) Word32ToWordOp: word32ToWord# result in [0, 4294967295] on 64-bit
    226 
    +word32_lt_ub :: Word32# -> Bool
    227 
    +word32_lt_ub x = isTrue# (word32ToWord# x `ltWord#` 4294967296##) -- True
    228 
    +
    229 
    +word32_ge_ub_false :: Word32# -> Bool
    230 
    +word32_ge_ub_false x = isTrue# (word32ToWord# x `geWord#` 4294967296##) -- False
    231 
    +
    232 
    +-- (34) WordToWord32Op: word32ToWord# (wordToWord32# x) in [0, 4294967295] on 64-bit
    233 
    +word_to_word32_lt :: Word# -> Bool
    234 
    +word_to_word32_lt x = isTrue# (word32ToWord# (wordToWord32# x) `ltWord#` 4294967296##) -- True
    235 
    +
    236 
    +-- (35) Word32AddOp: plusWord32# result in [0, 4294967295] on 64-bit
    237 
    +word32_add_lt_ub :: Word32# -> Word32# -> Bool
    238 
    +word32_add_lt_ub x y = isTrue# (word32ToWord# (plusWord32# x y) `ltWord#` 4294967296##) -- True
    239 
    +
    240 
    +-- (36) Word32SubOp: subWord32# result in [0, 4294967295] on 64-bit
    241 
    +word32_sub_lt_ub :: Word32# -> Word32# -> Bool
    242 
    +word32_sub_lt_ub x y = isTrue# (word32ToWord# (subWord32# x y) `ltWord#` 4294967296##) -- True
    243 
    +
    244 
    +-- (37) VRA1 for narrow32Int# (unreachable alts outside [-2147483648, 2147483647])
    245 
    +-- (literals 2147483648# and 3000000000# overflow Int# on 32-bit, so guarded by CPP)
    246 
    +narrow32_alts :: Int# -> Bool
    247 
    +narrow32_alts x = case narrow32Int# x of
    248 
    +  3000000000# -> False   -- unreachable: 3000000000 > 2147483647
    249 
    +  2147483648# -> False   -- unreachable: 2147483648 > 2147483647
    250 
    +  42#         -> False   -- reachable
    251 
    +  _           -> True
    252 
    +
    253 
    +-- (38) VRA1 for word32ToWord# (unreachable alts outside [0, 4294967295])
    254 
    +-- (literals 4294967296## etc. overflow Word# on 32-bit, so guarded by CPP)
    255 
    +word32_alts :: Word32# -> Bool
    256 
    +word32_alts x = case word32ToWord# x of
    257 
    +  5000000000## -> False   -- unreachable: 5000000000 > 4294967295
    258 
    +  4294967296## -> False   -- unreachable: 4294967296 > 4294967295
    259 
    +  42##         -> False   -- reachable
    260 
    +  _            -> True
    261 
    +#endif

  • testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-32
    1 
    +
    2 
    +==================== Tidy Core ====================
    3 
    +Result size of Tidy Core
    4 
    +  = {terms: 128, types: 115, coercions: 0, joins: 0/0}
    5 
    +
    6 
    +narrow8_ge_lb = \ _ -> True
    7 
    +
    8 
    +narrow8_le_ub = narrow8_ge_lb
    9 
    +
    10 
    +narrow8_gt_ub_false = \ _ -> False
    11 
    +
    12 
    +narrow16_ge_lb = narrow8_ge_lb
    13 
    +
    14 
    +narrow16_le_ub = narrow8_ge_lb
    15 
    +
    16 
    +narrow8w_lt_ub = \ _ -> True
    17 
    +
    18 
    +narrow16w_lt_ub = narrow8w_lt_ub
    19 
    +
    20 
    +word16_lt_ub = \ _ -> True
    21 
    +
    22 
    +word16_ge_ub_false = \ _ -> False
    23 
    +
    24 
    +word_to_word8_lt = narrow8w_lt_ub
    25 
    +
    26 
    +word_to_word16_lt = narrow8w_lt_ub
    27 
    +
    28 
    +word8_to_int8_ge = \ _ -> True
    29 
    +
    30 
    +word16_to_int16_ge = word16_lt_ub
    31 
    +
    32 
    +int8_to_word8_le = \ _ -> True
    33 
    +
    34 
    +int16_to_word16_le = \ _ -> True
    35 
    +
    36 
    +word8_add_lt_256 = \ _ _ -> True
    37 
    +
    38 
    +word16_alts
    39 
    +  = \ x ->
    40 
    +      case word16ToWord# x of {
    41 
    +        __DEFAULT -> True;
    42 
    +        42## -> False
    43 
    +      }
    44 
    +
    45 
    +narrow8_alts
    46 
    +  = \ x ->
    47 
    +      case narrow8Int# x of {
    48 
    +        __DEFAULT -> True;
    49 
    +        42# -> False
    50 
    +      }
    51 
    +
    52 
    +word8_sub_lt_256 = word8_add_lt_256
    53 
    +
    54 
    +word16_add_lt_ub = \ _ _ -> True
    55 
    +
    56 
    +word16_sub_lt_ub = word16_add_lt_ub
    57 
    +
    58 
    +int8_add_ge_lb = \ _ _ -> True
    59 
    +
    60 
    +int8_sub_le_ub = int8_add_ge_lb
    61 
    +
    62 
    +int16_add_ge_lb = \ _ _ -> True
    63 
    +
    64 
    +int16_sub_le_ub = int16_add_ge_lb
    65 
    +
    66 
    +narrow32_ge_lb = narrow8_ge_lb
    67 
    +
    68 
    +narrow32_le_ub = narrow8_ge_lb
    69 
    +
    70 
    +word32_to_int32_ge = \ _ -> True
    71 
    +
    72 
    +int32_to_word32_le = \ _ -> True
    73 
    +
    74 
    +int32_add_ge_lb = \ _ _ -> True
    75 
    +
    76 
    +int32_sub_le_ub = int32_add_ge_lb
    77 
    +
    78 
    +word8_and_lt = word8_to_int8_ge
    79 
    +
    80 
    +word8_and_alts
    81 
    +  = \ x ->
    82 
    +      case word8ToWord# (andWord8# x 15#Word8) of {
    83 
    +        __DEFAULT -> True;
    84 
    +        5## -> False
    85 
    +      }
    86 
    +
    87 
    +word16_and_lt = word16_lt_ub
    88 
    +
    89 
    +word32_and_lt = word32_to_int32_ge
    90 
    +
    91 
    +word64_and_le = \ _ -> True
    92 
    +
    93 
    +int_and_ge = narrow8_ge_lb
    94 
    +
    95 
    +int_and_alts
    96 
    +  = \ x ->
    97 
    +      case andI# x 255# of {
    98 
    +        __DEFAULT -> True;
    99 
    +        42# -> False
    100 
    +      }
    101 
    +
    102 
    +
    103 
    +

  • testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64
    1 
    +
    2 
    +==================== Tidy Core ====================
    3 
    +Result size of Tidy Core
    4 
    +  = {terms: 161, types: 140, coercions: 0, joins: 0/0}
    5 
    +
    6 
    +narrow8_ge_lb = \ _ -> True
    7 
    +
    8 
    +narrow8_le_ub = narrow8_ge_lb
    9 
    +
    10 
    +narrow8_gt_ub_false = \ _ -> False
    11 
    +
    12 
    +narrow16_ge_lb = narrow8_ge_lb
    13 
    +
    14 
    +narrow16_le_ub = narrow8_ge_lb
    15 
    +
    16 
    +narrow8w_lt_ub = \ _ -> True
    17 
    +
    18 
    +narrow16w_lt_ub = narrow8w_lt_ub
    19 
    +
    20 
    +word16_lt_ub = \ _ -> True
    21 
    +
    22 
    +word16_ge_ub_false = \ _ -> False
    23 
    +
    24 
    +word_to_word8_lt = narrow8w_lt_ub
    25 
    +
    26 
    +word_to_word16_lt = narrow8w_lt_ub
    27 
    +
    28 
    +word8_to_int8_ge = \ _ -> True
    29 
    +
    30 
    +word16_to_int16_ge = word16_lt_ub
    31 
    +
    32 
    +int8_to_word8_le = \ _ -> True
    33 
    +
    34 
    +int16_to_word16_le = \ _ -> True
    35 
    +
    36 
    +word8_add_lt_256 = \ _ _ -> True
    37 
    +
    38 
    +word16_alts
    39 
    +  = \ x ->
    40 
    +      case word16ToWord# x of {
    41 
    +        __DEFAULT -> True;
    42 
    +        42## -> False
    43 
    +      }
    44 
    +
    45 
    +narrow8_alts
    46 
    +  = \ x ->
    47 
    +      case narrow8Int# x of {
    48 
    +        __DEFAULT -> True;
    49 
    +        42# -> False
    50 
    +      }
    51 
    +
    52 
    +word8_sub_lt_256 = word8_add_lt_256
    53 
    +
    54 
    +word16_add_lt_ub = \ _ _ -> True
    55 
    +
    56 
    +word16_sub_lt_ub = word16_add_lt_ub
    57 
    +
    58 
    +int8_add_ge_lb = \ _ _ -> True
    59 
    +
    60 
    +int8_sub_le_ub = int8_add_ge_lb
    61 
    +
    62 
    +int16_add_ge_lb = \ _ _ -> True
    63 
    +
    64 
    +int16_sub_le_ub = int16_add_ge_lb
    65 
    +
    66 
    +narrow32_ge_lb = narrow8_ge_lb
    67 
    +
    68 
    +narrow32_le_ub = narrow8_ge_lb
    69 
    +
    70 
    +word32_to_int32_ge = \ _ -> True
    71 
    +
    72 
    +int32_to_word32_le = \ _ -> True
    73 
    +
    74 
    +int32_add_ge_lb = \ _ _ -> True
    75 
    +
    76 
    +int32_sub_le_ub = int32_add_ge_lb
    77 
    +
    78 
    +word8_and_lt = word8_to_int8_ge
    79 
    +
    80 
    +word8_and_alts
    81 
    +  = \ x ->
    82 
    +      case word8ToWord# (andWord8# x 15#Word8) of {
    83 
    +        __DEFAULT -> True;
    84 
    +        5## -> False
    85 
    +      }
    86 
    +
    87 
    +word16_and_lt = word16_lt_ub
    88 
    +
    89 
    +word32_and_lt = word32_to_int32_ge
    90 
    +
    91 
    +word64_and_le = \ _ -> True
    92 
    +
    93 
    +int_and_ge = narrow8_ge_lb
    94 
    +
    95 
    +int_and_alts
    96 
    +  = \ x ->
    97 
    +      case andI# x 255# of {
    98 
    +        __DEFAULT -> True;
    99 
    +        42# -> False
    100 
    +      }
    101 
    +
    102 
    +narrow32w_lt_ub = narrow8w_lt_ub
    103 
    +
    104 
    +word32_lt_ub = word32_to_int32_ge
    105 
    +
    106 
    +word32_ge_ub_false = \ _ -> False
    107 
    +
    108 
    +word_to_word32_lt = narrow8w_lt_ub
    109 
    +
    110 
    +word32_add_lt_ub = \ _ _ -> True
    111 
    +
    112 
    +word32_sub_lt_ub = word32_add_lt_ub
    113 
    +
    114 
    +narrow32_alts
    115 
    +  = \ x ->
    116 
    +      case narrow32Int# x of {
    117 
    +        __DEFAULT -> True;
    118 
    +        42# -> False
    119 
    +      }
    120 
    +
    121 
    +word32_alts
    122 
    +  = \ x ->
    123 
    +      case word32ToWord# x of {
    124 
    +        __DEFAULT -> True;
    125 
    +        42## -> False
    126 
    +      }
    127 
    +
    128 
    +
    129 
    +

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -594,3 +594,8 @@ test('T26805', [grep_errmsg(r'fromInteger')], compile, ['-O -dno-typeable-binds
    594 594 
     test('T26826', normal, compile, ['-O'])
    595 595 
     test('T26903', [grep_errmsg(r'reverse')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques -dsuppress-all'])
    596 596 
     test('T18032', normal, compile, ['-O -dsuppress-all -dsuppress-uniques -dno-typeable-binds -ddump-simpl'])
    597 
    +test('T25718', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])
    598 
    +test('T25718a', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])
    599 
    +test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])
    600 
    +test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])
    601 
    +test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help