[Git][ghc/ghc][wip/T22802] 8 commits: Do newtype unwrapping in the canonicaliser and rewriter
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jan 27 08:32:58 UTC 2023
Simon Peyton Jones pushed to branch wip/T22802 at Glasgow Haskell Compiler / GHC
Commits:
3e827c3f by Richard Eisenberg at 2023-01-26T20:06:53-05:00
Do newtype unwrapping in the canonicaliser and rewriter
See Note [Unwrap newtypes first], which has the details.
Close #22519.
- - - - -
b3ef5c89 by doyougnu at 2023-01-26T20:07:48-05:00
tryFillBuffer: strictify
more speculative bangs
- - - - -
d0d7ba0f by Vladislav Zavialov at 2023-01-26T20:08:25-05:00
base: NoImplicitPrelude in Data.Void and Data.Kind
This change removes an unnecessary dependency on Prelude
from two modules in the base package.
- - - - -
fa1db923 by Matthew Pickering at 2023-01-26T20:09:00-05:00
ci: Add ubuntu18_04 nightly and release jobs
This adds release jobs for ubuntu18_04 which uses glibc 2.27 which is
older than the 2.28 which is used by Rocky8 bindists.
Ticket #22268
- - - - -
807310a1 by Matthew Pickering at 2023-01-26T20:09:00-05:00
rel-eng: Add missing rocky8 bindist
We intend to release rocky8 bindist so the fetching script needs to know
about them.
- - - - -
c7116b10 by Ben Gamari at 2023-01-26T20:09:35-05:00
base: Make changelog proposal references more consistent
Addresses #22773.
- - - - -
6932cfc7 by Sylvain Henry at 2023-01-26T20:10:27-05:00
Fix spurious change from !9568
- - - - -
9223f1cf by Simon Peyton Jones at 2023-01-27T08:33:29+00:00
Take account of loop breakers in specLookupRule
The key change is that in GHC.Core.Opt.Specialise.specLookupRule
we were using realIdUnfolding, which ignores the loop-breaker
flag. When given a loop breaker, rule matching therefore
looped infinitely -- #22802.
In fixing this I refactored a bit.
* Define GHC.Core.InScopeEnv as a data type, and use it.
(Previously it was a pair: hard to grep for.)
* Put several functions returning an IdUnfoldingFun into
GHC.Types.Id, namely
idUnfolding
alwaysActiveUnfoldingFun,
whenActiveUnfoldingFun,
noUnfoldingFun
and use them. (The are all loop-breaker aware.)
- - - - -
28 changed files:
- .gitlab-ci.yml
- .gitlab/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- hadrian/src/Settings/Builders/RunTest.hs
- libraries/base/Data/Kind.hs
- libraries/base/Data/Void.hs
- libraries/base/GHC/Foreign.hs
- libraries/base/changelog.md
- + testsuite/tests/simplCore/should_compile/T22802.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T22519.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
- DOCKER_REV: dd01591a50ea4e2aa3c106cf50ca54d38663f912
+ DOCKER_REV: 2d59d551647d102c4af44f257c520a94f04ea3f6
# Sequential version number of all cached things.
# Bump to invalidate GitLab CI cache.
=====================================
.gitlab/gen_ci.hs
=====================================
@@ -112,6 +112,7 @@ data LinuxDistro
= Debian11 | Debian10 | Debian9
| Fedora33
| Ubuntu2004
+ | Ubuntu1804
| Centos7
| Alpine
| Rocky8
@@ -270,6 +271,7 @@ distroName Debian11 = "deb11"
distroName Debian10 = "deb10"
distroName Debian9 = "deb9"
distroName Fedora33 = "fedora33"
+distroName Ubuntu1804 = "ubuntu18_04"
distroName Ubuntu2004 = "ubuntu20_04"
distroName Centos7 = "centos7"
distroName Alpine = "alpine3_12"
@@ -860,6 +862,7 @@ job_groups =
-- We still build Deb9 bindists for now due to Ubuntu 18 and Linux Mint 19
-- not being at EOL until April 2023 and they still need tinfo5.
, disableValidate (standardBuildsWithConfig Amd64 (Linux Debian9) (splitSectionsBroken vanilla))
+ , disableValidate (standardBuilds Amd64 (Linux Ubuntu1804))
, disableValidate (standardBuilds Amd64 (Linux Ubuntu2004))
, disableValidate (standardBuilds Amd64 (Linux Rocky8))
, disableValidate (standardBuildsWithConfig Amd64 (Linux Centos7) (splitSectionsBroken vanilla))
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1872,6 +1872,65 @@
"XZ_OPT": "-9"
}
},
+ "nightly-x86_64-linux-ubuntu18_04-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "8 weeks",
+ "paths": [
+ "ghc-x86_64-linux-ubuntu18_04-validate.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-ubuntu18_04-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "x86_64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu18_04-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "",
+ "TEST_ENV": "x86_64-linux-ubuntu18_04-validate",
+ "XZ_OPT": "-9"
+ }
+ },
"nightly-x86_64-linux-ubuntu20_04-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -3038,6 +3097,66 @@
"XZ_OPT": "-9"
}
},
+ "release-x86_64-linux-ubuntu18_04-release": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "1 year",
+ "paths": [
+ "ghc-x86_64-linux-ubuntu18_04-release.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-ubuntu18_04-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "x86_64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-x86_64-linux-ubuntu18_04-release",
+ "BUILD_FLAVOUR": "release",
+ "CONFIGURE_ARGS": "",
+ "IGNORE_PERF_FAILURES": "all",
+ "TEST_ENV": "x86_64-linux-ubuntu18_04-release",
+ "XZ_OPT": "-9"
+ }
+ },
"release-x86_64-linux-ubuntu20_04-release": {
"after_script": [
".gitlab/ci.sh save_cache",
=====================================
.gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
=====================================
@@ -16,7 +16,9 @@ def job_triple(job_name):
bindists = {
'release-x86_64-windows-release': 'x86_64-unknown-mingw32',
'release-x86_64-windows-int_native-release': 'x86_64-unknown-mingw32-int_native',
+ 'release-x86_64-rocky8-release': 'x86_64-rocky8-linux',
'release-x86_64-ubuntu20_04-release': 'x86_64-ubuntu20_04-linux',
+ 'release-x86_64-ubuntu18_04-release': 'x86_64-ubuntu18_04-linux',
'release-x86_64-linux-fedora33-release+debug_info': 'x86_64-fedora33-linux-dwarf',
'release-x86_64-linux-fedora33-release': 'x86_64-fedora33-linux',
'release-x86_64-linux-fedora27-release': 'x86_64-fedora27-linux',
=====================================
compiler/GHC/Core.hs
=====================================
@@ -83,7 +83,7 @@ module GHC.Core (
-- * Core rule data types
CoreRule(..),
- RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleOpts,
+ RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts,
-- ** Operations on 'CoreRule's
ruleArity, ruleName, ruleIdName, ruleActivation,
@@ -1171,10 +1171,11 @@ data CoreRule
}
-- See Note [Extra args in the target] in GHC.Core.Rules
+type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
+
-- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are
-- currently in scope. See Note [The InScopeSet invariant].
-type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
-type InScopeEnv = (InScopeSet, IdUnfoldingFun)
+data InScopeEnv = ISE InScopeSet IdUnfoldingFun
type IdUnfoldingFun = Id -> Unfolding
-- A function that embodies how to unfold an Id if you need
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1791,7 +1791,7 @@ topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
--
-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')
--
--- then (a) @co : ty ~ ty'@.
+-- then (a) @co : ty ~R ty'@.
-- (b) ty' is not a newtype.
--
-- The function returns @Nothing@ for non- at newtypes@,
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -2402,7 +2402,7 @@ match_cstring_foldr_lit _ _ _ _ _ = Nothing
-- Also, look into variable's unfolding just in case the expression we look for
-- is in a top-level thunk.
stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
-stripStrTopTicks (_,id_unf) e = case e of
+stripStrTopTicks (ISE _ id_unf) e = case e of
Var v
| Just rhs <- expandUnfolding_maybe (id_unf v)
-> stripTicksTop tickishFloatable rhs
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1241,14 +1241,13 @@ getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
-- is 'otherwise' which we want exprIsConApp_maybe to be able to
-- see very early on
getUnfoldingInRuleMatch env
- = (in_scope, id_unf)
+ = ISE in_scope id_unf
where
in_scope = seInScope env
- id_unf id | unf_is_active id = idUnfolding id
- | otherwise = NoUnfolding
- unf_is_active id = isActive (sePhase env) (idInlineActivation id)
- -- When sm_rules was off we used to test for a /stable/ unfolding,
- -- but that seems wrong (#20941)
+ phase = sePhase env
+ id_unf = whenActiveUnfoldingFun (isActive phase)
+ -- When sm_rules was off we used to test for a /stable/ unfolding,
+ -- but that seems wrong (#20941)
----------------------
activeRule :: SimplMode -> Activation -> Bool
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1626,11 +1626,11 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- See Note [Inline specialisations] for why we do not
-- switch off specialisation for inline functions
- = do { -- debugTraceMsg (text "specCalls: some" <+> vcat
- -- [ text "function" <+> ppr fn
- -- , text "calls:" <+> ppr calls_for_me
- -- , text "subst" <+> ppr (se_subst env) ])
- ; foldlM spec_call ([], [], emptyUDs) calls_for_me }
+ = -- pprTrace "specCalls: some" (vcat
+ -- [ text "function" <+> ppr fn
+ -- , text "calls:" <+> ppr calls_for_me
+ -- , text "subst" <+> ppr (se_subst env) ]) $
+ foldlM spec_call ([], [], emptyUDs) calls_for_me
| otherwise -- No calls or RHS doesn't fit our preconceptions
= warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
@@ -1685,7 +1685,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
, rule_bndrs, rule_lhs_args
, spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
--- ; debugTraceMsg (text "spec_call" <+> vcat
+-- ; pprTrace "spec_call" (vcat
-- [ text "fun: " <+> ppr fn
-- , text "call info: " <+> ppr _ci
-- , text "useful: " <+> ppr useful
@@ -1698,7 +1698,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- , text "rhs_bndrs" <+> ppr rhs_bndrs
-- , text "rhs_body" <+> ppr rhs_body
-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
--- , ppr dx_binds ]
+-- , ppr dx_binds ]) $
+-- return ()
; if not useful -- No useful specialisation
|| already_covered rhs_env2 rules_acc rule_lhs_args
@@ -1795,12 +1796,13 @@ specLookupRule :: SpecEnv -> Id -> [CoreExpr]
-> CompilerPhase -- Look up rules as if we were in this phase
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
specLookupRule env fn args phase rules
- = lookupRule ropts (in_scope, realIdUnfolding) is_active fn args rules
+ = lookupRule ropts in_scope_env is_active fn args rules
where
- dflags = se_dflags env
- in_scope = getSubstInScope (se_subst env)
- ropts = initRuleOpts dflags
- is_active = isActive phase
+ dflags = se_dflags env
+ in_scope = getSubstInScope (se_subst env)
+ in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active)
+ ropts = initRuleOpts dflags
+ is_active = isActive phase
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -514,7 +514,7 @@ lookupRule :: RuleOpts -> InScopeEnv
-- See Note [Extra args in the target]
-- See comments on matchRule
-lookupRule opts rule_env@(in_scope,_) is_active fn args rules
+lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules
= -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $
case go [] rules of
[] -> Nothing
@@ -574,11 +574,12 @@ isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True
isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })
(Rule { ru_bndrs = bndrs2, ru_args = args2
, ru_name = rule_name2, ru_rhs = rhs2 })
- = isJust (matchN (full_in_scope, id_unfolding_fun)
+ = isJust (matchN in_scope_env
rule_name2 bndrs2 args2 args1 rhs2)
where
- id_unfolding_fun _ = NoUnfolding -- Don't expand in templates
full_in_scope = in_scope `extendInScopeSetList` bndrs1
+ in_scope_env = ISE full_in_scope noUnfoldingFun
+ -- noUnfoldingFun: don't expand in templates
noBlackList :: Activation -> Bool
noBlackList _ = False -- Nothing is black listed
@@ -687,7 +688,7 @@ matchN :: InScopeEnv
-- trailing ones, returning the result of applying the rule to a prefix
-- of the actual arguments.
-matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs
+matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
= do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es
; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)
(mkEmptySubst in_scope) $
@@ -872,7 +873,7 @@ see `init_menv` in `matchN`.
-}
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
-rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)
+rvInScopeEnv renv = ISE (rnInScopeSet (rv_lcl renv)) (rv_unf renv)
-- * The domain of the TvSubstEnv and IdSubstEnv are the template
-- variables passed into the match.
@@ -1686,7 +1687,7 @@ ruleAppCheck_help env fn args rules
= text "Rule" <+> doubleQuotes (ftext name)
rule_info opts rule
- | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env)
+ | Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env))
noBlackList fn args rough_args rule
= text "matches (which is very peculiar!)"
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -242,7 +242,7 @@ simple_opt_expr env expr
rec_ids = soe_rec_ids env
subst = soe_subst env
in_scope = getSubstInScope subst
- in_scope_env = (in_scope, simpleUnfoldingFun)
+ in_scope_env = ISE in_scope alwaysActiveUnfoldingFun
---------------
go (Var v)
@@ -761,11 +761,6 @@ add_info env old_bndr top_level new_rhs new_bndr
False -- may be bottom or not
new_rhs Nothing
-simpleUnfoldingFun :: IdUnfoldingFun
-simpleUnfoldingFun id
- | isAlwaysActive (idInlineActivation id) = idUnfolding id
- | otherwise = noUnfolding
-
wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing body = body
wrapLet (Just (b,r)) body = Let (NonRec b r) body
@@ -1184,7 +1179,7 @@ data ConCont = CC [CoreExpr] Coercion
exprIsConApp_maybe :: HasDebugCallStack
=> InScopeEnv -> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-exprIsConApp_maybe (in_scope, id_unf) expr
+exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
= go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))
where
go :: Either InScopeSet Subst
@@ -1304,7 +1299,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr
| (fun `hasKey` unpackCStringIdKey) ||
(fun `hasKey` unpackCStringUtf8IdKey)
, [arg] <- args
- , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
+ , Just (LitString str) <- exprIsLiteral_maybe ise arg
= succeedWith in_scope floats $
dealWithStringLiteral fun str co
where
@@ -1400,7 +1395,7 @@ exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
-- Nevertheless we do need to look through unfoldings for
-- string literals, which are vigorously hoisted to top level
-- and not subsequently inlined
-exprIsLiteral_maybe env@(_, id_unf) e
+exprIsLiteral_maybe env@(ISE _ id_unf) e
= case e of
Lit l -> Just l
Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
@@ -1430,14 +1425,14 @@ exprIsLambda_maybe _ (Lam x e)
= Just (x, e, [])
-- Still straightforward: Ticks that we can float out of the way
-exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
+exprIsLambda_maybe ise (Tick t e)
| tickishFloatable t
- , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
+ , Just (x, e, ts) <- exprIsLambda_maybe ise e
= Just (x, e, t:ts)
-- Also possible: A casted lambda. Push the coercion inside
-exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
- | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
+exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co)
+ | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e
-- Only do value lambdas.
-- this implies that x is not in scope in gamma (makes this code simpler)
, not (isTyVar x) && not (isCoVar x)
@@ -1448,7 +1443,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
res
-- Another attempt: See if we find a partial unfolding
-exprIsLambda_maybe (in_scope_set, id_unf) e
+exprIsLambda_maybe ise@(ISE in_scope_set id_unf) e
| (Var f, as, ts) <- collectArgsTicks tickishFloatable e
, idArity f > count isValArg as
-- Make sure there is hope to get a lambda
@@ -1456,7 +1451,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) e
-- Optimize, for beta-reduction
, let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as)
-- Recurse, because of possible casts
- , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
+ , Just (x', e'', ts') <- exprIsLambda_maybe ise e'
, let res = Just (x', e'', ts++ts')
= -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
res
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -881,7 +881,7 @@ addCoreCt nabla x e = do
where
expr_ty = exprType e
expr_in_scope = mkInScopeSet (exprFreeVars e)
- in_scope_env = (expr_in_scope, const NoUnfolding)
+ in_scope_env = ISE expr_in_scope noUnfoldingFun
-- It's inconvenient to get hold of a global in-scope set
-- here, but it'll only be needed if exprIsConApp_maybe ends
-- up substituting inside a forall or lambda (i.e. seldom)
=====================================
compiler/GHC/Tc/Instance/Family.hs
=====================================
@@ -519,16 +519,16 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
= Nothing
-- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes,
--- potentially looking through newtype /instances/.
+-- potentially looking through newtype /instances/ and type synonyms.
--
-- It is only used by the type inference engine (specifically, when
-- solving representational equality), and hence it is careful to unwrap
-- only if the relevant data constructor is in scope. That's why
-- it gets a GlobalRdrEnv argument.
--
--- It is careful not to unwrap data/newtype instances if it can't
--- continue unwrapping. Such care is necessary for proper error
--- messages.
+-- It is careful not to unwrap data/newtype instances nor synonyms
+-- if it can't continue unwrapping. Such care is necessary for proper
+-- error messages.
--
-- It does not look through type families.
-- It does not normalise arguments to a tycon.
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -61,7 +61,6 @@ import GHC.Types.Basic
import qualified Data.Semigroup as S
import Data.Bifunctor ( bimap )
-import Data.Foldable ( traverse_ )
{-
************************************************************************
@@ -1085,7 +1084,7 @@ can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
-- Decompose type constructor applications
-- NB: we have expanded type synonyms already
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
+can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
| Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1
, Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2
-- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better
@@ -1093,7 +1092,7 @@ can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
-- hence no direct match on TyConApp
, not (isTypeFamilyTyCon tc1)
, not (isTypeFamilyTyCon tc2)
- = canTyConApp ev eq_rel tc1 tys1 tc2 tys2
+ = canTyConApp rewritten ev eq_rel tc1 tys1 tc2 tys2
can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
s1@(ForAllTy (Bndr _ vis1) _) _
@@ -1115,11 +1114,8 @@ can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _
-------------------
-- No similarity in type structure detected. Rewrite and try again.
-can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
- = do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1
- ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2
- ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
- ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
+can_eq_nc' False _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
+ = rewrite_and_try_again ev eq_rel ps_ty1 ps_ty2
----------------------------
-- Look for a canonical LHS. See Note [Canonical LHS].
@@ -1157,6 +1153,16 @@ can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
-- No need to call canEqFailure/canEqHardFailure because they
-- rewrite, and the types involved here are already rewritten
+-- Rewrite the two types and try again
+rewrite_and_try_again :: CtEvidence -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct)
+rewrite_and_try_again ev eq_rel ty1 ty2
+ = do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ty1
+ ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ty2
+ ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
+ ; rdr_env <- getGlobalRdrEnvTcS
+ ; envs <- getFamInstEnvs
+ ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
+
{- Note [Unsolved equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have an unsolved equality like
@@ -1379,45 +1385,84 @@ zonk_eq_types = go
combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys)
combine_rev f (Right tys) (Right ty) = Right (f ty tys)
-{- See Note [Unwrap newtypes first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Unwrap newtypes first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [Decomposing newtype equalities]
Consider
newtype N m a = MkN (m a)
-Then N will get a conservative, Nominal role for its second parameter 'a',
+N will get a conservative, Nominal role for its second parameter 'a',
because it appears as an argument to the unknown 'm'. Now consider
[W] N Maybe a ~R# N Maybe b
-If we decompose, we'll get
+If we /decompose/, we'll get
[W] a ~N# b
-But if instead we unwrap we'll get
+But if instead we /unwrap/ we'll get
[W] Maybe a ~R# Maybe b
which in turn gives us
[W] a ~R# b
which is easier to satisfy.
-Bottom line: unwrap newtypes before decomposing them!
-c.f. #9123 comment:52,53 for a compelling example.
+Conclusion: we must unwrap newtypes before decomposing them. This happens
+in `can_eq_newtype_nc`
-Note [Newtypes can blow the stack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
+But even this is challenging. Here are two cases to consider:
- newtype X = MkX (Int -> X)
- newtype Y = MkY (Int -> Y)
+Case 1:
+
+ newtype Age = MkAge Int
+ [G] c
+ [W] w1 :: IO Age ~R# IO Int
-and now wish to prove
+Case 2:
- [W] X ~R Y
+ newtype A = MkA [A]
+ [W] A ~R# [A]
-This Wanted will loop, expanding out the newtypes ever deeper looking
-for a solid match or a solid discrepancy. Indeed, there is something
-appropriate to this looping, because X and Y *do* have the same representation,
-in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized
-coercion will ever witness it. This loop won't actually cause GHC to hang,
-though, because we check our depth when unwrapping newtypes.
+For Case 1, recall that IO is an abstract newtype. Then read Note
+[Decomposing newtype equalities]. According to that Note, we should not
+decompose w1, because we have an Irred Given. Yet we still want to solve
+the wanted! We can do so by unwrapping the (non-abstract) Age newtype
+underneath the IO, giving
+ [W] w2 :: IO Int ~R# IO Int
+ w1 = (IO unwrap-Age ; w2)
+where unwrap-Age :: Age ~R# Int. Now we case solve w2 by reflexivity;
+see Note [Eager reflexivity check].
+
+Conclusion: unwrap newtypes (deeply, inside types) in the rewriter:
+specifically in GHC.Tc.Solver.Rewrite.rewrite_newtype_app.
+
+Yet for Case 2, deep rewriting would be a disaster: we would loop.
+ [W] A ~R# [A] ---> {unwrap}
+ [W] [A] ~R# [[A]]
+ ---> {decompose}
+ [W] A ~R# [A]
+
+In this case, we just want to unwrap newtypes /at the top level/, allowing us
+to succeed via Note [Eager reflexivity check]:
+ [W] A ~R# [A] ---> {unwrap at top level only}
+ [W] [A] ~R# [A]
+ ---> {reflexivity} success
+
+Conclusion: to satisfy Case 1 and Case 2, we unwrap
+* /both/ at top level, in can_eq_nc'
+* /and/ deeply, in the rewriter, rewrite_newtype_app
+
+The former unwraps outer newtypes (when the data constructor is in scope).
+The latter unwraps deeply -- but it won't be invoked in Case 2, when we can
+recognize an equality between the types [A] and [A] before rewriting
+deeply.
+
+This "before" business is delicate -- there is still a real risk of a loop
+in the type checker with recursive newtypes -- but I think we're doomed to do
+*something* delicate, as we're really trying to solve for equirecursive
+type equality. Bottom line for users: recursive newtypes are dangerous.
+See also Section 5.3.1 and 5.3.4 of
+"Safe Zero-cost Coercions for Haskell" (JFP 2016).
+
+Another approach -- which we ultimately decided against -- is described in
+Note [Decomposing newtypes a bit more aggressively].
Note [Eager reflexivity check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1462,28 +1507,22 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2
= do { traceTcS "can_eq_newtype_nc" $
vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ]
- -- check for blowing our stack:
+ -- Check for blowing our stack, and increase the depth
-- See Note [Newtypes can blow the stack]
- ; checkReductionDepth (ctEvLoc ev) ty1
+ ; let loc = ctEvLoc ev
+ ev' = ev `setCtEvLoc` bumpCtLocDepth loc
+ ; checkReductionDepth loc ty1
-- Next, we record uses of newtype constructors, since coercing
-- through newtypes is tantamount to using their constructors.
- ; addUsedGREs gre_list
- -- If a newtype constructor was imported, don't warn about not
- -- importing it...
- ; traverse_ keepAlive $ map greMangledName gre_list
- -- ...and similarly, if a newtype constructor was defined in the same
- -- module, don't warn about it being unused.
- -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.
+ ; recordUsedGREs gres
; let redn1 = mkReduction co1 ty1'
- ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
+ ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped
redn1
(mkReflRedn Representational ps_ty2)
; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
- where
- gre_list = bagToList gres
---------
-- ^ Decompose a type application.
@@ -1559,7 +1598,8 @@ canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2
role = eqRelRole eq_rel
------------------------
-canTyConApp :: CtEvidence -> EqRel
+canTyConApp :: Bool -- True <=> the types have been rewritten
+ -> CtEvidence -> EqRel
-> TyCon -> [TcType]
-> TyCon -> [TcType]
-> TcS (StopOrContinue Ct)
@@ -1567,13 +1607,17 @@ canTyConApp :: CtEvidence -> EqRel
-- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family
-- But they can be data families.
-canTyConApp ev eq_rel tc1 tys1 tc2 tys2
+canTyConApp rewritten ev eq_rel tc1 tys1 tc2 tys2
| tc1 == tc2
, tys1 `equalLength` tys2
= do { inerts <- getTcSInerts
; if can_decompose inerts
then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2
- else canEqFailure ev eq_rel ty1 ty2 }
+ else if rewritten
+ then canEqFailure ev eq_rel ty1 ty2
+ else rewrite_and_try_again ev eq_rel ty1 ty2 }
+ -- Why rewrite and try again? See Case 1
+ -- of Note [Unwrap newtypes first]
-- See Note [Skolem abstract data] in GHC.Core.Tycon
| tyConSkolem tc1 || tyConSkolem tc2
@@ -1851,8 +1895,12 @@ only about /completeness/.
Note [Decomposing newtypes a bit more aggressively]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-c.f. https://github.com/ghc-proposals/ghc-proposals/pull/549,
-issue #22441, and discussion on !9282.
+IMPORTANT: the ideas in this Note are *not* implemented. Instead, the
+current approach is detailed in Note [Unwrap newtypes first].
+For more details about the ideas in this Note see
+ * GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549
+ * issue #22441
+ * discussion on !9282.
Consider [G] c, [W] (IO Int) ~R (IO Age)
where IO is abstract, and
@@ -2091,8 +2139,8 @@ canEqHardFailure :: CtEvidence
-- See Note [Make sure that insolubles are fully rewritten]
canEqHardFailure ev ty1 ty2
= do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)
- ; (redn1, rewriters1) <- rewrite ev ty1
- ; (redn2, rewriters2) <- rewrite ev ty2
+ ; (redn1, rewriters1) <- rewriteForErrors ev ty1
+ ; (redn2, rewriters2) <- rewriteForErrors ev ty2
; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
; continueWith (mkIrredCt ShapeMismatchReason new_ev) }
@@ -3203,12 +3251,12 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
= do { let new_tm = evCoercion ( mkSymCo lhs_co
`mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar)
`mkTransCo` rhs_co)
- ; newGivenEvVar loc' (new_pred, new_tm) }
+ ; newGivenEvVar loc (new_pred, new_tm) }
| CtWanted { ctev_dest = dest
, ctev_rewriters = rewriters } <- old_ev
, let rewriters' = rewriters S.<> new_rewriters
- = do { (new_ev, hole_co) <- newWantedEq loc' rewriters'
+ = do { (new_ev, hole_co) <- newWantedEq loc rewriters'
(ctEvRole old_ev) nlhs nrhs
; let co = maybeSymCo swapped $
lhs_co
@@ -3228,12 +3276,7 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
#endif
where
new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
-
- -- equality is like a type class. Bumping the depth is necessary because
- -- of recursive newtypes, where "reducing" a newtype can actually make
- -- it bigger. See Note [Newtypes can blow the stack].
loc = ctEvLoc old_ev
- loc' = bumpCtLocDepth loc
{-
************************************************************************
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Tc.Solver.Monad (
updWorkListTcS,
pushLevelNoWorkList,
- runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,
+ runTcPluginTcS, recordUsedGREs,
matchGlobalInst, TcM.ClsInstResult(..),
QCInst(..),
@@ -151,7 +151,7 @@ import GHC.Core.TyCon
import GHC.Types.Error ( mkPlainError, noHints )
import GHC.Types.Name
import GHC.Types.TyThing
-import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )
+import GHC.Types.Name.Reader
import GHC.Unit.Module ( HasModule, getModule, extractModule )
import qualified GHC.Rename.Env as TcM
@@ -175,7 +175,8 @@ import Control.Monad
import GHC.Utils.Monad
import Data.IORef
import GHC.Exts (oneShot)
-import Data.List ( mapAccumL, partition, find )
+import Data.List ( mapAccumL, partition )
+import Data.Foldable
#if defined(DEBUG)
import GHC.Data.Graph.Directed
@@ -1373,17 +1374,22 @@ tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
tcLookupId :: Name -> TcS Id
tcLookupId n = wrapTcS $ TcM.tcLookupId n
--- Setting names as used (used in the deriving of Coercible evidence)
--- Too hackish to expose it to TcS? In that case somehow extract the used
--- constructors from the result of solveInteract
-addUsedGREs :: [GlobalRdrElt] -> TcS ()
-addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres
+-- Any use of this function is a bit suspect, because it violates the
+-- pure veneer of TcS. But it's just about warnings around unused imports
+-- and local constructors (GHC will issue fewer warnings than it otherwise
+-- might), so it's not worth losing sleep over.
+recordUsedGREs :: Bag GlobalRdrElt -> TcS ()
+recordUsedGREs gres
+ = do { wrapTcS $ TcM.addUsedGREs gre_list
+ -- If a newtype constructor was imported, don't warn about not
+ -- importing it...
+ ; wrapTcS $ traverse_ (TcM.keepAlive . greMangledName) gre_list }
+ -- ...and similarly, if a newtype constructor was defined in the same
+ -- module, don't warn about it being unused.
+ -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.
-addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()
-addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre
-
-keepAlive :: Name -> TcS ()
-keepAlive = wrapTcS . TcM.keepAlive
+ where
+ gre_list = bagToList gres
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Solver/Rewrite.hs
=====================================
@@ -3,7 +3,7 @@
{-# LANGUAGE DeriveFunctor #-}
module GHC.Tc.Solver.Rewrite(
- rewrite, rewriteArgsNom,
+ rewrite, rewriteForErrors, rewriteArgsNom,
rewriteType
) where
@@ -42,6 +42,7 @@ import GHC.Builtin.Types (tYPETyCon)
import Data.List ( find )
import GHC.Data.List.Infinite (Infinite)
import qualified GHC.Data.List.Infinite as Inf
+import GHC.Tc.Instance.Family (tcTopNormaliseNewTypeTF_maybe)
{-
************************************************************************
@@ -223,6 +224,22 @@ rewrite ev ty
; traceTcS "rewrite }" (ppr $ reductionReducedType redn)
; return result }
+-- | See Note [Rewriting]
+-- This variant of 'rewrite' rewrites w.r.t. nominal equality only,
+-- as this is better than full rewriting for error messages. Specifically,
+-- we want to avoid unwrapping newtypes, as doing so can end up causing
+-- an otherwise-unnecessary stack overflow.
+rewriteForErrors :: CtEvidence -> TcType
+ -> TcS (Reduction, RewriterSet)
+rewriteForErrors ev ty
+ = do { traceTcS "rewriteForErrors {" (ppr ty)
+ ; result@(redn, rewriters) <-
+ runRewrite (ctEvLoc ev) (ctEvFlavour ev) NomEq (rewrite_one ty)
+ ; traceTcS "rewriteForErrors }" (ppr $ reductionReducedType redn)
+ ; return $ case ctEvEqRel ev of
+ NomEq -> result
+ ReprEq -> (mkSubRedn redn, rewriters) }
+
-- See Note [Rewriting]
rewriteArgsNom :: CtEvidence -> TyCon -> [TcType]
-> TcS (Reductions, RewriterSet)
@@ -482,16 +499,27 @@ rewrite_one (TyVarTy tv)
rewrite_one (AppTy ty1 ty2)
= rewrite_app_tys ty1 [ty2]
-rewrite_one (TyConApp tc tys)
+rewrite_one ty@(TyConApp tc tys)
-- If it's a type family application, try to reduce it
| isTypeFamilyTyCon tc
= rewrite_fam_app tc tys
- -- For * a normal data type application
- -- * data family application
- -- we just recursively rewrite the arguments.
| otherwise
- = rewrite_ty_con_app tc tys
+ = do { eq_rel <- getEqRel
+ ; if eq_rel == ReprEq
+
+ then -- Rewriting w.r.t. representational equality requires
+ -- unwrapping newtypes; see GHC.Tc.Solver.Canonical.
+ -- Note [Unwrap newtypes first]
+ -- NB: try rewrite_newtype_app even when tc isn't a newtype;
+ -- the allows the possibility of having a newtype buried under
+ -- a synonym. Needed for e.g. T12067.
+ rewrite_newtype_app ty
+
+ else -- For * a normal data type application
+ -- * data family application
+ -- we just recursively rewrite the arguments.
+ rewrite_ty_con_app tc tys }
rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
= do { arg_redn <- rewrite_one ty1
@@ -650,7 +678,43 @@ rewrite_vector ki roles tys
fvs = tyCoVarsOfType ki
{-# INLINE rewrite_vector #-}
-{-
+-- Rewrite a (potential) newtype application
+-- Precondition: the ambient EqRel is ReprEq
+-- Precondition: the type is a TyConApp
+-- See Note [Newtypes can blow the stack]
+rewrite_newtype_app :: TcType -> RewriteM Reduction
+rewrite_newtype_app ty@(TyConApp tc tys)
+ = do { rdr_env <- liftTcS getGlobalRdrEnvTcS
+ ; tf_envs <- liftTcS getFamInstEnvs
+ ; case (tcTopNormaliseNewTypeTF_maybe tf_envs rdr_env ty) of
+ Nothing -> -- Non-newtype or abstract newtype
+ rewrite_ty_con_app tc tys
+
+ Just ((used_ctors, co), ty') -- co :: ty ~ ty'
+ -> do { liftTcS $ recordUsedGREs used_ctors
+ ; checkStackDepth ty
+ ; rewrite_reduction (Reduction co ty') } }
+
+rewrite_newtype_app other_ty = pprPanic "rewrite_newtype_app" (ppr other_ty)
+
+{- Note [Newtypes can blow the stack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+ newtype X = MkX (Int -> X)
+ newtype Y = MkY (Int -> Y)
+
+and now wish to prove
+
+ [W] X ~R Y
+
+This Wanted will loop, expanding out the newtypes ever deeper looking
+for a solid match or a solid discrepancy. Indeed, there is something
+appropriate to this looping, because X and Y *do* have the same representation,
+in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized
+coercion will ever witness it. This loop won't actually cause GHC to hang,
+though, because we check our depth when unwrapping newtypes.
+
Note [Rewriting synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Not expanding synonyms aggressively improves error messages, and
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -294,6 +294,7 @@ data RewriteEnv
-- ^ At what role are we rewriting?
--
-- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite
+
, re_rewriters :: !(TcRef RewriterSet) -- ^ See Note [Wanteds rewrite Wanteds]
}
-- RewriteEnv is mostly used in @GHC.Tc.Solver.Rewrite@, but it is defined
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -92,12 +92,14 @@ module GHC.Types.Id (
-- ** Reading 'IdInfo' fields
idArity,
idCallArity, idFunRepArity,
- idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo, idLFInfo_maybe,
idOneShotInfo,
idOccInfo,
+ IdUnfoldingFun, idUnfolding, realIdUnfolding,
+ alwaysActiveUnfoldingFun, whenActiveUnfoldingFun, noUnfoldingFun,
+
-- ** Writing 'IdInfo' fields
setIdUnfolding, zapIdUnfolding, setCaseBndrEvald,
setIdArity,
@@ -126,8 +128,9 @@ module GHC.Types.Id (
import GHC.Prelude
-import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,
- isCompulsoryUnfolding, Unfolding( NoUnfolding ), isEvaldUnfolding, hasSomeUnfolding, noUnfolding )
+import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding
+ , isCompulsoryUnfolding, Unfolding( NoUnfolding )
+ , IdUnfoldingFun, isEvaldUnfolding, hasSomeUnfolding, noUnfolding )
import GHC.Types.Id.Info
import GHC.Types.Basic
@@ -744,9 +747,28 @@ idTagSig_maybe = tagSig . idInfo
-- loop breaker. See 'unfoldingInfo'.
--
-- If you really want the unfolding of a strong loopbreaker, call 'realIdUnfolding'.
-idUnfolding :: Id -> Unfolding
+idUnfolding :: IdUnfoldingFun
idUnfolding id = unfoldingInfo (idInfo id)
+noUnfoldingFun :: IdUnfoldingFun
+noUnfoldingFun _id = noUnfolding
+
+-- | Returns an unfolding only if
+-- (a) not a strong loop breaker and
+-- (b) always active
+alwaysActiveUnfoldingFun :: IdUnfoldingFun
+alwaysActiveUnfoldingFun id
+ | isAlwaysActive (idInlineActivation id) = idUnfolding id
+ | otherwise = noUnfolding
+
+-- | Returns an unfolding only if
+-- (a) not a strong loop breaker and
+-- (b) active in according to is_active
+whenActiveUnfoldingFun :: (Activation -> Bool) -> IdUnfoldingFun
+whenActiveUnfoldingFun is_active id
+ | is_active (idInlineActivation id) = idUnfolding id
+ | otherwise = NoUnfolding
+
realIdUnfolding :: Id -> Unfolding
-- ^ Expose the unfolding if there is one, including for loop breakers
realIdUnfolding id = realUnfoldingInfo (idInfo id)
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -469,7 +469,7 @@ setOccInfo info oc = oc `seq` info { occInfo = oc }
unfoldingInfo :: IdInfo -> Unfolding
unfoldingInfo info
| isStrongLoopBreaker (occInfo info) = trimUnfolding $ realUnfoldingInfo info
- | otherwise = realUnfoldingInfo info
+ | otherwise = realUnfoldingInfo info
setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo info uf
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -145,7 +145,7 @@ outOfTreeCompilerArgs = do
withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen
withInterpreter <- getBooleanSetting TestGhcWithInterpreter
unregisterised <- getBooleanSetting TestGhcUnregisterised
- tables_next_to_code <- getBooleanSetting TestGhcUnregisterised
+ tables_next_to_code <- getBooleanSetting TestGhcTablesNextToCode
targetWithSMP <- targetSupportsSMP
debugAssertions <- getBooleanSetting TestGhcDebugged
=====================================
libraries/base/Data/Kind.hs
=====================================
@@ -1,4 +1,5 @@
-{-# LANGUAGE Trustworthy, ExplicitNamespaces #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
=====================================
libraries/base/Data/Void.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
=====================================
libraries/base/GHC/Foreign.hs
=====================================
@@ -202,11 +202,11 @@ peekEncodedCString :: TextEncoding -- ^ Encoding of CString
peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes)
= bracket mk_decoder close $ \decoder -> do
let chunk_size = sz_bytes `max` 1 -- Decode buffer chunk size in characters: one iteration only for ASCII
- from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p)
- to <- newCharBuffer chunk_size WriteBuffer
+ !from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p)
+ !to <- newCharBuffer chunk_size WriteBuffer
- let go !iteration from = do
- (why, from', to') <- encode decoder from to
+ let go !iteration !from = do
+ (why, from', !to') <- encode decoder from to
if isEmptyBuffer from'
then
-- No input remaining: @why@ will be InputUnderflow, but we don't care
@@ -281,11 +281,11 @@ newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s
tryFillBuffer :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int
-> IO (Maybe (Buffer Word8))
-tryFillBuffer encoder null_terminate from0 to_p to_sz_bytes = do
- to_fp <- newForeignPtr_ to_p
- go (0 :: Int) (from0, emptyBuffer to_fp to_sz_bytes WriteBuffer)
+tryFillBuffer encoder null_terminate from0 to_p !to_sz_bytes = do
+ !to_fp <- newForeignPtr_ to_p
+ go (0 :: Int) from0 (emptyBuffer to_fp to_sz_bytes WriteBuffer)
where
- go !iteration (from, to) = do
+ go !iteration !from !to = do
(why, from', to') <- encode encoder from to
putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from')
if isEmptyBuffer from'
@@ -293,8 +293,8 @@ tryFillBuffer encoder null_terminate from0 to_p to_sz_bytes = do
then return Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer
else return (Just to')
else case why of -- We didn't consume all of the input
- InputUnderflow -> recover encoder from' to' >>= go (iteration + 1) -- These conditions are equally bad
- InvalidSequence -> recover encoder from' to' >>= go (iteration + 1) -- since the input was truncated/invalid
+ InputUnderflow -> recover encoder from' to' >>= \(a,b) -> go (iteration + 1) a b -- These conditions are equally bad
+ InvalidSequence -> recover encoder from' to' >>= \(a,b) -> go (iteration + 1) a b -- since the input was truncated/invalid
OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more
{-
Note [Check *before* fill in withEncodedCString]
=====================================
libraries/base/changelog.md
=====================================
@@ -1,20 +1,23 @@
# Changelog for [`base` package](http://hackage.haskell.org/package/base)
## 4.18.0.0 *TBA*
- * Add `forall a. Functor (p a)` superclass for `Bifunctor p`.
- * Add Functor instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and
- `(,,,,,) a b c d e f`.
+ * Add `forall a. Functor (p a)` superclass for `Bifunctor p` ([CLC proposal #91](https://github.com/haskell/core-libraries-committee/issues/91))
+ * Add `Functor` instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and
+ `(,,,,,) a b c d e f`
* Exceptions thrown by weak pointer finalizers are now reported via a global
exception handler.
- * Add `GHC.Weak.Finalize.{get,set}FinalizerExceptionHandler` which the user to
- override the above-mentioned handler.
- * `Numeric.Natural` re-exports `GHC.Natural.minusNaturalMaybe`.
- * Add `Data.Foldable1` and `Data.Bifoldable1`.
- * Add `applyWhen` to `Data.Function`.
- * Add functions `mapAccumM` and `forAccumM` to `Data.Traversable`, per the
- [Core Libraries proposal](https://github.com/haskell/core-libraries-committee/issues/65).
+ * Add `GHC.Weak.Finalize.{get,set}FinalizerExceptionHandler` which allows the
+ user to override the above-mentioned handler.
+ * `Numeric.Natural` re-exports `GHC.Natural.minusNaturalMaybe`
+ ([CLC proposal #45](https://github.com/haskell/core-libraries-committee/issues/45))
+ * Add `Data.Foldable1` and `Data.Bifoldable1`
+ ([CLC proposal #9](https://github.com/haskell/core-libraries-committee/issues/9))
+ * Add `applyWhen` to `Data.Function`
+ ([CLC proposal #71](https://github.com/haskell/core-libraries-committee/issues/71))
+ * Add functions `mapAccumM` and `forAccumM` to `Data.Traversable`
+ ([CLC proposal #65](https://github.com/haskell/core-libraries-committee/issues/65))
* Add default implementation of `(<>)` in terms of `sconcat` and `mempty` in
- terms of `mconcat`.
+ terms of `mconcat` ([CLC proposal #61](https://github.com/haskell/core-libraries-committee/issues/61)).
* `GHC.Conc.Sync.listThreads` was added, allowing the user to list the threads
(both running and blocked) of the program.
* `GHC.Conc.Sync.labelThreadByteArray#` was added, allowing the user to specify
@@ -23,25 +26,24 @@
function.
* `GHC.Conc.Sync.threadLabel` was added, allowing the user to query the label
of a given `ThreadId`.
- * Add `inits1` and `tails1` to `Data.List.NonEmpty`.
+ * Add `inits1` and `tails1` to `Data.List.NonEmpty`
+ ([CLC proposal #67](https://github.com/haskell/core-libraries-committee/issues/67))
* Change default `Ord` implementation of `(>=)`, `(>)`, and `(<)` to use
- `(<=)` instead of `compare` per
- [Core Libraries proposal](https://github.com/haskell/core-libraries-committee/issues/24).
+ `(<=)` instead of `compare` ([CLC proposal #24](https://github.com/haskell/core-libraries-committee/issues/24)).
* Export `liftA2` from `Prelude`. This means that the entirety of `Applicative`
- is now exported from `Prelude`. See [CLC #50](https://github.com/haskell/core-libraries-committee/issues/50)
- for the related discussion,
- as well as [the migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/export-lifta2-prelude.md)
+ is now exported from `Prelude`
+ ([CLC proposal #50](https://github.com/haskell/core-libraries-committee/issues/50),
+ [the migration
+ guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/export-lifta2-prelude.md))
* Update to [Unicode 15.0.0](https://www.unicode.org/versions/Unicode15.0.0/).
* Add standard Unicode case predicates `isUpperCase` and `isLowerCase` to
`GHC.Unicode` and `Data.Char`. These predicates use the standard Unicode
- case properties and are more intuitive than `isUpper` and `isLower`. See
- [CLC proposal #90](https://github.com/haskell/core-libraries-committee/issues/90).
+ case properties and are more intuitive than `isUpper` and `isLower`
+ ([CLC proposal #90](https://github.com/haskell/core-libraries-committee/issues/90))
* Add `Eq` and `Ord` instances for `Generically1`.
* Relax instances for Functor combinators; put superclass on Class1 and Class2
- to make non-breaking. See [CLC
- #10](https://github.com/haskell/core-libraries-committee/issues/10) for the
- related discussion, as well as [the migration
- guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/functor-combinator-instances-and-class1s.md).
+ to make non-breaking ([CLC proposal #10](https://github.com/haskell/core-libraries-committee/issues/10),
+ [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/functor-combinator-instances-and-class1s.md))
* Add `gcdetails_block_fragmentation_bytes` to `GHC.Stats.GCDetails` to track heap fragmentation.
* `GHC.TypeLits` and `GHC.TypeNats` now export the `natSing`, `symbolSing`,
and `charSing` methods of `KnownNat`, `KnownSymbol`, and `KnownChar`,
@@ -50,16 +52,16 @@
types, per
[CLC proposal #85](https://github.com/haskell/core-libraries-committee/issues/85).
* The `Enum` instance of `Down a` now enumerates values in the opposite
- order as the `Enum a` instance, per
- [CLC proposal #51](https://github.com/haskell/core-libraries-committee/issues/51).
+ order as the `Enum a` instance ([CLC proposal #51](https://github.com/haskell/core-libraries-committee/issues/51))
* `Foreign.Marshal.Pool` now uses the RTS internal arena instead of libc
`malloc` for allocation. It avoids the O(n) overhead of maintaining a list
of individually allocated pointers as well as freeing each one of them when
- freeing a `Pool`. (#14762) (#18338)
+ freeing a `Pool` (#14762, #18338)
* `Type.Reflection.Unsafe` is now marked as unsafe.
- * Add `Data.Typeable.heqT`, a kind-heterogeneous version of `Data.Typeable.eqT`.
- * Add `Data.List.!?` per
- [CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110).
+ * Add `Data.Typeable.heqT`, a kind-heterogeneous version of
+ `Data.Typeable.eqT`
+ ([CLC proposal #99](https://github.com/haskell/core-libraries-committee/issues/99))
+ * Add `Data.List.!?` ([CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110))
* `maximumBy`/`minimumBy` are now marked as `INLINE` improving performance for unpackable
types significantly.
=====================================
testsuite/tests/simplCore/should_compile/T22802.hs
=====================================
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -O1 #-}
+module T22802 where
+
+class C a where
+ f :: a -> a -> a
+ g :: a -> a -> a
+instance C () where
+ f = g
+ g = f
+
+h :: a -> () -> ()
+h = mapFB f (const ())
+
+mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
+{-# INLINE [0] mapFB #-}
+mapFB c f = \x ys -> c (f x) ys
+
+{-# RULES
+"my-mapFB" forall c a b. mapFB (mapFB c a) b = mapFB c (a.b)
+ #-}
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -470,3 +470,4 @@ test('T22725', normal, compile, ['-O'])
test('T22502', normal, compile, ['-O'])
test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
+test('T22802', normal, compile, ['-O'])
=====================================
testsuite/tests/typecheck/should_compile/T22519.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module Bug where
+
+import Data.Coerce (coerce)
+import Data.Kind (Type)
+import GHC.TypeNats (Nat, type (<=))
+
+f :: (1 <= w)
+ => IO (SymBV' sym w)
+ -> IO (SymBV sym w)
+f = coerce
+
+----
+
+data BaseType = BaseBVType Nat
+type family SymExpr (sym :: Type) :: BaseType -> Type
+type SymBV sym n = SymExpr sym (BaseBVType n)
+newtype SymBV' sym w = MkSymBV' (SymBV sym w)
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -457,6 +457,7 @@ test('T10335', normal, compile, [''])
test('Improvement', normal, compile, [''])
test('T10009', normal, compile, [''])
test('T10390', normal, compile, [''])
+test('T22519', normal, compile, [''])
test('T8555', normal, compile, [''])
test('T8799', normal, compile, [''])
test('T10432', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6d97a9100fa615283b2b2a6041fdd17007adc9f0...9223f1cf509169e8425ac78fc05fc943fba81727
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6d97a9100fa615283b2b2a6041fdd17007adc9f0...9223f1cf509169e8425ac78fc05fc943fba81727
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/20230127/65d83636/attachment-0001.html>
More information about the ghc-commits
mailing list