[Git][ghc/ghc][wip/9.4.7-backports] 11 commits: Bump bytestring submodule to 0.11.5.2 (#23789)
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Sun Aug 20 23:14:11 UTC 2023
Zubin pushed to branch wip/9.4.7-backports at Glasgow Haskell Compiler / GHC
Commits:
3266eba3 by Zubin Duggal at 2023-08-21T04:43:22+05:30
Bump bytestring submodule to 0.11.5.2 (#23789)
- - - - -
724133db by Zubin Duggal at 2023-08-21T04:43:28+05:30
Specialise: Cherry-pick fix for #21332 from
commit 4d2ee313f23a4454d12c9f94ff132f078dd64d31
Author: Sebastian Graf <sebastian.graf at kit.edu>
Date: Thu Apr 7 17:21:08 2022 +0200
Specialising through specialised method calls (#19644)
- - - - -
58d7b006 by Simon Peyton Jones at 2023-08-21T04:43:28+05:30
Fix substitution in bindAuxiliaryDict
In GHC.Core.Opt.Specialise.bindAuxiliaryDict we were unnecessarily
calling `extendInScope` to bring into scope variables that were
/already/ in scope. Worse, GHC.Core.Subst.extendInScope strangely
deleted the newly-in-scope variables from the substitution -- and that
was fatal in #21391.
I removed the redundant calls to extendInScope.
More ambitiously, I changed GHC.Core.Subst.extendInScope (and cousins)
to stop deleting variables from the substitution. I even changed the
names of the function to extendSubstInScope (and cousins) and audited
all the calls to check that deleting from the substitution was wrong.
In fact there are very few such calls, and they are all about
introducing a fresh non-in-scope variable. These are "OutIds"; it is
utterly wrong to mess with the "InId" substitution.
I have not added a Note, because I'm deleting wrong code, and it'd be
distracting to document a bug.
(cherry picked from commit 000b7d3d2f9211c3243d34a47ce93eb985d0cc88)
- - - - -
56127dd2 by Simon Peyton Jones at 2023-08-21T04:43:28+05:30
Improve floated dicts in Specialise
Second fix to #21391. It turned out that we missed calling
bringFloatedDictsIntoScope when specialising imports, which
led to the same bug as before.
I refactored to move that call to a single place, in specCalls,
so we can't forget it.
This meant making `FloatedDictBinds` into its own type, pairing
the dictionary bindings themselves with the set of their binders.
Nicer this way.
(cherry picked from commit 2c541f99f5a83cee873b76b3bd46e4d617f5bcd7)
- - - - -
9f5a783b by Simon Peyton Jones at 2023-08-21T04:43:28+05:30
Ensure floated dictionaries are in scope (again)
In the Specialiser, we missed one more call to
bringFloatedDictsIntoScope (see #21391).
This omission led to #21689. The problem is that the call
to `rewriteClassOps` needs to have in scope any dictionaries
floated out of the arguments we have just specialised.
Easy fix.
(cherry picked from commit 04209f2a6a49f6cdc116b5cb73ccd1749c90f88b)
- - - - -
e5f6e260 by Simon Peyton Jones at 2023-08-21T04:43:28+05:30
Fix a scoping bug in the Specialiser
In the call to `specLookupRule` in `already_covered`, in `specCalls`,
we need an in-scope set that includes the free vars of the arguments.
But we simply were not guaranteeing that: did not include the
`rule_bndrs`.
Easily fixed. I'm not sure how how this bug has lain for quite
so long without biting us.
Fixes #21828.
(cherry picked from commit 460505345e500eb902da9737c75c077d5fc5ef66)
- - - - -
7deeb495 by Jens Petersen at 2023-08-21T04:43:28+05:30
make hadrian buildable with Cabal-3.8
(cherry picked from commit 5042fb142daa7275e8bb16ff7575cd8de0e017d6)
- - - - -
7122bc44 by Matthew Pickering at 2023-08-21T04:43:29+05:30
Build vanilla alpine bindists
We currently attempt to build and distribute fully static alpine
bindists (ones which could be used on any linux platform) but most
people who use the alpine bindists want to use alpine to build their own
static applications (for which a fully static bindist is not necessary).
We should build and distribute these bindists for these users whilst the
fully-static bindist is still unusable.
Fixes #23349
(cherry picked from commit 29be39ba3f187279b19cf451f2d8f58822edab4f)
- - - - -
27ae6fea by Ben Gamari at 2023-08-21T04:43:29+05:30
users-guide: Support both distutils and packaging
As noted in #23818, some old distributions (e.g. Debian 9) only include
`distutils` while newer distributions only include `packaging`.
Fixes #23818.
(cherry picked from commit d814bda97994df01139c2a9bcde915dc86ef2927)
- - - - -
d0e239bf by Ben Gamari at 2023-08-21T04:43:29+05:30
users-guide: Ensure extlinks is compatible with Sphinx <4
The semantics of the `extlinks` attribute annoyingly changed in Sphinx
4. Reflect this in our configuration. See #22690.
Fixes #23807.
(cherry picked from commit 1726db3f39f1c41b92b1bdf45e9dc054b401e782)
- - - - -
3cc991a9 by Zubin Duggal at 2023-08-21T04:43:29+05:30
Prepare release 9.4.7
- - - - -
22 changed files:
- .gitlab/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Plugins.hs
- configure.ac
- + docs/users_guide/9.4.7-notes.rst
- docs/users_guide/flags.py
- docs/users_guide/ghc_config.py.in
- docs/users_guide/release-notes.rst
- docs/users_guide/utils.py
- hadrian/hadrian.cabal
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- libraries/bytestring
- + testsuite/tests/simplCore/should_compile/T21391.hs
- + testsuite/tests/simplCore/should_compile/T21391a.hs
- + testsuite/tests/simplCore/should_compile/T21689.hs
- + testsuite/tests/simplCore/should_compile/T21689a.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
.gitlab/gen_ci.hs
=====================================
@@ -363,7 +363,7 @@ distroVariables Alpine = mconcat
-- T10458, ghcilink002: due to #17869
-- linker_unload_native: due to musl not supporting any means of probing dynlib dependencies
-- (see Note [Object unloading]).
- , "BROKEN_TESTS" =: "encoding004 T10458 ghcilink002 linker_unload_native"
+ , "BROKEN_TESTS" =: "encoding004 T10458 linker_unload_native"
]
distroVariables Centos7 = mconcat [
"HADRIAN_ARGS" =: "--docs=no-sphinx"
@@ -789,11 +789,18 @@ jobs = M.fromList $ concatMap flattenJobGroup $
, standardBuilds AArch64 (Linux Debian10)
, allowFailureGroup (addValidateRule ARMLabel (standardBuilds ARMv7 (Linux Debian10)))
, standardBuilds I386 (Linux Debian9)
- , allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) static)
- , disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt))
+ -- Fully static build, in theory usable on any linux distribution.
+ , allowFailureGroup (fullyStaticBrokenTests (standardBuildsWithConfig Amd64 (Linux Alpine) static))
+ , disableValidate (fullyStaticBrokenTests (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt)))
+ -- Dynamically linked build, suitable for building your own static executables on alpine
+ , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine) vanilla)
]
where
+
+ -- ghcilink002 broken due to #17869
+ fullyStaticBrokenTests = modifyJobs (addVariable "BROKEN_TESTS" "ghcilink002 ")
+
hackage_doc_job = rename (<> "-hackage") . modifyJobs (addVariable "HADRIAN_ARGS" "--haddock-base-url")
tsan_jobs =
=====================================
.gitlab/jobs.yaml
=====================================
@@ -661,7 +661,7 @@
"variables": {
"BIGNUM_BACKEND": "native",
"BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-int_native-validate+fully_static",
- "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native",
+ "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native",
"BUILD_FLAVOUR": "validate+fully_static",
"CONFIGURE_ARGS": "--disable-ld-override ",
"HADRIAN_ARGS": "--docs=no-sphinx",
@@ -670,6 +670,68 @@
"XZ_OPT": "-9"
}
},
+ "nightly-x86_64-linux-alpine3_12-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-alpine3_12-validate.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-alpine3_12-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$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\") && (\"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-alpine3_12-validate",
+ "BROKEN_TESTS": "encoding004 T10458 linker_unload_native",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "--disable-ld-override ",
+ "HADRIAN_ARGS": "--docs=no-sphinx",
+ "INSTALL_CONFIGURE_ARGS": "--disable-ld-override",
+ "TEST_ENV": "x86_64-linux-alpine3_12-validate",
+ "XZ_OPT": "-9"
+ }
+ },
"nightly-x86_64-linux-alpine3_12-validate+fully_static": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -723,7 +785,7 @@
"variables": {
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate+fully_static",
- "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native",
+ "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native",
"BUILD_FLAVOUR": "validate+fully_static",
"CONFIGURE_ARGS": "--disable-ld-override ",
"HADRIAN_ARGS": "--docs=no-sphinx",
@@ -2236,7 +2298,7 @@
"variables": {
"BIGNUM_BACKEND": "native",
"BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-int_native-release+fully_static",
- "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native",
+ "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native",
"BUILD_FLAVOUR": "release+fully_static",
"CONFIGURE_ARGS": "--disable-ld-override ",
"HADRIAN_ARGS": "--docs=no-sphinx",
@@ -2246,6 +2308,69 @@
"XZ_OPT": "-9"
}
},
+ "release-x86_64-linux-alpine3_12-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-alpine3_12-release.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-alpine3_12-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$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\") && (\"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-alpine3_12-release",
+ "BROKEN_TESTS": "encoding004 T10458 linker_unload_native",
+ "BUILD_FLAVOUR": "release",
+ "CONFIGURE_ARGS": "--disable-ld-override ",
+ "HADRIAN_ARGS": "--docs=no-sphinx",
+ "IGNORE_PERF_FAILURES": "all",
+ "INSTALL_CONFIGURE_ARGS": "--disable-ld-override",
+ "TEST_ENV": "x86_64-linux-alpine3_12-release",
+ "XZ_OPT": "-9"
+ }
+ },
"release-x86_64-linux-alpine3_12-release+fully_static": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -2299,7 +2424,7 @@
"variables": {
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-release+fully_static",
- "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native",
+ "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native",
"BUILD_FLAVOUR": "release+fully_static",
"CONFIGURE_ARGS": "--disable-ld-override ",
"HADRIAN_ARGS": "--docs=no-sphinx",
@@ -3217,7 +3342,7 @@
"variables": {
"BIGNUM_BACKEND": "native",
"BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-int_native-validate+fully_static",
- "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native",
+ "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native",
"BUILD_FLAVOUR": "validate+fully_static",
"CONFIGURE_ARGS": "--disable-ld-override ",
"HADRIAN_ARGS": "--docs=no-sphinx",
@@ -3225,6 +3350,67 @@
"TEST_ENV": "x86_64-linux-alpine3_12-int_native-validate+fully_static"
}
},
+ "x86_64-linux-alpine3_12-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "2 weeks",
+ "paths": [
+ "ghc-x86_64-linux-alpine3_12-validate.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-alpine3_12-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$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\") && (\"disabled\" != \"disabled\")",
+ "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-alpine3_12-validate",
+ "BROKEN_TESTS": "encoding004 T10458 linker_unload_native",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "--disable-ld-override ",
+ "HADRIAN_ARGS": "--docs=no-sphinx",
+ "INSTALL_CONFIGURE_ARGS": "--disable-ld-override",
+ "TEST_ENV": "x86_64-linux-alpine3_12-validate"
+ }
+ },
"x86_64-linux-alpine3_12-validate+fully_static": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -3278,7 +3464,7 @@
"variables": {
"BIGNUM_BACKEND": "gmp",
"BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate+fully_static",
- "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native",
+ "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native",
"BUILD_FLAVOUR": "validate+fully_static",
"CONFIGURE_ARGS": "--disable-ld-override ",
"HADRIAN_ARGS": "--docs=no-sphinx",
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -929,7 +929,8 @@ zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
extendScInScope :: ScEnv -> [Var] -> ScEnv
-- Bring the quantified variables into scope
-extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
+extendScInScope env qvars
+ = env { sc_subst = extendSubstInScopeList (sc_subst env) qvars }
-- Extend the substitution
extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -689,18 +689,18 @@ spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in s
-- See Note [specImport call stack]
-> RuleBase -- Rules from this module and the home package
-- (but not external packages, which can change)
- -> Bag DictBind -- Dict bindings, used /only/ for filterCalls
+ -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
-- See Note [Avoiding loops in specImports]
-> CallDetails -- Calls for imported things
-> CoreM ( [CoreRule] -- New rules
, [CoreBind] ) -- Specialised bindings
spec_imports top_env callers rule_base dict_binds calls
= do { let import_calls = dVarEnvElts calls
- -- ; debugTraceMsg (text "specImports {" <+>
- -- vcat [ text "calls:" <+> ppr import_calls
- -- , text "dict_binds:" <+> ppr dict_binds ])
+-- ; debugTraceMsg (text "specImports {" <+>
+-- vcat [ text "calls:" <+> ppr import_calls
+-- , text "dict_binds:" <+> ppr dict_binds ])
; (rules, spec_binds) <- go rule_base import_calls
- -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
+-- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
; return (rules, spec_binds) }
where
@@ -709,7 +709,7 @@ spec_imports top_env callers rule_base dict_binds calls
go rb (cis : other_calls)
= do { -- debugTraceMsg (text "specImport {" <+> ppr cis)
; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis
- -- ; debugTraceMsg (text "specImport }" <+> ppr cis)
+ ; -- debugTraceMsg (text "specImport }" <+> ppr cis)
; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
@@ -718,7 +718,7 @@ spec_import :: SpecEnv -- Passed in so that all top-level Ids are
-> [Id] -- Stack of imported functions being specialised
-- See Note [specImport call stack]
-> RuleBase -- Rules from this module
- -> Bag DictBind -- Dict bindings, used /only/ for filterCalls
+ -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
-- See Note [Avoiding loops in specImports]
-> CallInfoSet -- Imported function and calls for it
-> CoreM ( [CoreRule] -- New rules
@@ -742,20 +742,22 @@ spec_import top_env callers rb dict_binds cis@(CIS fn _)
; vis_orphs <- getVisibleOrphanMods
; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn
+ ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])
; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
- <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>
- (runSpecM $ specCalls True top_env rules_for_fn good_calls fn rhs)
+ <- runSpecM $ specCalls True top_env dict_binds
+ rules_for_fn good_calls fn rhs
+
; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
-- After the rules kick in we may get recursion, but
-- we rely on a global GlomBinds to sort that out later
-- See Note [Glom the bindings if imported functions are specialised]
-- Now specialise any cascaded calls
- -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
+ ; -- debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
; (rules2, spec_binds2) <- spec_imports top_env
(fn:callers)
(extendRuleBaseList rb rules1)
- (dict_binds `unionBags` dict_binds1)
+ (dict_binds `thenFDBs` dict_binds1)
new_calls
; let final_binds = wrapDictBinds dict_binds1 $
@@ -1112,17 +1114,20 @@ specExpr env (Tick tickish body)
; return (Tick (specTickish env tickish) body', uds) }
---------------- Applications might generate a call instance --------------------
-specExpr env expr@(App {})
- = go expr []
+specExpr top_env expr@(App {})
+ = go top_env expr []
where
- go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg
- (fun', uds_app) <- go fun (arg':args)
- return (App fun' arg', uds_arg `plusUDs` uds_app)
-
- go (Var f) args = case specVar env f of
- Var f' -> return (Var f', mkCallUDs env f' args)
- e' -> return (e', emptyUDs) -- I don't expect this!
- go other _ = specExpr env other
+ go env (App fun arg) args = do (arg', uds_arg) <- specExpr env arg
+ let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_arg
+ -- Some dicts may have floated out of arg;
+ -- they should be in scope (#21689)
+ (fun', uds_app) <- go env_args fun (arg':args)
+ return (App fun' arg', uds_arg `thenUDs` uds_app)
+
+ go env (Var f) args = case specVar env f of
+ Var f' -> return (Var f', mkCallUDs env f' args)
+ e' -> return (e', emptyUDs) -- I don't expect this!
+ go env other _ = specExpr env other
---------------- Lambda/case require dumping of usage details --------------------
specExpr env e@(Lam {})
@@ -1138,7 +1143,7 @@ specExpr env (Case scrut case_bndr ty alts)
; (scrut'', case_bndr', alts', alts_uds)
<- specCase env scrut' case_bndr alts
; return (Case scrut'' case_bndr' (substTy env ty) alts'
- , scrut_uds `plusUDs` alts_uds) }
+ , scrut_uds `thenUDs` alts_uds) }
---------------- Finally, let is the interesting case --------------------
specExpr env (Let bind body)
@@ -1149,7 +1154,7 @@ specExpr env (Let bind body)
; (body', body_uds) <- specExpr body_env body
-- Deal with the bindings
- ; (binds', uds) <- specBind rhs_env bind' body_uds
+ ; (binds', uds) <- specBind rhs_env bind' body_uds
-- All done
; return (foldr Let body' binds', uds) }
@@ -1211,7 +1216,7 @@ specCase env scrut' case_bndr [Alt con args rhs]
| (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]
flt_binds = scrut_bind : sc_binds
(free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
- all_uds = flt_binds `addDictBinds` free_uds
+ all_uds = flt_binds `consDictBinds` free_uds
alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs')
; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
where
@@ -1287,6 +1292,13 @@ to substitute sc -> sc_flt in the RHS
************************************************************************
-}
+bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv
+bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs })
+ = -- pprTrace "brought into scope" (ppr dx_bndrs) $
+ env {se_subst=subst'}
+ where
+ subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs
+
specBind :: SpecEnv -- Use this for RHSs
-> CoreBind -- Binders are already cloned by cloneBindSM,
-- but RHSs are un-processed
@@ -1310,7 +1322,7 @@ specBind rhs_env (NonRec fn rhs) body_uds
-- fn' mentions the spec_defns in its rules,
-- so put the latter first
- combined_uds = body_uds1 `plusUDs` rhs_uds
+ combined_uds = body_uds1 `thenUDs` rhs_uds
(free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds
@@ -1341,7 +1353,7 @@ specBind rhs_env (Rec pairs) body_uds
-- Note [Specialising a recursive group]
= do { let (bndrs,rhss) = unzip pairs
; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss
- ; let scope_uds = body_uds `plusUDs` rhs_uds
+ ; let scope_uds = body_uds `thenUDs` rhs_uds
-- Includes binds and calls arising from rhss
; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs
@@ -1381,8 +1393,8 @@ specDefns :: SpecEnv
specDefns _env uds []
= return ([], [], uds)
specDefns env uds ((bndr,rhs):pairs)
- = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs
- ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs
+ = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs
+ ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs
; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
---------------------------
@@ -1396,12 +1408,15 @@ specDefn :: SpecEnv
specDefn env body_uds fn rhs
= do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
rules_for_me = idCoreRules fn
- ; (rules, spec_defns, spec_uds) <- specCalls False env rules_for_me
- calls_for_me fn rhs
+ dict_binds = ud_binds body_uds
+
+ ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds
+ rules_for_me calls_for_me fn rhs
+
; return ( fn `addIdSpecialisations` rules
, spec_defns
- , body_uds_without_me `plusUDs` spec_uds) }
- -- It's important that the `plusUDs` is this way
+ , body_uds_without_me `thenUDs` spec_uds) }
+ -- It's important that the `thenUDs` is this way
-- round, because body_uds_without_me may bind
-- dictionaries that are used in calls_for_me passed
-- to specDefn. So the dictionary bindings in
@@ -1412,6 +1427,7 @@ specDefn env body_uds fn rhs
specCalls :: Bool -- True => specialising imported fn
-- False => specialising local fn
-> SpecEnv
+ -> FloatedDictBinds -- Just so that we can extend the in-scope set
-> [CoreRule] -- Existing RULES for the fn
-> [CallInfo]
-> OutId -> InExpr
@@ -1425,7 +1441,7 @@ type SpecInfo = ( [CoreRule] -- Specialisation rules
, [(Id,CoreExpr)] -- Specialised definition
, UsageDetails ) -- Usage details from specialised RHSs
-specCalls spec_imp env existing_rules calls_for_me fn rhs
+specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
-- The first case is the interesting one
| notNull calls_for_me -- And there are some calls to specialise
&& not (isNeverActive (idInlineActivation fn))
@@ -1441,14 +1457,14 @@ 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
- = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
+ = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
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)
"Missed specialisation opportunity" (ppr fn $$ _trace_doc) $
-- Note [Specialisation shape]
- -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
+ -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $
return ([], [], emptyUDs)
where
_trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]
@@ -1461,7 +1477,6 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
is_local = isLocalId fn
is_dfun = isDFunId fn
dflags = se_dflags env
- ropts = initRuleOpts dflags
this_mod = se_module env
-- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations]
@@ -1469,13 +1484,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
(rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-- See Note [Account for casts in binding]
- in_scope = Core.substInScope (se_subst env)
+ -- Bring into scope the binders from the floated dicts
+ env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds
- already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool
- already_covered ropts new_rules args -- Note [Specialisations already covered]
- = isJust (lookupRule ropts (in_scope, realIdUnfolding)
- (const True) fn args
- (new_rules ++ existing_rules))
+ already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool
+ already_covered env new_rules args -- Note [Specialisations already covered]
+ = isJust (specLookupRule env fn args (new_rules ++ existing_rules))
-- NB: we look both in the new_rules (generated by this invocation
-- of specCalls), and in existing_rules (passed in to specCalls)
@@ -1491,21 +1505,25 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- See Note [Specialising DFuns]
; ( useful, rhs_env2, leftover_bndrs
, rule_bndrs, rule_lhs_args
- , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
-
--- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci
--- , text "useful: " <+> ppr useful
--- , text "rule_bndrs:" <+> ppr rule_bndrs
--- , text "lhs_args: " <+> ppr rule_lhs_args
--- , text "spec_bndrs:" <+> ppr spec_bndrs1
--- , text "spec_args: " <+> ppr spec_args
--- , text "dx_binds: " <+> ppr dx_binds
--- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
+ , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs
+ rhs_bndrs all_call_args
+
+-- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn
+-- , text "call info: " <+> ppr _ci
+-- , text "useful: " <+> ppr useful
+-- , text "rule_bndrs:" <+> ppr rule_bndrs
+-- , text "lhs_args: " <+> ppr rule_lhs_args
+-- , text "spec_bndrs1:" <+> ppr spec_bndrs1
+-- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
+-- , text "spec_args: " <+> ppr spec_args
+-- , text "dx_binds: " <+> ppr dx_binds
+-- , text "rhs_body" <+> ppr rhs_body
+-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
-- , ppr dx_binds ]) $
-- return ()
; if not useful -- No useful specialisation
- || already_covered ropts rules_acc rule_lhs_args
+ || already_covered rhs_env2 rules_acc rule_lhs_args
then return spec_acc
else
do { -- Run the specialiser on the specialised RHS
@@ -1616,9 +1634,20 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
; -- pprTrace "spec_call: rule" _rule_trace_doc
return ( spec_rule : rules_acc
, (spec_f_w_arity, spec_rhs) : pairs_acc
- , spec_uds `plusUDs` uds_acc
+ , spec_uds `thenUDs` uds_acc
) } }
+-- Convenience function for invoking lookupRule from Specialise
+-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]
+specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
+specLookupRule env fn args rules
+ = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules
+ where
+ dflags = se_dflags env
+ in_scope = Core.substInScope (se_subst env)
+ ropts = initRuleOpts dflags
+
+
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DFuns have a special sort of unfolding (DFunUnfolding), and it is
@@ -2357,12 +2386,12 @@ specHeader env (bndr : bndrs) (UnspecType : args)
-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
-- the nitty-gritty), as a LHS rule and unfolding details.
specHeader env (bndr : bndrs) (SpecDict d : args)
- = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
- ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d
- ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader env' bndrs args
+ = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
+ ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
+ ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env2 bndrs args
; pure ( True -- Ha! A useful specialisation!
- , env''
+ , env3
, leftover_bndrs
-- See Note [Evidence foralls]
, exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs
@@ -2416,9 +2445,9 @@ specHeader env bndrs []
bindAuxiliaryDict
:: SpecEnv
-> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression
- -> ( SpecEnv -- Substitute for orig_dict_id
+ -> ( SpecEnv -- Substitutes for orig_dict_id
, Maybe DictBind -- Auxiliary dict binding, if any
- , OutExpr) -- Witnessing expression (always trivial)
+ , OutExpr) -- Witnessing expression (always trivial)
bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
orig_dict_id fresh_dict_id dict_expr
@@ -2426,7 +2455,6 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
-- don’t bother creating a new dict binding; just substitute
| Just dict_id <- getIdFromTrivialExpr_maybe dict_expr
= let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr
- `Core.extendInScope` dict_id
-- See Note [Keep the old dictionaries interesting]
, se_interesting = interesting `extendVarSet` dict_id }
in (env', Nothing, dict_expr)
@@ -2434,7 +2462,7 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
| otherwise -- Non-trivial dictionary arg; make an auxiliary binding
= let dict_bind = mkDB (NonRec fresh_dict_id dict_expr)
env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id)
- `Core.extendInScope` fresh_dict_id
+ `Core.extendSubstInScope` fresh_dict_id
-- See Note [Make the new dictionaries interesting]
, se_interesting = interesting `extendVarSet` fresh_dict_id }
in (env', Just dict_bind, Var fresh_dict_id)
@@ -2499,24 +2527,34 @@ specializing the body of h. See !2913.
********************************************************************* -}
data UsageDetails
- = MkUD {
- ud_binds :: !(Bag DictBind),
- -- See Note [Floated dictionary bindings]
+ = MkUD { ud_binds :: !FloatedDictBinds
+ , ud_calls :: !CallDetails }
+ -- INVARIANT: suppose bs = fdb_bndrs ud_binds
+ -- Then 'calls' may *mention* 'bs',
+ -- but there should be no calls *for* bs
+
+data FloatedDictBinds -- See Note [Floated dictionary bindings]
+ = FDB { fdb_binds :: !(Bag DictBind)
-- The order is important;
- -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
+ -- in ds1 `unionBags` ds2, bindings in ds2 can depend on those in ds1
-- (Remember, Bags preserve order in GHC.)
- ud_calls :: !CallDetails
-
- -- INVARIANT: suppose bs = bindersOf ud_binds
- -- Then 'calls' may *mention* 'bs',
- -- but there should be no calls *for* bs
- }
+ , fdb_bndrs :: !IdSet
+ } -- ^ The binders of 'fdb_binds'.
+ -- Caches a superset of the expression
+ -- `mkVarSet (bindersOfDictBinds fdb_binds))`
+ -- for later addition to an InScopeSet
-- | A 'DictBind' is a binding along with a cached set containing its free
-- variables (both type variables and dictionaries)
data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet }
+bindersOfDictBind :: DictBind -> [Id]
+bindersOfDictBind = bindersOf . db_bind
+
+bindersOfDictBinds :: Foldable f => f DictBind -> [Id]
+bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) []
+
{- Note [Floated dictionary bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We float out dictionary bindings for the reasons described under
@@ -2542,12 +2580,16 @@ successfully specialise 'f'.
So the DictBinds in (ud_binds :: Bag DictBind) may contain
non-dictionary bindings too.
+
+It's important to add the dictionary binders that are currently in-float to the
+InScopeSet of the SpecEnv before calling 'specBind'. That's what we do when we
+call 'bringFloatedDictsIntoScope'.
-}
instance Outputable DictBind where
ppr (DB { db_bind = bind, db_fvs = fvs })
- = text "DB" <+> braces (sep [ text "bind:" <+> ppr bind
- , text "fvs: " <+> ppr fvs ])
+ = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs
+ , text "bind:" <+> ppr bind ])
instance Outputable UsageDetails where
ppr (MkUD { ud_binds = dbs, ud_calls = calls })
@@ -2555,8 +2597,15 @@ instance Outputable UsageDetails where
[text "binds" <+> equals <+> ppr dbs,
text "calls" <+> equals <+> ppr calls]))
+instance Outputable FloatedDictBinds where
+ ppr (FDB { fdb_binds = binds }) = ppr binds
+
emptyUDs :: UsageDetails
-emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }
+emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv }
+
+
+emptyFDBs :: FloatedDictBinds
+emptyFDBs = FDB { fdb_binds = emptyBag, fdb_bndrs = emptyVarSet }
------------------------------------------------------------
type CallDetails = DIdEnv CallInfoSet
@@ -2624,7 +2673,7 @@ getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedB
------------------------------------------------------------
singleCall :: Id -> [SpecArg] -> UsageDetails
singleCall id args
- = MkUD {ud_binds = emptyBag,
+ = MkUD {ud_binds = emptyFDBs,
ud_calls = unitDVarEnv id $ CIS id $
unitBag (CI { ci_key = args -- used to be tys
, ci_fvs = call_fvs }) }
@@ -2767,11 +2816,19 @@ interestingDict env (Tick _ a) = interestingDict env a
interestingDict env (Cast e _) = interestingDict env e
interestingDict _ _ = True
-plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
-plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
+thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
+thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
(MkUD {ud_binds = db2, ud_calls = calls2})
- = MkUD { ud_binds = db1 `unionBags` db2
- , ud_calls = calls1 `unionCalls` calls2 }
+ = MkUD { ud_binds = db1 `thenFDBs` db2
+ , ud_calls = calls1 `unionCalls` calls2 }
+
+thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds
+-- Combine FloatedDictBinds
+-- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa
+thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 })
+ (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 })
+ = FDB { fdb_binds = dbs1 `unionBags` dbs2
+ , fdb_bndrs = bs1 `unionVarSet` bs2 }
-----------------------------
_dictBindBndrs :: Bag DictBind -> [Id]
@@ -2784,9 +2841,8 @@ mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind }
-- | Identify the free variables of a 'CoreBind'
bind_fvs :: CoreBind -> VarSet
bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
-bind_fvs (Rec prs) = foldl' delVarSet rhs_fvs bndrs
+bind_fvs (Rec prs) = rhs_fvs `delVarSetList` (map fst prs)
where
- bndrs = map fst prs
rhs_fvs = unionVarSets (map pair_fvs prs)
pair_fvs :: (Id, CoreExpr) -> VarSet
@@ -2811,7 +2867,8 @@ pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs
-- pairs, into a single recursive binding.
recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind
recWithDumpedDicts pairs dbs
- = DB { db_bind = Rec bindings, db_fvs = fvs }
+ = DB { db_bind = Rec bindings
+ , db_fvs = fvs `delVarSetList` map fst bindings }
where
(bindings, fvs) = foldr add ([], emptyVarSet)
(dbs `snocBag` mkDB (Rec pairs))
@@ -2822,22 +2879,29 @@ recWithDumpedDicts pairs dbs
where
fvs' = fvs_acc `unionVarSet` fvs
+snocDictBind :: UsageDetails -> DictBind -> UsageDetails
+snocDictBind uds at MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db
+ = uds { ud_binds = FDB { fdb_binds = dbs `snocBag` db
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
+
snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
-- Add ud_binds to the tail end of the bindings in uds
-snocDictBinds uds dbs
- = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }
+snocDictBinds uds at MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs
+ = uds { ud_binds = FDB { fdb_binds = binds `unionBags` listToBag dbs
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
consDictBind :: DictBind -> UsageDetails -> UsageDetails
-consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }
-
-addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
-addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }
+consDictBind db uds at MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}}
+ = uds { ud_binds = FDB { fdb_binds = db `consBag` binds
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
-snocDictBind :: UsageDetails -> DictBind -> UsageDetails
-snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }
+consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
+consDictBinds dbs uds at MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}
+ = uds { ud_binds = FDB{ fdb_binds = listToBag dbs `unionBags` binds
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
-wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
-wrapDictBinds dbs binds
+wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]
+wrapDictBinds (FDB { fdb_binds = dbs }) binds
= foldr add binds dbs
where
add (DB { db_bind = bind }) binds = bind : binds
@@ -2856,7 +2920,7 @@ dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
| otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
(free_uds, dump_dbs)
where
- free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
+ free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }
bndr_set = mkVarSet bndrs
(free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor
@@ -2880,17 +2944,15 @@ dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls
callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
-callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+callsForMe fn uds at MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }
= -- pprTrace ("callsForMe")
-- (vcat [ppr fn,
-- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs),
-- text "Orig calls =" <+> ppr orig_calls,
- -- text "Dep set =" <+> ppr dep_set,
-- text "Calls for me =" <+> ppr calls_for_me]) $
(uds_without_me, calls_for_me)
where
- uds_without_me = MkUD { ud_binds = orig_dbs
- , ud_calls = delDVarEnv orig_calls fn }
+ uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn }
calls_for_me = case lookupDVarEnv orig_calls fn of
Nothing -> []
Just cis -> filterCalls cis orig_dbs
@@ -2898,10 +2960,10 @@ callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
-- refer to fn. See Note [Avoiding loops (DFuns)]
----------------------
-filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
--- Remove dominated calls
+filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
+-- Remove dominated calls (Note [Specialising polymorphic dictionaries])
-- and loopy DFuns (Note [Avoiding loops (DFuns)])
-filterCalls (CIS fn call_bag) dbs
+filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
| isDFunId fn -- Note [Avoiding loops (DFuns)] applies only to DFuns
= filter ok_call unfiltered_calls
| otherwise -- Do not apply it to non-DFuns
@@ -2922,18 +2984,23 @@ filterCalls (CIS fn call_bag) dbs
ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set
----------------------
-splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
+splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, Bag DictBind, IdSet)
-- splitDictBinds dbs bndrs returns
-- (free_dbs, dump_dbs, dump_set)
-- where
-- * dump_dbs depends, transitively on bndrs
-- * free_dbs does not depend on bndrs
-- * dump_set = bndrs `union` bndrs(dump_dbs)
-splitDictBinds dbs bndr_set
- = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs
+splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set
+ = (FDB { fdb_binds = free_dbs
+ , fdb_bndrs = bs `minusVarSet` dump_set }
+ , dump_dbs, dump_set)
+ where
+ (free_dbs, dump_dbs, dump_set)
+ = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs
-- Important that it's foldl' not foldr;
-- we're accumulating the set of dumped ids in dump_set
- where
+
split_db (free_dbs, dump_dbs, dump_idset) db
| DB { db_bind = bind, db_fvs = fvs } <- db
, dump_idset `intersectsVarSet` fvs -- Dump it
@@ -2975,7 +3042,7 @@ mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDet
mapAndCombineSM _ [] = return ([], emptyUDs)
mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
(ys, uds2) <- mapAndCombineSM f xs
- return (y:ys, uds1 `plusUDs` uds2)
+ return (y:ys, uds1 `thenUDs` uds2)
extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv
extendTvSubstList env tv_binds
@@ -3004,6 +3071,7 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec
interesting' | interestingDict env rhs
= interesting `extendVarSet` bndr'
| otherwise = interesting
+-- ; pprTrace "cloneBindSM" (ppr bndr <+> text ":->" <+> ppr bndr') return ()
; return (env, env { se_subst = subst', se_interesting = interesting' }
, NonRec bndr' rhs) }
@@ -3015,13 +3083,16 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pai
[ v | (v,r) <- pairs, interestingDict env r ] }
; return (env', env', Rec (bndrs' `zip` map snd pairs)) }
-newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
+newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr)
-- Make up completely fresh binders for the dictionaries
-- Their bindings are going to float outwards
-newDictBndr env b = do { uniq <- getUniqueM
- ; let n = idName b
- ty' = substTy env (idType b)
- ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) }
+newDictBndr env@(SE { se_subst = subst }) b
+ = do { uniq <- getUniqueM
+ ; let n = idName b
+ ty' = Core.substTy subst (idType b)
+ b' = mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)
+ env' = env { se_subst = subst `Core.extendSubstInScope` b' }
+ ; pure (env', b') }
newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id
-- Give the new Id a similar occurrence name to the old one
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Core.Ppr (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprCoreBindingWithSize, pprCoreBindingsWithSize,
- pprCoreBinder, pprCoreBinders,
+ pprCoreBinder, pprCoreBinders, pprId, pprIds,
pprRule, pprRules, pprOptCo,
pprOcc, pprOccWithTick
) where
@@ -466,6 +466,13 @@ pprKindedTyVarBndr :: TyVar -> SDoc
pprKindedTyVarBndr tyvar
= text "@" <> pprTyVar tyvar
+-- pprId x prints x :: ty
+pprId :: Id -> SDoc
+pprId x = ppr x <+> dcolon <+> ppr (idType x)
+
+pprIds :: [Id] -> SDoc
+pprIds xs = sep (map pprId xs)
+
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
pprIdBndr :: Id -> SDoc
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -405,7 +405,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
- = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
+ = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $
case go [] rules of
[] -> Nothing
(m:ms) -> Just (findBest in_scope (fn,args') m ms)
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.Core.Subst (
emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,
extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
- extendInScope, extendInScopeList, extendInScopeIds,
+ extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,
isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst,
delBndr, delBndrs,
@@ -50,7 +50,7 @@ import GHC.Core.Type hiding
import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )
import GHC.Types.Var.Set
-import GHC.Types.Var.Env
+import GHC.Types.Var.Env as InScopeSet
import GHC.Types.Id
import GHC.Types.Name ( Name )
import GHC.Types.Var
@@ -284,25 +284,23 @@ mkOpenSubst in_scope pairs = Subst in_scope
isInScope :: Var -> Subst -> Bool
isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
--- | Add the 'Var' to the in-scope set: as a side effect,
--- and remove any existing substitutions for it
-extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope ids tvs cvs) v
- = Subst (in_scope `extendInScopeSet` v)
- (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
+-- | Add the 'Var' to the in-scope set
+extendSubstInScope :: Subst -> Var -> Subst
+extendSubstInScope (Subst in_scope ids tvs cvs) v
+ = Subst (in_scope `InScopeSet.extendInScopeSet` v)
+ ids tvs cvs
-- | Add the 'Var's to the in-scope set: see also 'extendInScope'
-extendInScopeList :: Subst -> [Var] -> Subst
-extendInScopeList (Subst in_scope ids tvs cvs) vs
+extendSubstInScopeList :: Subst -> [Var] -> Subst
+extendSubstInScopeList (Subst in_scope ids tvs cvs) vs
= Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
+ ids tvs cvs
--- | Optimized version of 'extendInScopeList' that can be used if you are certain
--- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
-extendInScopeIds :: Subst -> [Id] -> Subst
-extendInScopeIds (Subst in_scope ids tvs cvs) vs
- = Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) tvs cvs
+-- | Add the 'Var's to the in-scope set: see also 'extendInScope'
+extendSubstInScopeSet :: Subst -> VarSet -> Subst
+extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs
+ = Subst (in_scope `extendInScopeSetSet` vs)
+ ids tvs cvs
setInScope :: Subst -> InScopeSet -> Subst
setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
@@ -462,7 +460,7 @@ substIdBndr :: SDoc
substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
= -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
- (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
+ (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_env tvs cvs, new_id)
where
id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
id2 | no_type_change = id1
@@ -532,7 +530,7 @@ clone_id :: Subst -- Substitution for the IdInfo
-> (Subst, Id) -- Transformed pair
clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
- = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)
+ = (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)
where
id1 = setVarUnique old_id uniq
id2 = substIdType subst id1
=====================================
compiler/GHC/Plugins.hs
=====================================
@@ -89,7 +89,7 @@ import GHC.Core.DataCon
import GHC.Core.Utils
import GHC.Core.Make
import GHC.Core.FVs
-import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )
+import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet )
-- These names are also exported by Type
import GHC.Core.Rules
=====================================
configure.ac
=====================================
@@ -13,7 +13,7 @@ dnl
# see what flags are available. (Better yet, read the documentation!)
#
-AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.4.6], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION])
+AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.4.7], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION])
# Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable
# to be useful (cf #19058). However, the version must have three components
# (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are
=====================================
docs/users_guide/9.4.7-notes.rst
=====================================
@@ -0,0 +1,84 @@
+.. _release-9-4-6:
+
+Version 9.4.7
+==============
+
+The significant changes to the various parts of the compiler are listed in the
+following sections.
+
+The :ghc-flag:`LLVM backend <-fllvm>` of this release is to be used with LLVM
+10, 11, 12, 13, or 14.
+
+Significant Changes
+~~~~~~~~~~~~~~~~~~~~
+
+Issues fixed in this release include:
+
+Compiler
+--------
+
+- Fix a number of scoping bugs in the specialiser, prevent simplifier
+ panics (:ghc-ticket:`21391`, :ghc-ticket:`21689`, :ghc-ticket:`21828`,
+ :ghc-ticket:`23762`).
+
+Build system and packaging
+--------------------------
+
+- Allow building documentation with sphinx versions older than ``4.0`` along
+ with older versions of ``python`` (:ghc-ticket:`23807`, :ghc-ticket:`23818`).
+
+- Also build vanilla (non-static) alpine bindists (:ghc-ticket:`23349`, :ghc-ticket:`23828`).
+
+- Make hadrian buildable with Cabal-3.8.
+
+Core libraries
+--------------
+
+- Bump ``bytestring`` to 0.11.5.2 (:ghc-ticket:`23789`), allowing GHC to be
+ bootstrapped on systems having ``HAVE_PTHREAD_CONDATTR_SETCLOCK``
+
+Included libraries
+------------------
+
+The package database provided with this distribution also contains a number of
+packages other than GHC itself. See the changelogs provided with these packages
+for further change information.
+
+.. ghc-package-list::
+
+ libraries/array/array.cabal: Dependency of ``ghc`` library
+ libraries/base/base.cabal: Core library
+ libraries/binary/binary.cabal: Dependency of ``ghc`` library
+ libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library
+ libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library
+ libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library
+ libraries/directory/directory.cabal: Dependency of ``ghc`` library
+ libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library
+ libraries/filepath/filepath.cabal: Dependency of ``ghc`` library
+ compiler/ghc.cabal: The compiler itself
+ libraries/ghci/ghci.cabal: The REPL interface
+ libraries/ghc-boot/ghc-boot.cabal: Internal compiler library
+ libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library
+ libraries/ghc-compact/ghc-compact.cabal: Core library
+ libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library
+ libraries/ghc-prim/ghc-prim.cabal: Core library
+ libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable
+ libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable
+ libraries/integer-gmp/integer-gmp.cabal: Core library
+ libraries/libiserv/libiserv.cabal: Internal compiler library
+ libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library
+ libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library
+ libraries/pretty/pretty.cabal: Dependency of ``ghc`` library
+ libraries/process/process.cabal: Dependency of ``ghc`` library
+ libraries/stm/stm.cabal: Dependency of ``haskeline`` library
+ libraries/template-haskell/template-haskell.cabal: Core library
+ libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library
+ libraries/text/text.cabal: Dependency of ``Cabal`` library
+ libraries/time/time.cabal: Dependency of ``ghc`` library
+ libraries/transformers/transformers.cabal: Dependency of ``ghc`` library
+ libraries/unix/unix.cabal: Dependency of ``ghc`` library
+ libraries/Win32/Win32.cabal: Dependency of ``ghc`` library
+ libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable
+
=====================================
docs/users_guide/flags.py
=====================================
@@ -50,8 +50,8 @@ import sphinx
from sphinx import addnodes
from sphinx.domains.std import GenericObject
from sphinx.errors import SphinxError
-from distutils.version import LooseVersion
-from utils import build_table_from_list
+
+from utils import build_table_from_list, parse_version
import os.path
@@ -628,8 +628,8 @@ def purge_flags(app, env, docname):
def setup(app):
# The override argument to add_directive_to_domain is only supported by >= 1.8
- sphinx_version = LooseVersion(sphinx.__version__)
- override_arg = {'override': True} if sphinx_version >= LooseVersion('1.8') else {}
+ sphinx_version = parse_version(sphinx.__version__)
+ override_arg = {'override': True} if sphinx_version >= parse_version('1.8') else {}
# Add ghc-flag directive, and override the class with our own
app.add_object_type('ghc-flag', 'ghc-flag')
=====================================
docs/users_guide/ghc_config.py.in
=====================================
@@ -1,7 +1,17 @@
-extlinks = {
- 'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '%s'),
- 'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', '#%s'),
-}
+import sphinx
+from utils import parse_version
+
+if parse_version(sphinx.__version__) >= parse_version("4.0.0"):
+ # N.B. see #23807 and #22690
+ extlinks = {
+ 'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '#%s'),
+ 'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', '%s'),
+ }
+else:
+ extlinks = {
+ 'ghc-ticket': ('https://gitlab.haskell.org/ghc/ghc/issues/%s', '#'),
+ 'ghc-wiki': ('https://gitlab.haskell.org/ghc/ghc/wikis/%s', ''),
+ }
libs_base_uri = '../libraries'
=====================================
docs/users_guide/release-notes.rst
=====================================
@@ -4,6 +4,7 @@ Release notes
.. toctree::
:maxdepth: 1
+ 9.4.7-notes
9.4.6-notes
9.4.5-notes
9.4.4-notes
=====================================
docs/users_guide/utils.py
=====================================
@@ -1,5 +1,12 @@
from docutils import nodes
+# N.B. `packaging` is not available in Ubuntu 18.04 or Debian 9
+# See #23818.
+try:
+ from packaging.version import parse as parse_version
+except ImportError as e:
+ from distutils.version import LooseVersion as parse_version
+
# Taken from Docutils source inside the ListTable class. We must bypass
# using the class itself, but this function comes in handy.
def build_table_from_list(table_data, col_widths):
=====================================
hadrian/hadrian.cabal
=====================================
@@ -147,7 +147,7 @@ executable hadrian
, BangPatterns
other-extensions: MultiParamTypeClasses
, TypeFamilies
- build-depends: Cabal >= 3.2 && < 3.7
+ build-depends: Cabal >= 3.2 && < 3.9
, base >= 4.8 && < 5
, bytestring >= 0.10 && < 0.12
, containers >= 0.5 && < 0.7
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -23,7 +23,11 @@ import qualified Distribution.ModuleName as C
import qualified Distribution.Package as C
import qualified Distribution.PackageDescription as C
import qualified Distribution.PackageDescription.Configuration as C
+#if MIN_VERSION_Cabal(3,8,0)
+import qualified Distribution.Simple.PackageDescription as C
+#else
import qualified Distribution.PackageDescription.Parsec as C
+#endif
import qualified Distribution.Simple.Compiler as C
import qualified Distribution.Simple.Program.Db as C
import qualified Distribution.Simple as C
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit 602fd2f3470f180d64cb8baadf63e94baec66b60
+Subproject commit e377f49b046c986184cf802c8c6386b04c1f1aeb
=====================================
testsuite/tests/simplCore/should_compile/T21391.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+module Web.Routing.SafeRouting where
+
+import Control.DeepSeq (NFData (..))
+import Data.Kind (Constraint, Type)
+import Data.Typeable (Typeable)
+
+class FromHttpApiData a where
+
+data PolyMap (c :: Type -> Constraint) (f :: Type -> Type) (a :: Type) where
+ PMNil :: PolyMap c f a
+ PMCons :: (Typeable p, c p) => f (p -> a) -> PolyMap c f a -> PolyMap c f a
+
+rnfHelper :: (forall p. c p => f (p -> a) -> ()) -> PolyMap c f a -> ()
+rnfHelper _ PMNil = ()
+rnfHelper h (PMCons v pm) = h v `seq` rnfHelper h pm
+
+data PathMap x =
+ PathMap [x] (PolyMap FromHttpApiData PathMap x)
+
+instance NFData x => NFData (PathMap x) where
+ rnf (PathMap a b) = rnf a `seq` rnfHelper rnf b
=====================================
testsuite/tests/simplCore/should_compile/T21391a.hs
=====================================
@@ -0,0 +1,34 @@
+module T21391a (readYamlFile) where
+
+import Control.Monad (liftM)
+import Control.Monad.Trans.Writer.Strict (tell, WriterT(..))
+
+discard :: a -> b
+discard x = discard x
+
+data Pipe a = MkPipe a
+
+sinkValue :: m ~ ResourceT IO => () -> Pipe (WriterT String m ())
+sinkValue _ = tell' ()
+ where
+ tell' _ = lift' discard (tell "")
+
+ lift' rest mr = MkPipe (liftM rest mr)
+ {-# INLINE [1] lift' #-}
+
+class FromYaml a where
+ fromYaml :: () -> a
+
+readYamlFile :: FromYaml a => a
+readYamlFile = fromYaml (discard sinkValue)
+
+newtype ResourceT m a = ResourceT { unResourceT :: IO a }
+
+instance Monad m => Functor (ResourceT m) where
+ fmap = discard
+instance Monad m => Applicative (ResourceT m) where
+ pure = discard
+ (<*>) = discard
+instance Monad m => Monad (ResourceT m) where
+ (>>=) = discard
+
=====================================
testsuite/tests/simplCore/should_compile/T21689.hs
=====================================
@@ -0,0 +1,41 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+module Unboxed (Vec, MVec, Unbox) where
+
+import Data.Data (Data(..), Constr, DataType, Fixity(..), mkConstr, mkDataType)
+import Data.Typeable (Typeable)
+import GHC.TypeLits (Nat)
+
+import T21689a
+
+data family Vec (n :: Nat) a
+data family MVec (n :: Nat) s a
+
+class (Arity n, IVector (Vec n) a, MVector (MVec n) a) => Unbox n a
+
+type instance Mutable (Vec n) = MVec n
+
+type instance Dim (Vec n) = n
+type instance DimM (MVec n) = n
+
+instance (Unbox n a) => Vector (Vec n) a where
+ construct = constructVec
+ inspect = inspectVec
+ {-# INLINE construct #-}
+ {-# INLINE inspect #-}
+
+instance (Typeable n, Unbox n a, Data a) => Data (Vec n a) where
+ gfoldl = gfoldl'
+ gunfold = gunfold'
+ toConstr _ = con_Vec
+ dataTypeOf _ = ty_Vec
+
+ty_Vec :: DataType
+ty_Vec = mkDataType "Data.Vector.Fixed.Unboxed.Vec" [con_Vec]
+
+con_Vec :: Constr
+con_Vec = mkConstr ty_Vec "Vec" [] Prefix
=====================================
testsuite/tests/simplCore/should_compile/T21689a.hs
=====================================
@@ -0,0 +1,192 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T21689a
+ ( Arity
+ , Dim
+ , DimM
+ , IVector
+ , Mutable
+ , MVector
+ , Vector(..)
+ , constructVec
+ , inspectVec
+ , gfoldl'
+ , gunfold'
+ ) where
+
+import Control.Monad.ST (ST, runST)
+import Data.Coerce (coerce)
+import Data.Data (Data)
+import Data.Functor.Const (Const(..))
+import Data.Kind (Type)
+import GHC.TypeLits (KnownNat, Nat, type (+), type (-))
+
+-----
+-- Data.Vector.Fixed.Cont
+-----
+
+data PeanoNum = Z
+ | S PeanoNum
+
+type family Peano (n :: Nat) :: PeanoNum where
+ Peano 0 = 'Z
+ Peano n = 'S (Peano (n - 1))
+
+type family Fn (n :: PeanoNum) (a :: Type) (b :: Type) where
+ Fn 'Z a b = b
+ Fn ('S n) a b = a -> Fn n a b
+
+newtype Fun n a b = Fun { unFun :: Fn n a b }
+
+type family Dim (v :: Type -> Type) :: Nat
+
+class Arity (Dim v) => Vector v a where
+ construct :: Fun (Peano (Dim v)) a (v a)
+
+ inspect :: v a -> Fun (Peano (Dim v)) a b -> b
+
+type Arity n = ( ArityPeano (Peano n)
+ , KnownNat n
+ , Peano (n+1) ~ 'S (Peano n)
+ )
+
+class ArityPeano n where
+ accum :: (forall k. t ('S k) -> a -> t k)
+ -> (t 'Z -> b)
+ -> t n
+ -> Fun n a b
+
+ applyFun :: (forall k. t ('S k) -> (a, t k))
+ -> t n
+ -> (CVecPeano n a, t 'Z)
+
+ gunfoldF :: (Data a)
+ => (forall b x. Data b => c (b -> x) -> c x)
+ -> T_gunfold c r a n -> c r
+
+newtype T_gunfold c r a n = T_gunfold (c (Fn n a r))
+
+gfoldl' :: forall c v a. (Vector v a, Data a)
+ => (forall x y. Data x => c (x -> y) -> x -> c y)
+ -> (forall x . x -> c x)
+ -> v a -> c (v a)
+gfoldl' f inj v
+ = inspect v
+ $ gfoldlF f (inj $ unFun (construct :: Fun (Peano (Dim v)) a (v a)))
+
+gunfold' :: forall con c v a. (Vector v a, Data a)
+ => (forall b r. Data b => c (b -> r) -> c r)
+ -> (forall r. r -> c r)
+ -> con -> c (v a)
+gunfold' f inj _
+ = gunfoldF f gun
+ where
+ con = construct :: Fun (Peano (Dim v)) a (v a)
+ gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Peano (Dim v))
+
+gfoldlF :: (ArityPeano n, Data a)
+ => (forall x y. Data x => c (x -> y) -> x -> c y)
+ -> c (Fn n a r) -> Fun n a (c r)
+gfoldlF f c0 = accum
+ (\(T_gfoldl c) x -> T_gfoldl (f c x))
+ (\(T_gfoldl c) -> c)
+ (T_gfoldl c0)
+
+newtype T_gfoldl c r a n = T_gfoldl (c (Fn n a r))
+
+newtype ContVec n a = ContVec (forall r. Fun (Peano n) a r -> r)
+
+type instance Dim (ContVec n) = n
+
+instance Arity n => Vector (ContVec n) a where
+ construct = accum
+ (\(T_mkN f) a -> T_mkN (f . consPeano a))
+ (\(T_mkN f) -> toContVec $ f (CVecPeano unFun))
+ (T_mkN id)
+ inspect (ContVec c) f = c f
+ {-# INLINE construct #-}
+ {-# INLINE inspect #-}
+
+newtype T_mkN n_tot a n = T_mkN (CVecPeano n a -> CVecPeano n_tot a)
+
+toContVec :: CVecPeano (Peano n) a -> ContVec n a
+toContVec = coerce
+
+newtype CVecPeano n a = CVecPeano (forall r. Fun n a r -> r)
+
+consPeano :: a -> CVecPeano n a -> CVecPeano ('S n) a
+consPeano a (CVecPeano cont) = CVecPeano $ \f -> cont $ curryFirst f a
+{-# INLINE consPeano #-}
+
+curryFirst :: Fun ('S n) a b -> a -> Fun n a b
+curryFirst = coerce
+{-# INLINE curryFirst #-}
+
+apply :: Arity n
+ => (forall k. t ('S k) -> (a, t k))
+ -> t (Peano n)
+ -> ContVec n a
+{-# INLINE apply #-}
+apply step' z = toContVec $ fst (applyFun step' z)
+
+-----
+-- Data.Vector.Fixed.Mutable
+-----
+
+type family Mutable (v :: Type -> Type) :: Type -> Type -> Type
+
+type family DimM (v :: Type -> Type -> Type) :: Nat
+
+class (Arity (DimM v)) => MVector v a where
+ new :: PrimMonad m => m (v (PrimState m) a)
+
+ unsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m ()
+
+class (Dim v ~ DimM (Mutable v), MVector (Mutable v) a) => IVector v a where
+ unsafeFreeze :: PrimMonad m => Mutable v (PrimState m) a -> m (v a)
+
+ unsafeIndex :: v a -> Int -> a
+
+inspectVec :: forall v a b. (Arity (Dim v), IVector v a) => v a -> Fun (Peano (Dim v)) a b -> b
+{-# INLINE inspectVec #-}
+inspectVec v
+ = inspect cv
+ where
+ cv :: ContVec (Dim v) a
+ cv = apply (\(Const i) -> (unsafeIndex v i, Const (i+1)))
+ (Const 0 :: Const Int (Peano (Dim v)))
+
+constructVec :: forall v a. (Arity (Dim v), IVector v a) => Fun (Peano (Dim v)) a (v a)
+{-# INLINE constructVec #-}
+constructVec =
+ accum step
+ (\(T_new _ st) -> runST $ unsafeFreeze =<< st :: v a)
+ (T_new 0 new :: T_new v a (Peano (Dim v)))
+
+data T_new v a n = T_new Int (forall s. ST s (Mutable v s a))
+
+step :: (IVector v a) => T_new v a ('S n) -> a -> T_new v a n
+step (T_new i st) x = T_new (i+1) $ do
+ mv <- st
+ unsafeWrite mv i x
+ return mv
+
+-----
+-- Control.Monad.Primitive
+-----
+
+class Monad m => PrimMonad m where
+ type PrimState m
+
+instance PrimMonad (ST s) where
+ type PrimState (ST s) = s
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -400,3 +400,6 @@ test('T21476', normal, compile, [''])
test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings -fno-omit-interface-pragmas -fno-ignore-interface-pragmas'])
test('T22761', normal, multimod_compile, ['T22761', '-O2 -v0'])
test('T23012', normal, compile, ['-O'])
+test('T21391', normal, compile, ['-O -dcore-lint'])
+test('T21391a', normal, compile, ['-O -dcore-lint'])
+test('T21689', [extra_files(['T21689a.hs'])], multimod_compile, ['T21689', '-v0 -O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b62980cbc8601ea5bbaa8f89aefcd88abd296cc6...3cc991a9eef062a7d66ac350c20b43f27cfbf21e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b62980cbc8601ea5bbaa8f89aefcd88abd296cc6...3cc991a9eef062a7d66ac350c20b43f27cfbf21e
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/20230820/10e82f9c/attachment-0001.html>
More information about the ghc-commits
mailing list