[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: DmdAnal: Don't panic in addCaseBndrDmd (#22039)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Sep 6 14:46:08 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d2be80fd by Sebastian Graf at 2022-09-05T23:12:14-04:00
DmdAnal: Don't panic in addCaseBndrDmd (#22039)
Rather conservatively return Top.
See Note [Untyped demand on case-alternative binders].
I also factored `addCaseBndrDmd` into two separate functions `scrutSubDmd` and
`fieldBndrDmds`.
Fixes #22039.
- - - - -
25f68ace by Ben Gamari at 2022-09-05T23:12:50-04:00
gitlab-ci: Ensure that ghc derivation is in scope
Previously the lint-ci job attempted to use cabal-install (specifically
`cabal update`) without a GHC in PATH. However, cabal-install-3.8
appears to want GHC, even for `cabal update`.
- - - - -
f37b621f by sheaf at 2022-09-06T11:51:53+00:00
Update instances.rst, clarifying InstanceSigs
Fixes #22103
- - - - -
841eaf36 by Cheng Shao at 2022-09-06T10:45:51-04:00
ci: remove unused build_make/test_make in ci script
- - - - -
6 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- compiler/GHC/Core/Opt/DmdAnal.hs
- docs/users_guide/exts/instances.rst
- + testsuite/tests/stranal/should_compile/T22039.hs
- testsuite/tests/stranal/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -267,7 +267,7 @@ lint-ci-config:
- mkdir -p ~/.cabal
- cp -Rf cabal-cache/* ~/.cabal || true
script:
- - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#cabal-install -c cabal update
+ - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#cabal-install nixpkgs#ghc -c cabal update
- .gitlab/generate_jobs
# 1 if .gitlab/generate_jobs changed the output of the generated config
- nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#git -c git diff --exit-code
=====================================
.gitlab/ci.sh
=====================================
@@ -50,11 +50,6 @@ Common Modes:
shell Run an interactive shell with a configured build environment.
save_cache Preserve the cabal cache
-Make build system:
-
- build_make Build GHC via the make build system
- test_make Test GHC via the make build system
-
Hadrian build system
build_hadrian Build GHC via the Hadrian build system
test_hadrian Test GHC via the Hadrian build system
@@ -436,23 +431,6 @@ function configure() {
end_section "configuring"
}
-function build_make() {
- check_release_build
- prepare_build_mk
- if [[ -z "$BIN_DIST_PREP_TAR_COMP" ]]; then
- fail "BIN_DIST_PREP_TAR_COMP is not set"
- fi
- if [[ -n "${VERBOSE:-}" ]]; then
- MAKE_ARGS="${MAKE_ARGS:-} V=1"
- else
- MAKE_ARGS="${MAKE_ARGS:-} V=0"
- fi
-
- run "$MAKE" -j"$cores" "$MAKE_ARGS"
- run "$MAKE" -j"$cores" binary-dist-prep TAR_COMP_OPTS=-1
- ls -lh "$BIN_DIST_PREP_TAR_COMP"
-}
-
function fetch_perf_notes() {
info "Fetching perf notes..."
"$TOP/.gitlab/test-metrics.sh" pull
@@ -508,23 +486,6 @@ function check_release_build() {
fi
}
-function test_make() {
- if [ -n "${CROSS_TARGET:-}" ]; then
- info "Can't test cross-compiled build."
- return
- fi
-
- check_msys2_deps inplace/bin/ghc-stage2 --version
- check_release_build
-
- run "$MAKE" test_bindist TEST_PREP=YES TEST_PROF=${RELEASE_JOB:-}
- (unset $(compgen -v | grep CI_*);
- run "$MAKE" V=0 VERBOSE=1 test \
- THREADS="$cores" \
- JUNIT_FILE=../../junit.xml \
- EXTRA_RUNTEST_OPTS="${RUNTEST_ARGS:-}")
-}
-
function build_hadrian() {
if [ -z "${BIN_DIST_NAME:-}" ]; then
fail "BIN_DIST_NAME not set"
@@ -842,13 +803,6 @@ case $1 in
usage) usage ;;
setup) setup && cleanup_submodules ;;
configure) time_it "configure" configure ;;
- build_make) time_it "build" build_make ;;
- test_make)
- fetch_perf_notes
- res=0
- time_it "test" test_make || res=$?
- push_perf_notes
- exit $res ;;
build_hadrian) time_it "build" build_hadrian ;;
# N.B. Always push notes, even if the build fails. This is okay to do as the
# testsuite driver doesn't record notes for tests that fail due to
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -455,8 +455,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs])
!(!bndrs', !scrut_sd)
| DataAlt _ <- alt_con
-- See Note [Demand on the scrutinee of a product case]
+ , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds
-- See Note [Demand on case-alternative binders]
- , (!scrut_sd, fld_dmds') <- addCaseBndrDmd case_bndr_sd fld_dmds
+ , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds)
, let !bndrs' = setBndrsDemandInfo bndrs fld_dmds'
= (bndrs', scrut_sd)
| otherwise
@@ -560,7 +561,6 @@ forcesRealWorld fam_envs ty
= False
dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt]
-
dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType []
-- Base case is botDmdType, for empty case alternatives
-- This is a unit for lubDmdType, and the right result
@@ -580,28 +580,29 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)
-- See Note [Demand on case-alternative binders]
-- we can't use the scrut_sd, because it says 'Prod' and we'll use
-- topSubDmd anyway for scrutinees of sum types.
- (!_scrut_sd, dmds') = addCaseBndrDmd case_bndr_sd dmds
+ scrut_sd = scrutSubDmd case_bndr_sd dmds
+ dmds' = fieldBndrDmds scrut_sd (length dmds)
-- Do not put a thunk into the Alt
!new_ids = setBndrsDemandInfo bndrs dmds'
= -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $
WithDmdType alt_ty (Alt con new_ids rhs')
--- Precondition: The SubDemand is not a Call
-- See Note [Demand on the scrutinee of a product case]
--- and Note [Demand on case-alternative binders]
-addCaseBndrDmd :: SubDemand -- On the case binder
- -> [Demand] -- On the fields of the constructor
- -> (SubDemand, [Demand])
- -- SubDemand on the case binder incl. field demands
- -- and final demands for the components of the constructor
-addCaseBndrDmd case_sd fld_dmds
- | Just (_, ds) <- viewProd (length fld_dmds) scrut_sd
- -- , pprTrace "addCaseBndrDmd" (ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) True
- = (scrut_sd, ds)
- | otherwise
- = pprPanic "was a call demand" (ppr case_sd $$ ppr fld_dmds) -- See the Precondition
- where
- scrut_sd = case_sd `plusSubDmd` mkProd Unboxed fld_dmds
+scrutSubDmd :: SubDemand -> [Demand] -> SubDemand
+scrutSubDmd case_sd fld_dmds =
+ -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $
+ case_sd `plusSubDmd` mkProd Unboxed fld_dmds
+
+-- See Note [Demand on case-alternative binders]
+fieldBndrDmds :: SubDemand -- on the scrutinee
+ -> Arity
+ -> [Demand] -- Final demands for the components of the DataCon
+fieldBndrDmds scrut_sd n_flds =
+ case viewProd n_flds scrut_sd of
+ Just (_, ds) -> ds
+ Nothing -> replicate n_flds topDmd
+ -- Either an arity mismatch or scrut_sd was a call demand.
+ -- See Note [Untyped demand on case-alternative binders]
{-
Note [Anticipating ANF in demand analysis]
@@ -830,6 +831,44 @@ thunk for a let binder that was an an absent case-alt binder during DmdAnal.
This is needed even for non-product types, in case the case-binder
is used but the components of the case alternative are not.
+Note [Untyped demand on case-alternative binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder
+may be a call demand or have a different number of fields than the constructor
+of the case alternative it is used in. From T22039:
+
+ blarg :: (Int, Int) -> Int
+ blarg (x,y) = x+y
+ -- blarg :: <1!P(1L,1L)>
+
+ f :: Either Int Int -> Int
+ f Left{} = 0
+ f e = blarg (unsafeCoerce e)
+ ==> { desugars to }
+ f = \ (ds_d1nV :: Either Int Int) ->
+ case ds_d1nV of wild_X1 {
+ Left ds_d1oV -> lvl_s1Q6;
+ Right ipv_s1Pl ->
+ blarg
+ (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of
+ { UnsafeRefl co_a1oT ->
+ wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int))
+ })
+ }
+
+The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call
+to `blarg`, but `Right` only has one field. Although the code will crash when
+executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively
+approximate with Top instead of panicking because of the mismatch.
+In #22039, this kind of code was guarded behind a safe `cast` and thus dead
+code, but nevertheless led to a panic of the compiler.
+
+You might wonder why the same problem doesn't come up when scrutinising a
+product type instead of a sum type. It appears that for products, `wild_X1`
+will be inlined before DmdAnal.
+
+See also Note [mkWWstr and unsafeCoerce] for a related issue.
+
Note [Aggregated demand for cardinality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FIXME: This Note should be named [LetUp vs. LetDown] and probably predates
=====================================
docs/users_guide/exts/instances.rst
=====================================
@@ -591,16 +591,15 @@ Instance signatures: type signatures in instance declarations
Allow type signatures for members in instance definitions.
-In Haskell, you can't write a type signature in an instance declaration,
-but it is sometimes convenient to do so, and the language extension
-:extension:`InstanceSigs` allows you to do so. For example: ::
+The :extension:`InstanceSigs` extension allows users to give type signatures
+to the class methods in a class instance declaration. For example: ::
data T a = MkT a a
instance Eq a => Eq (T a) where
- (==) :: T a -> T a -> Bool -- The signature
+ (==) :: T a -> T a -> Bool -- The instance signature
(==) (MkT x1 x2) (MkTy y1 y2) = x1==y1 && x2==y2
-Some details
+Some details:
- The type signature in the instance declaration must be more
polymorphic than (or the same as) the one in the class declaration,
@@ -613,11 +612,37 @@ Some details
Here the signature in the instance declaration is more polymorphic
than that required by the instantiated class method.
+ Note that, to check that the instance signature is more polymorphic,
+ GHC performs a sub-type check, which can solve constraints using available
+ top-level instances.
+ This means that the following instance signature is accepted: ::
+
+ instance Eq (T Int) where
+ (==) :: Eq Int => T Int -> T Int -> Bool
+ (==) (MkT x1 _) (MkT y1 _) = x1 == y1
+
+ The ``Eq Int`` constraint in the instance signature will be solved
+ by the top-level ``Eq Int`` instance, from which it follows that the
+ instance signature is indeed as general as the instantiated class
+ method type ``T Int -> T Int -> Bool``.
+
- The code for the method in the instance declaration is typechecked
against the type signature supplied in the instance declaration, as
you would expect. So if the instance signature is more polymorphic
than required, the code must be too.
+- The instance signature is purely local to the class instance
+ declaration. It only affects the typechecking of the method in
+ the instance; it does not affect anything outside the class
+ instance. In this way, it is similar to an inline type signature:
+
+ instance Eq a => Eq (T a) where
+ (==) = (\ x y -> True) :: forall b. b -> b -> Bool
+
+ In particular, adding constraints such as `HasCallStack` to the
+ instance signature will not have an effect; they need to be added
+ to the class instead.
+
- One stylistic reason for wanting to write a type signature is simple
documentation. Another is that you may want to bring scoped type
variables into scope. For example: ::
=====================================
testsuite/tests/stranal/should_compile/T22039.hs
=====================================
@@ -0,0 +1,59 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Bug where
+
+import Control.Exception
+import Data.Typeable
+import Unsafe.Coerce
+
+data Error
+ = Error Int String
+ | forall e . Exception e => SomeError Int e
+ deriving (Typeable)
+
+fromError :: Exception e => Error -> Maybe e
+fromError e@(Error _ _) = cast e
+fromError (SomeError _ e) = cast e
+-- {-# NOINLINE fromError #-}
+
+instance Eq Error where
+ Error i s == Error i' s' = i == i' && s == s'
+ SomeError i e == SomeError i' e' = i == i' && show e == show e'
+ _ == _ = False
+
+instance Show Error where
+ show _ = ""
+
+instance Exception Error
+
+-- newtype
+data
+ UniquenessError = UniquenessError [((String, String), Int)]
+ deriving (Show, Eq)
+
+instance Exception UniquenessError
+
+test :: SomeException -> IO ()
+test e = case fromError =<< fromException e :: Maybe UniquenessError of
+ Just err -> print err
+ _ -> pure ()
+
+--
+-- Smaller reproducer by sgraf
+--
+
+blarg :: (Int,Int) -> Int
+blarg (x,y) = x+y
+{-# NOINLINE blarg #-}
+
+f :: Either Int Int -> Int
+f Left{} = 0
+f e = blarg (unsafeCoerce e)
+
+blurg :: (Int -> Int) -> Int
+blurg f = f 42
+{-# NOINLINE blurg #-}
+
+g :: Either Int Int -> Int
+g Left{} = 0
+g e = blurg (unsafeCoerce e)
=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -85,3 +85,4 @@ test('T21150', [ grep_errmsg(r'( t\d? :: Int)') ], compile, ['-dsuppress-uniques
test('T21128', [ grep_errmsg(r'let { y = I\#') ], multimod_compile, ['T21128', '-v0 -dsuppress-uniques -dsuppress-all -ddump-simpl'])
test('T21265', normal, compile, [''])
test('EtaExpansion', normal, compile, [''])
+test('T22039', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eb1bfb1135d40cb377f7b0c1c39f93b01f34d7a4...841eaf3608769f2a4caa48c4f7bc82d1ceb24ce6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eb1bfb1135d40cb377f7b0c1c39f93b01f34d7a4...841eaf3608769f2a4caa48c4f7bc82d1ceb24ce6
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/20220906/ecdfbf1d/attachment-0001.html>
More information about the ghc-commits
mailing list