[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Stop dropping a case whose binder is demanded
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Feb 5 20:08:46 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f69a5a96 by Simon Peyton Jones at 2024-02-05T15:08:27-05:00
Stop dropping a case whose binder is demanded
This MR fixes #24251.
See Note [Case-to-let for strictly-used binders]
in GHC.Core.Opt.Simplify.Iteration, plus #24251, for
lots of discussion.
Final Nofib changes over 0.1%:
+-----------------------------------------
| imaginary/digits-of-e2 -2.16%
| imaginary/rfib -0.15%
| real/fluid -0.10%
| real/gamteb -1.47%
| real/gg -0.20%
| real/maillist +0.19%
| real/pic -0.23%
| real/scs -0.43%
| shootout/n-body -0.41%
| shootout/spectral-norm -0.12%
+========================================
| geom mean -0.05%
Pleasingly, overall executable size is down by just over 1%.
Compile times (in perf/compiler) wobble around a bit +/- 0.5%, but the
geometric mean is -0.1% which seems good.
- - - - -
b7a814b4 by Simon Peyton Jones at 2024-02-05T15:08:27-05:00
Add Note [Bangs in Integer functions]
...to document the bangs in the functions in GHC.Num.Integer
- - - - -
ea6e6ff9 by Andrei Borzenkov at 2024-02-05T15:08:27-05:00
Hide WARNING/DEPRECATED namespacing under -XExplicitNamespaces (#24396)
- - - - -
23 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Types/Error/Codes.hs
- docs/users_guide/9.10.1-notes.rst
- docs/users_guide/exts/pragmas.rst
- libraries/ghc-bignum/src/GHC/Num/Integer.hs
- libraries/ghc-prim/GHC/Tuple.hs
- testsuite/tests/numeric/should_compile/T19641.stderr
- testsuite/tests/simplCore/should_compile/T15631.hs
- testsuite/tests/simplCore/should_compile/T15631.stdout
- testsuite/tests/simplCore/should_compile/T20103.stderr
- testsuite/tests/simplCore/should_compile/T22428.stderr
- testsuite/tests/simplCore/should_compile/T22611.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/warnings/should_compile/T24396a.hs
- + testsuite/tests/warnings/should_fail/T24396c.hs
- + testsuite/tests/warnings/should_fail/T24396c.stderr
- testsuite/tests/warnings/should_fail/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2827,30 +2827,73 @@ Note [Case-to-let for strictly-used binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have this:
case <scrut> of r { _ -> ..r.. }
-
-where 'r' is used strictly in (..r..), we can safely transform to
+where 'r' is used strictly in (..r..), we /could/ safely transform to
let r = <scrut> in ...r...
-
-This is a Good Thing, because 'r' might be dead (if the body just
-calls error), or might be used just once (in which case it can be
-inlined); or we might be able to float the let-binding up or down.
-E.g. #15631 has an example.
-
-Note that this can change the error behaviour. For example, we might
-transform
- case x of { _ -> error "bad" }
- --> error "bad"
-which is might be puzzling if 'x' currently lambda-bound, but later gets
-let-bound to (error "good").
-
-Nevertheless, the paper "A semantics for imprecise exceptions" allows
-this transformation. If you want to fix the evaluation order, use
-'pseq'. See #8900 for an example where the loss of this
-transformation bit us in practice.
-
-See also Note [Empty case alternatives] in GHC.Core.
-
-Historical notes
+As a special case, we have a plain `seq` like
+ case r of r1 { _ -> ...r1... }
+where `r` is used strictly, we /could/ simply drop the `case` to get
+ ...r....
+
+HOWEVER, there are some serious downsides to this transformation, so
+GHC doesn't do it any longer (#24251):
+
+* Suppose the Simplifier sees
+ case x of y* { __DEFAULT ->
+ let z = case y of { __DEFAULT -> expr } in
+ z+1 }
+ The "y*" means "y is used strictly in its scope. Now we may:
+ - Eliminate the inner case because `y` is evaluated.
+ Now the demand-info on `y` is not right, because `y` is no longer used
+ strictly in its scope. But it is hard to spot that without doing a new
+ demand analysis. So there is a danger that we will subsequently:
+ - Eliminate the outer case because `y` is used strictly
+ Yikes! We can't eliminate both!
+
+* It introduces space leaks (#24251). Consider
+ go 0 where go x = x `seq` go (x + 1)
+ It is an infinite loop, true, but it should not leak space. Yet if we drop
+ the `seq`, it will. Another great example is #21741.
+
+* Dropping the outer `case can change the error behaviour. For example,
+ we might transform
+ case x of { _ -> error "bad" } --> error "bad"
+ which is might be puzzling if 'x' currently lambda-bound, but later gets
+ let-bound to (error "good"). Tht is OK accoring to the paper "A semantics for
+ imprecise exceptions", but see #8900 for an example where the loss of this
+ transformation bit us in practice.
+
+* If we have (case e of x -> f x), where `f` is strict, then it looks as if `x`
+ is strictly used, and we could soundly transform to
+ let x = e in f x
+ But if f's strictness info got worse (which can happen in in obscure cases;
+ see #21392) then we might have turned a non-thunk into a thunk! Bad.
+
+Lacking this "drop-strictly-used-seq" transformation means we can end up with
+some redundant-looking evals. For example, consider
+ f x y = case x of DEFAULT -> -- A redundant-looking eval
+ case y of
+ True -> case x of { Nothing -> False; Just z -> z }
+ False -> case x of { Nothing -> True; Just z -> z }
+That outer eval will be retained right through to code generation. But,
+perhaps surprisingly, that is probably a /good/ thing:
+
+ Key point: those inner (case x) expressions will be compiled a simple 'if',
+ because the code generator can see that `x` is, at those points, evaluated
+ and properly tagged.
+
+If we dropped the outer eval, both the inner (case x) expressions would need to
+do a proper eval, pushing a return address, with an info table. See the example
+in #15631 where, in the Description, the (case ys) will be a simple multi-way
+jump.
+
+In fact (#24251), when I stopped GHC implementing the drop-strictly-used-seqs
+transformation, binary sizes fell by 1%, and a few programs actually allocated
+less and ran faster. A case in point is nofib/imaginary/digits-of-e2. (I'm not
+sure exactly why it improves so much, though.)
+
+Slightly related: Note [Empty case alternatives] in GHC.Core.
+
+Historical notes:
There have been various earlier versions of this patch:
@@ -3124,8 +3167,9 @@ doCaseToLet scrut case_bndr
| otherwise -- Scrut has a lifted type
= exprIsHNF scrut
- || isStrUsedDmd (idDemandInfo case_bndr)
- -- See Note [Case-to-let for strictly-used binders]
+ -- || isStrUsedDmd (idDemandInfo case_bndr)
+ -- We no longer look at the demand on the case binder
+ -- See Note [Case-to-let for strictly-used binders]
--------------------------------------------------
-- 3. Catch-all case
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -74,6 +74,7 @@ import GHC.Types.Demand
import GHC.Types.Var.Set
import GHC.Types.Basic
+import GHC.Data.Maybe ( orElse )
import GHC.Data.OrdList ( isNilOL )
import GHC.Data.FastString ( fsLit )
@@ -2358,6 +2359,44 @@ the outer case scrutinises the same variable as the outer case. This
transformation is called Case Merging. It avoids that the same
variable is scrutinised multiple times.
+Wrinkles
+
+(MC1) `tryCaseMerge` "looks though" an inner single-alternative case-on-variable.
+ For example
+ case x of {
+ ...outer-alts...
+ DEFAULT -> case y of (a,b) ->
+ case x of { A -> rhs1; B -> rhs2 }
+ ===>
+ case x of
+ ...outer-alts...
+ a -> case y of (a,b) -> rhs1
+ B -> case y of (a,b) -> rhs2
+
+ This duplicates the `case y` but it removes the case x; so it is a win
+ in terms of execution time (combining the cases on x) at the cost of
+ perhaps duplicating the `case y`. A case in point is integerEq, which
+ is defined thus
+ integerEq :: Integer -> Integer -> Bool
+ integerEq !x !y = isTrue# (integerEq# x y)
+ which becomes
+ integerEq
+ = \ (x :: Integer) (y_aAL :: Integer) ->
+ case x of x1 { __DEFAULT ->
+ case y of y1 { __DEFAULT ->
+ case x1 of {
+ IS x2 -> case y1 of {
+ __DEFAULT -> GHC.Types.False;
+ IS y2 -> tagToEnum# @Bool (==# x2 y2) };
+ IP x2 -> ...
+ IN x2 -> ...
+ We want to merge the outer `case x` with the inner `case x1`.
+
+ This story is not fully robust; it will be defeated by a let-binding,
+ whih we don't want to duplicate. But accounting for single-alternative
+ case-on-variable is easy to do, and seems useful in common cases so
+ `tryMergeCase` does it.
+
Note [Eliminate Identity Case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
case e of ===> e
@@ -2537,24 +2576,25 @@ mkCase, mkCase1, mkCase2, mkCase3
-- 1. Merge Nested Cases
--------------------------------------------------
-mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)
+mkCase mode scrut outer_bndr alts_ty alts
| sm_case_merge mode
- , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)
- <- stripTicksTop tickishFloatable deflt_rhs
- , inner_scrut_var == outer_bndr
+ , Just alts' <- tryMergeCase outer_bndr alts
= do { tick (CaseMerge outer_bndr)
-
- ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args)
- (Alt con args (wrap_rhs rhs))
- -- Simplifier's no-shadowing invariant should ensure
- -- that outer_bndr is not shadowed by the inner patterns
- wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs
- -- The let is OK even for unboxed binders,
-
- wrapped_alts | isDeadBinder inner_bndr = inner_alts
- | otherwise = map wrap_alt inner_alts
-
- merged_alts = mergeAlts outer_alts wrapped_alts
+ ; mkCase1 mode scrut outer_bndr alts_ty alts' }
+ -- Warning: don't call mkCase recursively!
+ -- Firstly, there's no point, because inner alts have already had
+ -- mkCase applied to them, so they won't have a case in their default
+ -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
+ -- in munge_rhs may put a case into the DEFAULT branch!
+ | otherwise
+ = mkCase1 mode scrut outer_bndr alts_ty alts
+
+tryMergeCase :: OutId -> [OutAlt] -> Maybe [OutAlt]
+-- See Note [Merge Nested Cases]
+tryMergeCase outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
+ = case go 5 (\e -> e) emptyVarSet deflt_rhs of
+ Nothing -> Nothing
+ Just inner_alts -> Just (mergeAlts outer_alts inner_alts)
-- NB: mergeAlts gives priority to the left
-- case x of
-- A -> e1
@@ -2563,17 +2603,42 @@ mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)
-- B -> e3
-- When we merge, we must ensure that e1 takes
-- precedence over e2 as the value for A!
-
- ; fmap (mkTicks ticks) $
- mkCase1 mode scrut outer_bndr alts_ty merged_alts
- }
- -- Warning: don't call mkCase recursively!
- -- Firstly, there's no point, because inner alts have already had
- -- mkCase applied to them, so they won't have a case in their default
- -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
- -- in munge_rhs may put a case into the DEFAULT branch!
-
-mkCase mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts
+ where
+ go :: Int -> (OutExpr -> OutExpr) -> VarSet -> OutExpr -> Maybe [OutAlt]
+ -- In the call (go wrap free_bndrs rhs), the `wrap` function has free `free_bndrs`;
+ -- so do not push `wrap` under any binders that would shadow `free_bndrs`
+ --
+ -- The 'n' is just a depth-bound to avoid pathalogical quadratic behaviour with
+ -- case x1 of DEFAULT -> case x2 of DEFAULT -> case x3 of DEFAULT -> ...
+ -- when for each `case` we'll look down the whole chain to see if there is
+ -- another `case` on that same variable. Also all of these (case xi) evals
+ -- get duplicated in each branch of the outer case, so 'n' controls how much
+ -- duplication we are prepared to put up with.
+ go 0 _ _ _ = Nothing
+
+ go n wrap free_bndrs (Tick t rhs)
+ = go n (wrap . Tick t) free_bndrs rhs
+ go _ wrap free_bndrs (Case (Var inner_scrut_var) inner_bndr _ inner_alts)
+ | inner_scrut_var == outer_bndr
+ , let wrap_let rhs' | isDeadBinder inner_bndr = rhs'
+ | otherwise = Let (NonRec inner_bndr (Var outer_bndr)) rhs'
+ -- The let is OK even for unboxed binders,
+ free_bndrs' = extendVarSet free_bndrs outer_bndr
+ = Just [ assert (not (any (`elemVarSet` free_bndrs') bndrs)) $
+ Alt con bndrs (wrap (wrap_let rhs))
+ | Alt con bndrs rhs <- inner_alts ]
+ go n wrap free_bndrs (Case (Var inner_scrut) inner_bndr ty inner_alts)
+ | [Alt con bndrs rhs] <- inner_alts -- Wrinkle (MC1)
+ , let wrap_case rhs' = Case (Var inner_scrut) inner_bndr ty $
+ tryMergeCase inner_bndr alts `orElse` alts
+ where
+ alts = [Alt con bndrs rhs']
+ = assert (not (outer_bndr `elem` (inner_bndr : bndrs))) $
+ go (n-1) (wrap . wrap_case) (free_bndrs `extendVarSet` inner_scrut) rhs
+
+ go _ _ _ _ = Nothing
+
+tryMergeCase _ _ = Nothing
--------------------------------------------------
-- 2. Eliminate Identity Case
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1288,7 +1288,7 @@ data NamespaceSpecifier
= NoNamespaceSpecifier
| TypeNamespaceSpecifier (EpToken "type")
| DataNamespaceSpecifier (EpToken "data")
- deriving (Data)
+ deriving (Eq, Data)
overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool
overlappingNamespaceSpecifiers NoNamespaceSpecifier _ = True
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -283,10 +283,13 @@ rnSrcWarnDecls bndr_set decls'
sig_ctxt = TopSigCtxt bndr_set
- rn_deprec (Warning (ns_spec, _) rdr_names txt)
+ rn_deprec w@(Warning (ns_spec, _) rdr_names txt)
-- ensures that the names are defined locally
= do { names <- concatMapM (lookupLocalTcNames sig_ctxt what ns_spec . unLoc)
rdr_names
+ ; unlessXOptM LangExt.ExplicitNamespaces $
+ when (ns_spec /= NoNamespaceSpecifier) $
+ addErr (TcRnNamespacedWarningPragmaWithoutFlag w)
; txt' <- rnWarningTxt txt
; return [(nameOccName nm, txt') | (_, nm) <- names] }
-- Use the OccName from the Name we looked up, rather than from the RdrName,
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1889,6 +1889,17 @@ instance Diagnostic TcRnMessage where
| otherwise
= text "they are not unfilled metavariables"
+ TcRnNamespacedWarningPragmaWithoutFlag warning@(Warning (kw, _) _ txt) -> mkSimpleDecorated $
+ vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:"
+ , nest 2 (ppr warning)
+ , text "in a" <+> pragma_type <+> text "pragma"
+ ]
+ where
+ pragma_type = case txt of
+ WarningTxt{} -> text "WARNING"
+ DeprecatedTxt{} -> text "DEPRECATED"
+
+ diagnosticReason :: TcRnMessage -> DiagnosticReason
diagnosticReason = \case
TcRnUnknownMessage m
-> diagnosticReason m
@@ -2512,6 +2523,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnInvalidDefaultedTyVar{}
-> ErrorWithoutFlag
+ TcRnNamespacedWarningPragmaWithoutFlag{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -3170,6 +3183,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnInvalidDefaultedTyVar{}
-> noHints
+ TcRnNamespacedWarningPragmaWithoutFlag{}
+ -> [suggestExtension LangExt.ExplicitNamespaces]
diagnosticCode = constructorCode
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -4205,6 +4205,13 @@ data TcRnMessage where
-> NE.NonEmpty TcTyVar -- ^ The invalid type variables of the proposal
-> TcRnMessage
+ {-| TcRnNamespacedWarningPragmaWithoutFlag is an error that occurs when
+ a namespace specifier is used in {-# WARNING ... #-} or {-# DEPRECATED ... #-}
+ pragmas without the -XExplicitNamespaces extension enabled
+
+ -}
+ TcRnNamespacedWarningPragmaWithoutFlag :: WarnDecl GhcPs -> TcRnMessage
+
deriving Generic
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -600,6 +600,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat" = 69797
GhcDiagnosticCode "TcRnInvalidDefaultedTyVar" = 45625
GhcDiagnosticCode "TcRnIllegalTermLevelUse" = 01928
+ GhcDiagnosticCode "TcRnNamespacedWarningPragmaWithoutFlag" = 14995
-- TcRnTypeApplicationsDisabled
GhcDiagnosticCode "TypeApplication" = 23482
=====================================
docs/users_guide/9.10.1-notes.rst
=====================================
@@ -75,9 +75,10 @@ Language
- GHC Proposal `#65 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0065-type-infix.rst>`_
"Require namespacing fixity declarations for type names and WARNING/DEPRECATED pragmas" has been partially implemented.
- Now you can specify namespace of a name that you want to warn about or deprecate: ::
+ Now, with :extension:`ExplicitNamespaces` enabled, you can specify the
+ namespace of a name that you want to warn about or deprecate: ::
- {-# DEPRACATED type D "Use `()` instead" #-} -- this will deprecate type D, but will not touch pattern synonym
+ {-# DEPRECATED type D "Use `()` instead" #-} -- this will deprecate type D, but will not touch pattern synonym
data D = MkD
{-# DEPRECATED data D "Use `MkD` instead" #-} -- this will deprecate pattern synonym only
=====================================
docs/users_guide/exts/pragmas.rst
=====================================
@@ -251,7 +251,8 @@ When a deprecated name appears in both value and type namespaces (i.e. punning o
{-# DEPRECATED D "This will deprecate both the type D and the pattern synonym D" #-}
It is possible to specify the namespace of the name to be warned about
-or deprecated using ``type`` and ``data`` specifiers: ::
+or deprecated using ``type`` and ``data`` specifiers, but this feature
+requires enabling :extension:`ExplicitNamespaces`: ::
{-# LANGUAGE PatternSynonyms #-}
=====================================
libraries/ghc-bignum/src/GHC/Num/Integer.hs
=====================================
@@ -360,6 +360,24 @@ integerToNaturalThrow (IN _) = raiseUnderflow
-- Predicates
---------------------------------------------------------------------
+{- Note [Bangs in Integer functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In this module some functions have banged arguments. E.g.
+ integerNe !x !y = isTrue# (integerNe# x y)
+This will ensure that both argument are evaluated first, and then pattern
+matching takes place just a multi-way jump.
+
+In some cases (e.g. integerMul, integerSub) this actually makes the function
+strict when it would otherwise not be; but in other cases (e.g integerNe) the
+function is strict in both arguments anyway. In the latter case it's a bit moot
+whether to have the bangs or not; so this Note just documents that there is no
+Deep Reason why they have to be there. See Note Note [Case-to-let for
+strictly-used binders] in GHC.Core.Opt.Simplify.Iteration for discussion about
+evals on strictly-used binders.
+
+I have not pointed to this Note from every such use. There are a lot of them!
+-}
+
-- | Negative predicate
integerIsNegative# :: Integer -> Bool#
integerIsNegative# (IS i#) = i# <# 0#
@@ -369,6 +387,7 @@ integerIsNegative# (IN _) = 1#
-- | Negative predicate
integerIsNegative :: Integer -> Bool
integerIsNegative !i = isTrue# (integerIsNegative# i)
+ -- Note [Bangs in Integer functions]
-- | Zero predicate
integerIsZero :: Integer -> Bool
@@ -383,26 +402,32 @@ integerIsOne _ = False
-- | Not-equal predicate.
integerNe :: Integer -> Integer -> Bool
integerNe !x !y = isTrue# (integerNe# x y)
+ -- Note [Bangs in Integer functions]
-- | Equal predicate.
integerEq :: Integer -> Integer -> Bool
integerEq !x !y = isTrue# (integerEq# x y)
+ -- See Note [Bangs in Integer functions]
-- | Lower-or-equal predicate.
integerLe :: Integer -> Integer -> Bool
integerLe !x !y = isTrue# (integerLe# x y)
+ -- See Note [Bangs in Integer functions]
-- | Lower predicate.
integerLt :: Integer -> Integer -> Bool
integerLt !x !y = isTrue# (integerLt# x y)
+ -- See Note [Bangs in Integer functions]
-- | Greater predicate.
integerGt :: Integer -> Integer -> Bool
integerGt !x !y = isTrue# (integerGt# x y)
+ -- See Note [Bangs in Integer functions]
-- | Greater-or-equal predicate.
integerGe :: Integer -> Integer -> Bool
integerGe !x !y = isTrue# (integerGe# x y)
+ -- See Note [Bangs in Integer functions]
-- | Equal predicate.
integerEq# :: Integer -> Integer -> Bool#
@@ -473,7 +498,7 @@ instance Ord Integer where
-- | Subtract one 'Integer' from another.
integerSub :: Integer -> Integer -> Integer
{-# NOINLINE integerSub #-}
-integerSub !x (IS 0#) = x
+integerSub !x (IS 0#) = x -- Note [Bangs in Integer functions]
integerSub (IS x#) (IS y#)
= case subIntC# x# y# of
(# z#, 0# #) -> IS z#
@@ -548,7 +573,7 @@ integerAdd (IP x) (IN y)
-- | Multiply two 'Integer's
integerMul :: Integer -> Integer -> Integer
{-# NOINLINE integerMul #-}
-integerMul !_ (IS 0#) = IS 0#
+integerMul !_ (IS 0#) = IS 0# -- Note [Bangs in Integer functions]
integerMul (IS 0#) _ = IS 0#
integerMul x (IS 1#) = x
integerMul (IS 1#) y = y
@@ -639,6 +664,7 @@ integerAbs n@(IS i)
-- negative, zero, or positive, respectively
integerSignum :: Integer -> Integer
integerSignum !j = IS (integerSignum# j)
+ -- Note [Bangs in Integer functions]
-- | Return @-1#@, @0#@, and @1#@ depending on whether argument is
-- negative, zero, or positive, respectively
@@ -711,7 +737,7 @@ integerTestBit !i (W# n) = isTrue# (integerTestBit# i n)
-- Fake 2's complement for negative values (might be slow)
integerShiftR# :: Integer -> Word# -> Integer
{-# NOINLINE integerShiftR# #-}
-integerShiftR# !x 0## = x
+integerShiftR# !x 0## = x -- Note [Bangs in Integer functions]
integerShiftR# (IS i) n = IS (iShiftRA# i (word2Int# n))
where
iShiftRA# a b
@@ -728,11 +754,12 @@ integerShiftR# (IN bn) n =
-- Fake 2's complement for negative values (might be slow)
integerShiftR :: Integer -> Word -> Integer
integerShiftR !x (W# w) = integerShiftR# x w
+ -- Note [Bangs in Integer functions]
-- | Shift-left operation
integerShiftL# :: Integer -> Word# -> Integer
{-# NOINLINE integerShiftL# #-}
-integerShiftL# !x 0## = x
+integerShiftL# !x 0## = x -- Note [Bangs in Integer functions]
integerShiftL# (IS 0#) _ = IS 0#
integerShiftL# (IS 1#) n = integerBit# n
integerShiftL# (IS i) n
@@ -747,6 +774,7 @@ integerShiftL# (IN bn) n = IN (bigNatShiftL# bn n)
-- negative Integers is different from negative Int's behavior.
integerShiftL :: Integer -> Word -> Integer
integerShiftL !x (W# w) = integerShiftL# x w
+ -- Note [Bangs in Integer functions]
-- | Bitwise OR operation
--
@@ -913,7 +941,7 @@ integerComplement (IN x) = IP (bigNatSubWordUnsafe# x 1##)
-- with a division-by-zero fault.
integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #)
{-# NOINLINE integerQuotRem# #-}
-integerQuotRem# !n (IS 1#) = (# n, IS 0# #)
+integerQuotRem# !n (IS 1#) = (# n, IS 0# #) -- Note [Bangs in Integer functions]
integerQuotRem# !n (IS -1#) = let !q = integerNegate n in (# q, (IS 0#) #)
integerQuotRem# !_ (IS 0#) = case raiseDivZero of
!_ -> (# IS 0#, IS 0# #)
@@ -951,12 +979,13 @@ integerQuotRem# n@(IS n#) (IP d) -- need to account for (IS minBound)
-- with a division-by-zero fault.
integerQuotRem :: Integer -> Integer -> (Integer, Integer)
integerQuotRem !x !y = case integerQuotRem# x y of
- (# q, r #) -> (q, r)
+ -- Note [Bangs in Integer functions]
+ (# q, r #) -> (q, r)
integerQuot :: Integer -> Integer -> Integer
{-# NOINLINE integerQuot #-}
-integerQuot !n (IS 1#) = n
+integerQuot !n (IS 1#) = n -- Note [Bangs in Integer functions]
integerQuot !n (IS -1#) = integerNegate n
integerQuot !_ (IS 0#) = raiseDivZero
integerQuot (IS 0#) _ = IS 0#
@@ -977,7 +1006,7 @@ integerQuot n d = case integerQuotRem# n d of (# q, _ #) -> q
integerRem :: Integer -> Integer -> Integer
{-# NOINLINE integerRem #-}
-integerRem !_ (IS 1#) = IS 0#
+integerRem !_ (IS 1#) = IS 0# -- Note [Bangs in Integer functions]
integerRem _ (IS -1#) = IS 0#
integerRem _ (IS 0#) = IS (remInt# 0# 0#)
integerRem (IS 0#) _ = IS 0#
@@ -999,7 +1028,7 @@ integerRem n d = case integerQuotRem# n d of (# _, r #) -> r
-- with a division-by-zero fault.
integerDivMod# :: Integer -> Integer -> (# Integer, Integer #)
{-# NOINLINE integerDivMod# #-}
-integerDivMod# !n !d
+integerDivMod# !n !d -- Note [Bangs in Integer functions]
| isTrue# (integerSignum# r ==# negateInt# (integerSignum# d))
= let !q' = integerSub q (IS 1#)
!r' = integerAdd r d
@@ -1014,12 +1043,13 @@ integerDivMod# !n !d
-- with a division-by-zero fault.
integerDivMod :: Integer -> Integer -> (Integer, Integer)
integerDivMod !n !d = case integerDivMod# n d of
+ -- Note [Bangs in Integer functions]
(# q,r #) -> (q,r)
integerDiv :: Integer -> Integer -> Integer
{-# NOINLINE integerDiv #-}
-integerDiv !n !d
+integerDiv !n !d -- Note [Bangs in Integer functions]
-- same-sign ops can be handled by more efficient 'integerQuot'
| isTrue# (integerIsNegative# n ==# integerIsNegative# d) = integerQuot n d
| True = case integerDivMod# n d of (# q, _ #) -> q
@@ -1027,7 +1057,7 @@ integerDiv !n !d
integerMod :: Integer -> Integer -> Integer
{-# NOINLINE integerMod #-}
-integerMod !n !d
+integerMod !n !d -- Note [Bangs in Integer functions]
-- same-sign ops can be handled by more efficient 'integerRem'
| isTrue# (integerIsNegative# n ==# integerIsNegative# d) = integerRem n d
| True = case integerDivMod# n d of (# _, r #) -> r
=====================================
libraries/ghc-prim/GHC/Tuple.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, PatternSynonyms #-}
+{-# LANGUAGE NoImplicitPrelude, PatternSynonyms, ExplicitNamespaces #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Tuple
=====================================
testsuite/tests/numeric/should_compile/T19641.stderr
=====================================
@@ -6,7 +6,7 @@ Result size of Tidy Core
natural_to_word
= \ eta ->
case eta of {
- NS x1 -> Just (W# x1);
+ NS x2 -> Just (W# x2);
NB ds -> Nothing
}
@@ -14,7 +14,7 @@ integer_to_int
= \ eta ->
case eta of {
IS ipv -> Just (I# ipv);
- IP x1 -> Nothing;
+ IP x2 -> Nothing;
IN ds -> Nothing
}
=====================================
testsuite/tests/simplCore/should_compile/T15631.hs
=====================================
@@ -7,5 +7,5 @@ f xs = let ys = reverse xs
let w = length xs
in w + length (reverse (case ys of { a:as -> as; [] -> [] }))
-
-
+-- Feb 24: because of #24251 we now expect ys to be
+-- evaluated early, and then case-analysed later
=====================================
testsuite/tests/simplCore/should_compile/T15631.stdout
=====================================
@@ -1,6 +1,7 @@
case GHC.List.$wlenAcc @a (Foo.f2 @a) 0# of v { __DEFAULT ->
+ case reverse @a xs of ys { __DEFAULT ->
case GHC.List.$wlenAcc @a xs 0# of ww1 { __DEFAULT ->
- case GHC.List.reverse1 @a xs (GHC.Types.[] @a) of {
+ case ys of {
[] -> case Foo.f1 @a of { GHC.Types.I# v1 -> GHC.Prim.+# ww1 v1 };
case GHC.List.$wlenAcc
case Foo.$wf @a xs of ww [Occ=Once1] { __DEFAULT ->
=====================================
testsuite/tests/simplCore/should_compile/T20103.stderr
=====================================
@@ -1,7 +1,12 @@
+T20103.hs:7:24: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]
+ In the use of ‘head’
+ (imported from Prelude, but defined in GHC.List):
+ "This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use "Data.List.NonEmpty"."
+
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 136, types: 88, coercions: 25, joins: 0/0}
+ = {terms: 139, types: 89, coercions: 22, joins: 0/0}
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
@@ -31,8 +36,9 @@ lvl4 = GHC.CString.unpackCString# lvl3
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T20103.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T20103.$trModule2 = "T20103"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
@@ -43,8 +49,9 @@ lvl5 = GHC.CString.unpackCString# T20103.$trModule2
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T20103.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T20103.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
@@ -110,10 +117,10 @@ lvl16
:: CallStack ~R# (?callStack::CallStack)))
Rec {
--- RHS size: {terms: 44, types: 41, coercions: 21, joins: 0/0}
+-- RHS size: {terms: 47, types: 42, coercions: 18, joins: 0/0}
T20103.$wfoo [InlPrag=[2], Occ=LoopBreaker]
:: HasCallStack => GHC.Prim.Int# -> GHC.Prim.Int#
-[GblId[StrictWorker([!])], Arity=2, Str=<SL><1L>, Unf=OtherCon []]
+[GblId[StrictWorker([!])], Arity=2, Str=<1L><1L>, Unf=OtherCon []]
T20103.$wfoo
= \ ($dIP :: HasCallStack) (ww :: GHC.Prim.Int#) ->
case ww of ds {
@@ -136,28 +143,26 @@ T20103.$wfoo
(GHC.Prim.-# ds 1#)
};
0# ->
- case getCallStack
- ($dIP
- `cast` (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N
- :: (?callStack::CallStack) ~R# CallStack))
- of {
+ case $dIP
+ `cast` (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N
+ :: (?callStack::CallStack) ~R# CallStack)
+ of wild1
+ { __DEFAULT ->
+ case getCallStack wild1 of {
[] ->
- case $dIP
- `cast` (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N
- :: (?callStack::CallStack) ~R# CallStack)
- of wild1 {
- __DEFAULT -> case lvl16 wild1 of wild2 { };
+ case wild1 of wild2 {
+ __DEFAULT -> case lvl16 wild2 of {};
GHC.Stack.Types.FreezeCallStack ds1 ->
case GHC.List.head1
@([Char], SrcLoc)
- (wild1
+ (wild2
`cast` (Sym (GHC.Classes.N:IP[0] <"callStack">_N <CallStack>_N)
:: CallStack ~R# (?callStack::CallStack)))
- of wild2 {
- }
+ of {}
};
: x ds1 -> case x of { (x1, ds2) -> GHC.List.$wlenAcc @Char x1 0# }
}
+ }
}
end Rec }
@@ -165,10 +170,10 @@ end Rec }
foo [InlPrag=[2]] :: HasCallStack => Int -> Int
[GblId,
Arity=2,
- Str=<SL><1!P(1L)>,
+ Str=<1L><1!P(1L)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
Tmpl= \ ($dIP [Occ=Once1] :: HasCallStack)
(eta [Occ=Once1!] :: Int) ->
@@ -186,22 +191,25 @@ foo
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T20103.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T20103.$trModule3 = GHC.Types.TrNameS T20103.$trModule4
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T20103.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T20103.$trModule1 = GHC.Types.TrNameS T20103.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T20103.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T20103.$trModule
= GHC.Types.Module T20103.$trModule3 T20103.$trModule1
=====================================
testsuite/tests/simplCore/should_compile/T22428.stderr
=====================================
@@ -6,8 +6,9 @@ Result size of Tidy Core
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T22428.f1 :: Integer
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T22428.f1 = GHC.Num.Integer.IS 1#
-- RHS size: {terms: 28, types: 10, coercions: 0, joins: 1/1}
@@ -15,8 +16,9 @@ f :: Integer -> Integer -> Integer
[GblId,
Arity=2,
Str=<SL><1L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 156 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0 0] 156 0}]
f = \ (x :: Integer) (y :: Integer) ->
joinrec {
go [InlPrag=INLINE (sat-args=1), Occ=LoopBreaker, Dmd=SC(S,L)]
@@ -24,20 +26,20 @@ f = \ (x :: Integer) (y :: Integer) ->
[LclId[JoinId(1)(Just [!])],
Arity=1,
Str=<1L>,
- Unf=Unf{Src=StableUser, TopLvl=False, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableUser, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False)}]
go (ds :: Integer)
- = case ds of wild {
- GHC.Num.Integer.IS x1 ->
- case x1 of {
- __DEFAULT -> jump go (GHC.Num.Integer.integerSub wild T22428.f1);
+ = case ds of x1 {
+ GHC.Num.Integer.IS x2 ->
+ case x2 of {
+ __DEFAULT -> jump go (GHC.Num.Integer.integerSub x1 T22428.f1);
0# -> x
};
- GHC.Num.Integer.IP x1 ->
- jump go (GHC.Num.Integer.integerSub wild T22428.f1);
- GHC.Num.Integer.IN x1 ->
- jump go (GHC.Num.Integer.integerSub wild T22428.f1)
+ GHC.Num.Integer.IP x2 ->
+ jump go (GHC.Num.Integer.integerSub x1 T22428.f1);
+ GHC.Num.Integer.IN x2 ->
+ jump go (GHC.Num.Integer.integerSub x1 T22428.f1)
}; } in
jump go y
=====================================
testsuite/tests/simplCore/should_compile/T22611.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 544, types: 486, coercions: 0, joins: 0/7}
+ = {terms: 562, types: 505, coercions: 0, joins: 0/10}
$WFound
= \ @a @m conrep conrep1 ->
@@ -54,13 +54,14 @@ $w$sgo15
__DEFAULT ->
let {
hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
- let { zeros = word2Int# (ctz# ds3) } in
- (# Just ipv4, uncheckedShiftRL# hi1 zeros,
+ let { zeros = ctz# ds3 } in
+ let { zeros1 = word2Int# zeros } in
+ (# Just ipv4, uncheckedShiftRL# hi1 zeros1,
or#
(uncheckedShiftRL#
(or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#))
- zeros)
- (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ zeros1)
+ (uncheckedShiftL# hi1 (-# 64# zeros1)) #);
0## ->
(# Just ipv4, 0##,
uncheckedShiftRL#
@@ -116,12 +117,13 @@ $w$sgo15
__DEFAULT ->
let {
hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
- let { zeros = word2Int# (ctz# ds3) } in
- (# Just ipv4, uncheckedShiftRL# hi1 zeros,
+ let { zeros = ctz# ds3 } in
+ let { zeros1 = word2Int# zeros } in
+ (# Just ipv4, uncheckedShiftRL# hi1 zeros1,
or#
(uncheckedShiftRL#
- (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros)
- (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros1)
+ (uncheckedShiftL# hi1 (-# 64# zeros1)) #);
0## ->
(# Just ipv4, 0##,
uncheckedShiftRL#
@@ -138,12 +140,13 @@ $w$sgo15
__DEFAULT ->
let {
hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
- let { zeros = word2Int# (ctz# ds3) } in
- (# Nothing, uncheckedShiftRL# hi1 zeros,
+ let { zeros = ctz# ds3 } in
+ let { zeros1 = word2Int# zeros } in
+ (# Nothing, uncheckedShiftRL# hi1 zeros1,
or#
(uncheckedShiftRL#
- (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros)
- (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros1)
+ (uncheckedShiftL# hi1 (-# 64# zeros1)) #);
0## ->
(# Nothing, 0##,
uncheckedShiftRL#
@@ -156,7 +159,8 @@ end Rec }
$salterF
= \ @v @a f1 k1 m ->
- case $w$sgo15 9223372036854775808## 0## k1 m of
+ case k1 of k2 { __DEFAULT ->
+ case $w$sgo15 9223372036854775808## 0## k2 m of
{ (# ww, ww1, ww2 #) ->
case f1 ww of {
NotFound -> NotFound;
@@ -167,18 +171,22 @@ $salterF
Nothing ->
case ww of {
Nothing -> m;
- Just old -> case $wbogus (##) of { __DEFAULT -> $wgo ww1 ww2 m }
+ Just old ->
+ case m of m1 { __DEFAULT ->
+ case $wbogus (##) of { __DEFAULT -> $wgo ww1 ww2 m1 }
+ }
};
Just new ->
case new of new1 { __DEFAULT ->
case ww of {
- Nothing -> $winsertAlong ww1 ww2 k1 new1 m;
+ Nothing -> $winsertAlong ww1 ww2 k2 new1 m;
Just ds -> $wreplaceAlong ww1 ww2 new1 m
}
}
})
}
}
+ }
lvl
= \ @v ds ->
@@ -190,10 +198,12 @@ lvl
Rec {
$wfoo
= \ @v x subst ->
- case $salterF lvl x subst of {
+ case x of x1 { __DEFAULT ->
+ case subst of subst1 { __DEFAULT ->
+ case $salterF lvl x1 subst1 of {
NotFound ->
- case x of wild1 {
- Left x1 -> $wfoo wild1 subst;
+ case x1 of wild1 {
+ Left x2 -> $wfoo wild1 subst1;
Right y ->
$wfoo
(Right
@@ -204,10 +214,12 @@ $wfoo
1# -> C# (chr# i#)
}
}))
- subst
+ subst1
};
Found p q -> (# p, q #)
}
+ }
+ }
end Rec }
foo
=====================================
testsuite/tests/simplCore/should_compile/T7360.stderr
=====================================
@@ -1,15 +1,15 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 116, types: 50, coercions: 0, joins: 0/0}
+ = {terms: 119, types: 52, coercions: 0, joins: 0/0}
-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo
[GblId[DataConWrapper],
Arity=1,
Str=<SL>,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (conrep [Occ=Once1!] :: Int) ->
case conrep of { GHC.Types.I# unbx [Occ=Once1] ->
@@ -31,8 +31,8 @@ fun1 [InlPrag=NOINLINE[final]] :: Foo -> ()
Arity=1,
Str=<1A>,
Cpr=1,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once1] :: Foo) ->
case T7360.$wfun1 x of { (# #) -> GHC.Tuple.Prim.() }}]
@@ -43,65 +43,75 @@ fun1
-- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0}
T7360.fun4 :: ()
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 30 10}]
T7360.fun4
= case T7360.$wfun1 T7360.Foo1 of { (# #) -> GHC.Tuple.Prim.() }
--- RHS size: {terms: 11, types: 7, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0}
fun2 :: forall {a}. [a] -> ((), Int)
[GblId,
Arity=1,
Str=<ML>,
Cpr=1,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (@a) (x [Occ=Once1] :: [a]) ->
(T7360.fun4,
- case GHC.List.$wlenAcc @a x 0# of ww1 [Occ=Once1] { __DEFAULT ->
+ case x of wild [Occ=Once1] { __DEFAULT ->
+ case GHC.List.$wlenAcc @a wild 0# of ww1 [Occ=Once1] { __DEFAULT ->
GHC.Types.I# ww1
+ }
})}]
fun2
= \ (@a) (x :: [a]) ->
(T7360.fun4,
- case GHC.List.$wlenAcc @a x 0# of ww1 { __DEFAULT ->
+ case x of wild { __DEFAULT ->
+ case GHC.List.$wlenAcc @a wild 0# of ww1 { __DEFAULT ->
GHC.Types.I# ww1
+ }
})
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T7360.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T7360.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T7360.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$trModule3 = GHC.Types.TrNameS T7360.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T7360.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T7360.$trModule2 = "T7360"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T7360.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$trModule1 = GHC.Types.TrNameS T7360.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T7360.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$trModule
= GHC.Types.Module T7360.$trModule3 T7360.$trModule1
@@ -115,22 +125,25 @@ $krep
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T7360.$tcFoo2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T7360.$tcFoo2 = "Foo"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T7360.$tcFoo1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$tcFoo1 = GHC.Types.TrNameS T7360.$tcFoo2
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
T7360.$tcFoo :: GHC.Types.TyCon
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$tcFoo
= GHC.Types.TyCon
1581370841583180512#Word64
@@ -150,22 +163,25 @@ T7360.$tc'Foo4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo6 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T7360.$tc'Foo6 = "'Foo1"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo5 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$tc'Foo5 = GHC.Types.TrNameS T7360.$tc'Foo6
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo1 :: GHC.Types.TyCon
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$tc'Foo1
= GHC.Types.TyCon
3986951253261644518#Word64
@@ -178,22 +194,25 @@ T7360.$tc'Foo1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo8 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T7360.$tc'Foo8 = "'Foo2"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo7 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$tc'Foo7 = GHC.Types.TrNameS T7360.$tc'Foo8
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo2 :: GHC.Types.TyCon
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$tc'Foo2
= GHC.Types.TyCon
17325079864060690428#Word64
@@ -211,22 +230,25 @@ T7360.$tc'Foo9 = GHC.Types.KindRepFun $krep T7360.$tc'Foo4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo11 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T7360.$tc'Foo11 = "'Foo3"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo10 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$tc'Foo10 = GHC.Types.TrNameS T7360.$tc'Foo11
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo3 :: GHC.Types.TyCon
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7360.$tc'Foo3
= GHC.Types.TyCon
3674231676522181654#Word64
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -417,8 +417,10 @@ test('T21391', normal, compile, ['-O -dcore-lint'])
# T22112: Simply test that dumping the Core doesn't loop becuse of the unfolding and ignore the dump output
test('T22112', [ grep_errmsg('never matches') ], compile, ['-O -dsuppress-uniques -dno-typeable-binds -fexpose-all-unfoldings -ddump-simpl'])
test('T21391a', normal, compile, ['-O -dcore-lint'])
+
# We don't want to see a thunk allocation for the insertBy expression after CorePrep.
-test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]'), expect_broken(21392) ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques'])
+test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]') ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques'])
+
test('T21689', [extra_files(['T21689a.hs'])], multimod_compile, ['T21689', '-v0 -O'])
test('T21801', normal, compile, ['-O -dcore-lint'])
test('T21848', [grep_errmsg(r'SPEC wombat') ], compile, ['-O -ddump-spec'])
=====================================
testsuite/tests/warnings/should_compile/T24396a.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE ExplicitNamespaces #-}
+
module T24396a where
class C1
=====================================
testsuite/tests/warnings/should_fail/T24396c.hs
=====================================
@@ -0,0 +1,20 @@
+
+module T24396c where
+
+
+f = id
+
+{-# WARNING data f "warning on data level" #-}
+
+data F
+
+{-# WARNING type F "warning on type level" #-}
+
+
+g = id
+
+{-# DEPRECATED data g "deprecation on data level" #-}
+
+data G
+
+{-# DEPRECATED type G "deprecation on type level" #-}
=====================================
testsuite/tests/warnings/should_fail/T24396c.stderr
=====================================
@@ -0,0 +1,24 @@
+
+T24396c.hs:7:13: error: [GHC-14995]
+ Illegal use of the ‘data’ keyword:
+ data f "warning on data level"
+ in a WARNING pragma
+ Suggested fix: Perhaps you intended to use ExplicitNamespaces
+
+T24396c.hs:11:13: error: [GHC-14995]
+ Illegal use of the ‘type’ keyword:
+ type F "warning on type level"
+ in a WARNING pragma
+ Suggested fix: Perhaps you intended to use ExplicitNamespaces
+
+T24396c.hs:16:16: error: [GHC-14995]
+ Illegal use of the ‘data’ keyword:
+ data g "deprecation on data level"
+ in a DEPRECATED pragma
+ Suggested fix: Perhaps you intended to use ExplicitNamespaces
+
+T24396c.hs:20:16: error: [GHC-14995]
+ Illegal use of the ‘type’ keyword:
+ type G "deprecation on type level"
+ in a DEPRECATED pragma
+ Suggested fix: Perhaps you intended to use ExplicitNamespaces
=====================================
testsuite/tests/warnings/should_fail/all.T
=====================================
@@ -26,3 +26,4 @@ test('WarningCategory5', [extra_files(['WarningCategory1.hs', 'WarningCategory1_
test('WarningCategory6', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -Wno-extended-warnings -Wdeprecations -Werror=warnings-deprecations'])
test('WarningCategory7', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -Werror -w -Wall'])
test('WarningCategoryInvalid', normal, compile_fail, [''])
+test('T24396c', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac5c3e4a2e5b1cdcefd1c051437211539b73b3c8...ea6e6ff98411e84dfffad9dd418496563babe54a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac5c3e4a2e5b1cdcefd1c051437211539b73b3c8...ea6e6ff98411e84dfffad9dd418496563babe54a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240205/f336c519/attachment-0001.html>
More information about the ghc-commits
mailing list