[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: rts: Build ticky GHC with single-threaded RTS
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri May 26 12:36:08 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
dc3422d4 by Matthew Pickering at 2023-05-25T18:57:19-04:00
rts: Build ticky GHC with single-threaded RTS
The threaded RTS allows you to use ticky profiling but only for the
counters in the generated code. The counters used in the C portion of
the RTS are disabled. Updating the counters is also racy using the
threaded RTS which can lead to misleading or incorrect ticky results.
Therefore we change the hadrian flavour to build using the
single-threaded RTS (mainly in order to get accurate C code counter
increments)
Fixes #23430
- - - - -
fbc8e04e by sheaf at 2023-05-25T18:58:00-04:00
Propagate long-distance info in generated code
When desugaring generated pattern matches, we skip pattern match checks.
However, this ended up also discarding long-distance information, which
might be needed for user-written sub-expressions.
Example:
```haskell
okay (GADT di) cd =
let sr_field :: ()
sr_field = case getFooBar di of { Foo -> () }
in case cd of { SomeRec _ -> SomeRec sr_field }
```
With sr_field a generated FunBind, we still want to propagate the outer
long-distance information from the GADT pattern match into the checks
for the user-written RHS of sr_field.
Fixes #23445
- - - - -
f5ad8f9e by Matthew Pickering at 2023-05-26T08:35:31-04:00
ghcup-metadata: Don't override existing metadata if version already exists.
If a nightly pipeline runs twice for some reason for the same version
then we really don't want to override an existing entry with new
bindists. This could cause ABI compatability issues for users or break
ghcup's caching logic.
- - - - -
3c6fafc7 by Matthew Pickering at 2023-05-26T08:35:32-04:00
ghcup-metadata: Use proper API url for bindist download
Previously we were using links from the web interface, but it's more
robust and future-proof to use the documented links to the artifacts.
https://docs.gitlab.com/ee/api/job_artifacts.html
- - - - -
9c6e32da by Matthew Pickering at 2023-05-26T08:35:32-04:00
ghcup-metadata: Set Nightly and LatestNightly tags
The latest nightly release needs the LatestNightly tag, and all other
nightly releases need the Nightly tag. Therefore when the metadata is
updated we need to replace all LatestNightly with Nightly.`
- - - - -
be2dac34 by Matthew Pickering at 2023-05-26T08:35:32-04:00
ghcup-metadata: Download nightly metadata for correct date
The metadata now lives in https://gitlab.haskell.org/ghc/ghcup-metadata
with one metadata file per year. When we update the metadata we download
and update the right file for the current year.
- - - - -
3428e814 by Matthew Pickering at 2023-05-26T08:35:32-04:00
ghcup-metadata: Download metadata and update for correct year
something about pipeline date
- - - - -
39d85ef1 by Matthew Pickering at 2023-05-26T08:35:32-04:00
ghcup-metadata: Don't skip CI
On a push we now have a CI job which updates gitlab pages with the
metadata files.
- - - - -
27e46bde by Matthew Pickering at 2023-05-26T08:35:32-04:00
ghcup-metadata: Add --date flag to specify the release date
The ghcup-metadata now has a viReleaseDay field which needs to be
populated with the day of the release.
- - - - -
7a660aaa by Matthew Pickering at 2023-05-26T08:35:32-04:00
ghcup-metadata: Add dlOutput field
ghcup now requires us to add this field which specifies where it should
download the bindist to. See
https://gitlab.haskell.org/ghc/ghcup-metadata/-/issues/1 for some more
discussion.
- - - - -
02f970ef by Josh Meredith at 2023-05-26T08:35:32-04:00
JS: Convert rendering to use HLine instead of SDoc (#22455)
- - - - -
74a2a9d6 by Sylvain Henry at 2023-05-26T08:35:42-04:00
Factorize getLinkDeps
Prepare reuse of getLinkDeps for TH implementation in the JS backend
(cf #22261 and review of !9779).
- - - - -
27 changed files:
- .gitlab-ci.yml
- .gitlab/rel_eng/mk-ghcup-metadata/README.mkd
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC/Driver/Config/StgToJS.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/JS/Ppr.hs
- + compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Opt.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Types.hs
- compiler/ghc.cabal.in
- docs/users_guide/debugging.rst
- hadrian/src/Flavour.hs
- testsuite/tests/linters/notes.stdout
- + testsuite/tests/pmcheck/should_compile/T23445.hs
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -998,8 +998,9 @@ project-version:
# Calculate the project version
- . ./version.sh
- # Download existing ghcup metadata
- - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://gitlab.haskell.org/ghc/ghcup-metadata/-/raw/updates/ghcup-0.0.7.yaml"
+ # Download existing ghcup metadata for the correct year
+ - PipelineYear="$(date -d $CI_PIPELINE_CREATED_AT +%Y)"
+ - nix shell nixpkgs#wget -c wget "https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-$PipelineYear-0.0.7.yaml" -O ghcup-0.0.7.yaml
- .gitlab/generate_job_metadata
@@ -1044,7 +1045,7 @@ ghcup-metadata-nightly:
artifacts: false
- job: project-version
script:
- - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --metadata ghcup-0.0.7.yaml --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
+ - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%M-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
rules:
- if: $NIGHTLY
@@ -1063,14 +1064,15 @@ ghcup-metadata-nightly-push:
artifacts: true
script:
- git clone https://gitlab.haskell.org/ghc/ghcup-metadata.git
- - cp metadata_test.yaml ghcup-metadata/ghcup-0.0.7.yaml
+ - PipelineYear="$(date -d $CI_PIPELINE_CREATED_AT +%Y)"
+ - cp metadata_test.yaml "ghcup-metadata/ghcup-nightlies-$PipelineYear-0.0.7.yaml"
- cd ghcup-metadata
- git config user.email "ghc-ci at gitlab-haskell.org"
- git config user.name "GHC GitLab CI"
- git remote add gitlab_origin https://oauth2:$PROJECT_PUSH_TOKEN@gitlab.haskell.org/ghc/ghcup-metadata.git
- git add .
- git commit -m "Update metadata"
- - git push gitlab_origin HEAD:updates -o ci.skip
+ - git push gitlab_origin HEAD:updates
rules:
# Only run the update on scheduled nightly pipelines, ie once a day
- if: $NIGHTLY && $CI_PIPELINE_SOURCE == "schedule" && $CI_COMMIT_BRANCH == "master"
@@ -1080,7 +1082,7 @@ ghcup-metadata-release:
# No explicit needs for release pipeline as we assume we need everything and everything will pass.
extends: .ghcup-metadata
script:
- - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --release-mode --metadata ghcup-0.0.7.yaml --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
+ - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --release-mode --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%M-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
rules:
- if: '$RELEASE_JOB == "yes"'
=====================================
.gitlab/rel_eng/mk-ghcup-metadata/README.mkd
=====================================
@@ -18,6 +18,7 @@ options:
--release-mode Generate metadata which points to downloads folder
--fragment Output the generated fragment rather than whole modified file
--version VERSION Version of the GHC compiler
+ --date DATE Date of the compiler release
```
The script also requires the `.gitlab/jobs-metadata.yaml` file which can be generated
=====================================
.gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
=====================================
@@ -63,7 +63,8 @@ eprint(f"Supported platforms: {job_mapping.keys()}")
# Artifact precisely specifies a job what the bindist to download is called.
class Artifact(NamedTuple):
job_name: str
- name: str
+ download_name: str
+ output_name: str
subdir: str
# Platform spec provides a specification which is agnostic to Job
@@ -72,8 +73,14 @@ class PlatformSpec(NamedTuple):
name: str
subdir: str
-source_artifact = Artifact('source-tarball', 'ghc-{version}-src.tar.xz', 'ghc-{version}' )
-test_artifact = Artifact('source-tarball', 'ghc-{version}-testsuite.tar.xz', 'ghc-{version}' )
+source_artifact = Artifact('source-tarball'
+ , 'ghc-{version}-src.tar.xz'
+ , 'ghc-{version}-src.tar.xz'
+ , 'ghc-{version}' )
+test_artifact = Artifact('source-tarball'
+ , 'ghc-{version}-testsuite.tar.xz'
+ , 'ghc-{version}-testsuite.tar.xz'
+ , 'ghc-{version}' )
def debian(arch, n):
return linux_platform(arch, "{arch}-linux-deb{n}".format(arch=arch, n=n))
@@ -104,7 +111,7 @@ def linux_platform(arch, opsys):
return PlatformSpec( opsys, 'ghc-{version}-{arch}-unknown-linux'.format(version="{version}", arch=arch) )
-base_url = 'https://gitlab.haskell.org/ghc/ghc/-/jobs/{job_id}/artifacts/raw/{artifact_name}'
+base_url = 'https://gitlab.haskell.org/api/v4/projects/1/jobs/{job_id}/artifacts/{artifact_name}'
hash_cache = {}
@@ -129,7 +136,7 @@ def download_and_hash(url):
def mk_one_metadata(release_mode, version, job_map, artifact):
job_id = job_map[artifact.job_name].id
- url = base_url.format(job_id=job_id, artifact_name=urllib.parse.quote_plus(artifact.name.format(version=version)))
+ url = base_url.format(job_id=job_id, artifact_name=urllib.parse.quote_plus(artifact.download_name.format(version=version)))
# In --release-mode, the URL in the metadata needs to point into the downloads folder
# rather then the pipeline.
@@ -143,10 +150,13 @@ def mk_one_metadata(release_mode, version, job_map, artifact):
eprint(f"Bindist URL: {url}")
eprint(f"Download URL: {final_url}")
- # Download and hash from the release pipeline, this must not change anyway during upload.
+ #Download and hash from the release pipeline, this must not change anyway during upload.
h = download_and_hash(url)
- res = { "dlUri": final_url, "dlSubdir": artifact.subdir.format(version=version), "dlHash" : h }
+ res = { "dlUri": final_url
+ , "dlSubdir": artifact.subdir.format(version=version)
+ , "dlOutput": artifact.output_name.format(version=version)
+ , "dlHash" : h }
eprint(res)
return res
@@ -155,10 +165,14 @@ def mk_one_metadata(release_mode, version, job_map, artifact):
def mk_from_platform(pipeline_type, platform):
info = job_mapping[platform.name][pipeline_type]
eprint(f"From {platform.name} / {pipeline_type} selecting {info['name']}")
- return Artifact(info['name'] , f"{info['jobInfo']['bindistName']}.tar.xz", platform.subdir)
+ return Artifact(info['name']
+ , f"{info['jobInfo']['bindistName']}.tar.xz"
+ , "ghc-{version}-{pn}.tar.xz".format(version="{version}", pn=platform.name)
+ , platform.subdir)
+
# Generate the new metadata for a specific GHC mode etc
-def mk_new_yaml(release_mode, version, pipeline_type, job_map):
+def mk_new_yaml(release_mode, version, date, pipeline_type, job_map):
def mk(platform):
eprint("\n=== " + platform.name + " " + ('=' * (75 - len(platform.name))))
return mk_one_metadata(release_mode, version, job_map, mk_from_platform(pipeline_type, platform))
@@ -227,7 +241,14 @@ def mk_new_yaml(release_mode, version, pipeline_type, job_map):
else:
change_log = "https://gitlab.haskell.org"
- return { "viTags": ["Latest", "TODO_base_version"]
+ if release_mode:
+ tags = ["Latest", "TODO_base_version"]
+ else:
+ tags = ["LatestNightly"]
+
+
+ return { "viTags": tags
+ , "viReleaseDay": date
# Check that this link exists
, "viChangeLog": change_log
, "viSourceDL": source
@@ -239,6 +260,15 @@ def mk_new_yaml(release_mode, version, pipeline_type, job_map):
}
+def setNightlyTags(ghcup_metadata):
+ for version in ghcup_metadata['ghcupDownloads']['GHC']:
+ if "LatestNightly" in ghcup_metadata['ghcupDownloads']['GHC'][version]["viTags"]:
+ ghcup_metadata['ghcupDownloads']['GHC'][version]["viTags"].remove("LatestNightly")
+ ghcup_metadata['ghcupDownloads']['GHC'][version]["viTags"].append("Nightly")
+
+
+
+
def main() -> None:
import argparse
@@ -249,6 +279,7 @@ def main() -> None:
parser.add_argument('--fragment', action='store_true', help='Output the generated fragment rather than whole modified file')
# TODO: We could work out the --version from the project-version CI job.
parser.add_argument('--version', required=True, type=str, help='Version of the GHC compiler')
+ parser.add_argument('--date', required=True, type=str, help='Date of the compiler release')
args = parser.parse_args()
project = gl.projects.get(1, lazy=True)
@@ -269,17 +300,21 @@ def main() -> None:
eprint(f"Pipeline Type: {pipeline_type}")
- new_yaml = mk_new_yaml(args.release_mode, args.version, pipeline_type, job_map)
+ new_yaml = mk_new_yaml(args.release_mode, args.version, args.date, pipeline_type, job_map)
if args.fragment:
print(yaml.dump({ args.version : new_yaml }))
else:
with open(args.metadata, 'r') as file:
ghcup_metadata = yaml.safe_load(file)
+ if args.version in ghcup_metadata['ghcupDownloads']['GHC']:
+ raise RuntimeError("Refusing to override existing version in metadata")
+ setNightlyTags(ghcup_metadata)
ghcup_metadata['ghcupDownloads']['GHC'][args.version] = new_yaml
print(yaml.dump(ghcup_metadata))
+
if __name__ == '__main__':
main()
=====================================
compiler/GHC/Driver/Config/StgToJS.hs
=====================================
@@ -20,6 +20,7 @@ initStgToJSConfig dflags = StgToJSConfig
, csInlineLoadRegs = False
, csInlineEnter = False
, csInlineAlloc = False
+ , csPrettyRender = gopt Opt_DisableJsMinifier dflags
, csTraceRts = False
, csAssertRts = False
, csBoundsCheck = gopt Opt_DoBoundsChecking dflags
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -314,6 +314,9 @@ data GeneralFlag
| Opt_WriteInterface -- forces .hi files to be written even with -fno-code
| Opt_WriteHie -- generate .hie files
+ -- JavaScript opts
+ | Opt_DisableJsMinifier -- ^ render JavaScript pretty-printed instead of minified (compacted)
+
-- profiling opts
| Opt_AutoSccsOnIndividualCafs
| Opt_ProfCountEntries
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1861,6 +1861,10 @@ dynamic_flags_deps = [
, (NotDeprecated, customOrUnrecognisedWarning "W" setCustomWarningFlag)
, (Deprecated, customOrUnrecognisedWarning "fwarn-" setCustomWarningFlag)
, (Deprecated, customOrUnrecognisedWarning "fno-warn-" unSetCustomWarningFlag)
+ ]
+
+ ------ JavaScript flags -----------------------------------------------
+ ++ [ make_ord_flag defFlag "ddisable-js-minifier" (NoArg (setGeneralFlag Opt_DisableJsMinifier))
]
------ Language flags -------------------------------------------------
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -218,7 +218,7 @@ mkMatchGroup :: AnnoBody p body
-> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup origin matches = MG { mg_ext = origin
- , mg_alts = matches }
+ , mg_alts = matches }
mkLamCaseMatchGroup :: AnnoBody p body
=> Origin
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -184,7 +184,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
) <> semi
_ -> empty
- strlit xs = docToSDoc (pprStringLit xs)
+ strlit xs = pprStringLit xs
-- the target which will form the root of what we ask rts_evalIO to run
the_cfun
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -36,7 +36,7 @@ import GHC.Hs.Syn.Type
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Pmc
-import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )
+import GHC.HsToCore.Pmc.Types ( Nablas )
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
@@ -783,16 +783,24 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-- Pattern match check warnings for /this match-group/.
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-- Each Match will split off one Nablas for its RHSs from this.
- ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
+ ; matches_nablas <-
+ if isMatchContextPmChecked dflags origin ctxt
+
+ -- See Note [Long-distance information] in GHC.HsToCore.Pmc
then addHsScrutTmCs (concat scrs) new_vars $
- -- See Note [Long-distance information]
pmcMatches (DsMatchContext ctxt locn) new_vars matches
- else pure (initNablasMatches matches)
+
+ -- When we're not doing PM checks on the match group,
+ -- we still need to propagate long-distance information.
+ -- See Note [Long-distance information in matchWrapper]
+ else do { ldi_nablas <- getLdiNablas
+ ; pure $ initNablasMatches ldi_nablas matches }
; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
- ; result_expr <- handleWarnings $
+ ; result_expr <- discard_warnings_if_generated origin $
matchEquations ctxt new_vars eqns_info rhs_ty
+
; return (new_vars, result_expr) }
where
-- Called once per equation in the match, or alternative in the case
@@ -810,19 +818,67 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
, eqn_orig = FromSource
, eqn_rhs = match_result } }
- handleWarnings = if isGenerated origin
- then discardWarningsDs
- else id
+ discard_warnings_if_generated orig =
+ if isGenerated orig
+ then discardWarningsDs
+ else id
+
+ initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
+ initNablasMatches ldi_nablas ms
+ = map (\(L _ m) -> (ldi_nablas, initNablasGRHSs ldi_nablas (m_grhss m))) ms
+
+ initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas
+ initNablasGRHSs ldi_nablas m
+ = expectJust "GRHSs non-empty"
+ $ NEL.nonEmpty
+ $ replicate (length (grhssGRHSs m)) ldi_nablas
+
+{- Note [Long-distance information in matchWrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The pattern match checking in matchWrapper is done conditionally, depending
+on isMatchContextPmChecked. This means that we don't perform pattern match
+checking on e.g. generated pattern matches.
+
+However, when we skip pattern match checking, we still need to keep track
+of long-distance information in case we need it in a nested context.
+
+This came up in #23445. For example:
- initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
- initNablasMatches ms
- = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms
+ data GADT a where
+ IsUnit :: GADT ()
- initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas
- initNablasGRHSs m = expectJust "GRHSs non-empty"
- $ NEL.nonEmpty
- $ replicate (length (grhssGRHSs m)) initNablas
+ data Foo b where
+ FooUnit :: Foo ()
+ FooInt :: Foo Int
+ data SomeRec = SomeRec { fld :: () }
+
+ bug :: GADT a -> Foo a -> SomeRec -> SomeRec
+ bug IsUnit foo r =
+ let gen_fld :: ()
+ gen_fld = case foo of { FooUnit -> () }
+ in case r of { SomeRec _ -> SomeRec gen_fld }
+
+Here the body of 'bug' was generated by 'desugarRecordUpd' from the user-written
+record update
+
+ cd { fld = case foo of { FooUnit -> () } }
+
+As a result, we have a generated FunBind gen_fld whose RHS
+
+ case foo of { FooUnit -> () }
+
+is user-written. This all happens after the GADT pattern match on IsUnit,
+which brings into scope the Given equality [G] a ~ (). We need to make sure
+that this long distance information is visible when pattern match checking the
+user-written case statement.
+
+To propagate this long-distance information in 'matchWrapper', when we skip
+pattern match checks, we make sure to manually pass the long-distance
+information to 'mk_eqn_info', which is responsible for recurring further into
+the expression (in this case, it will end up recursively calling 'matchWrapper'
+on the user-written case statement).
+-}
matchEquations :: HsMatchContext GhcRn
-> [MatchId] -> [EquationInfo] -> Type
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -39,7 +39,7 @@ module GHC.HsToCore.Pmc (
isMatchContextPmChecked,
-- See Note [Long-distance information]
- addTyCs, addCoreScrutTmCs, addHsScrutTmCs
+ addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas
) where
import GHC.Prelude
@@ -142,8 +142,8 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
-- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.)
-- each of a 'Match'es 'GRHS' for Note [Long-distance information].
--
--- Special case: When there are /no matches/, then the functionassumes it
--- checks and @-XEmptyCase@ with only a single match variable.
+-- Special case: When there are /no matches/, then the function assumes it
+-- checks an @-XEmptyCase@ with only a single match variable.
-- See Note [Checking EmptyCase].
pmcMatches
:: DsMatchContext -- ^ Match context, for warnings messages
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -30,6 +30,8 @@ module GHC.Iface.Load (
moduleFreeHolesPrecise,
needWiredInHomeIface, loadWiredInHomeIface,
+ WhereFrom(..),
+
pprModIfaceSimple,
ifaceStats, pprModIface, showIface,
@@ -1222,3 +1224,20 @@ pprExtensibleFields :: ExtensibleFields -> SDoc
pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs
where
pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"
+
+
+-- | Reason for loading an interface file
+--
+-- Used to figure out whether we want to consider loading hi-boot files or not.
+data WhereFrom
+ = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-})
+ | ImportBySystem -- Non user import.
+ | ImportByPlugin -- Importing a plugin.
+
+instance Outputable WhereFrom where
+ ppr (ImportByUser IsBoot) = text "{- SOURCE -}"
+ ppr (ImportByUser NotBoot) = empty
+ ppr ImportBySystem = text "{- SYSTEM -}"
+ ppr ImportByPlugin = text "{- PLUGIN -}"
+
+
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
-- For Outputable instances for JS syntax
{-# OPTIONS_GHC -Wno-orphans #-}
@@ -55,12 +56,13 @@ module GHC.JS.Ppr
, JsToDoc(..)
, defaultRenderJs
, RenderJs(..)
+ , JsRender(..)
, jsToDoc
, pprStringLit
- , braceNest
- , hangBrace
, interSemi
, addSemi
+ , braceNest
+ , hangBrace
)
where
@@ -75,16 +77,15 @@ import Data.List (sortOn)
import Numeric(showHex)
-import GHC.Utils.Outputable (Outputable (..), docToSDoc)
-import GHC.Utils.Ppr as PP
+import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Unique.Map
instance Outputable JExpr where
- ppr = docToSDoc . renderJs
+ ppr = renderJs
instance Outputable JVal where
- ppr = docToSDoc . renderJs
+ ppr = renderJs
--------------------------------------------------------------------------------
-- Top level API
@@ -93,87 +94,86 @@ instance Outputable JVal where
-- | Render a syntax tree as a pretty-printable document
-- (simply showing the resultant doc produces a nice,
-- well formatted String).
-renderJs :: (JsToDoc a) => a -> Doc
+renderJs :: (JsToDoc a) => a -> SDoc
renderJs = renderJs' defaultRenderJs
-renderJs' :: (JsToDoc a) => RenderJs -> a -> Doc
+{-# SPECIALISE renderJs' :: JsToDoc a => RenderJs HLine -> a -> HLine #-}
+{-# SPECIALISE renderJs' :: JsToDoc a => RenderJs SDoc -> a -> SDoc #-}
+renderJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc
renderJs' r = jsToDocR r
-data RenderJs = RenderJs
- { renderJsS :: !(RenderJs -> JStat -> Doc)
- , renderJsE :: !(RenderJs -> JExpr -> Doc)
- , renderJsV :: !(RenderJs -> JVal -> Doc)
- , renderJsI :: !(RenderJs -> Ident -> Doc)
+data RenderJs doc = RenderJs
+ { renderJsS :: !(JsRender doc => RenderJs doc -> JStat -> doc)
+ , renderJsE :: !(JsRender doc => RenderJs doc -> JExpr -> doc)
+ , renderJsV :: !(JsRender doc => RenderJs doc -> JVal -> doc)
+ , renderJsI :: !(JsRender doc => RenderJs doc -> Ident -> doc)
}
-defaultRenderJs :: RenderJs
+defaultRenderJs :: RenderJs doc
defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI
-jsToDoc :: JsToDoc a => a -> Doc
+jsToDoc :: JsToDoc a => a -> SDoc
jsToDoc = jsToDocR defaultRenderJs
-- | Render a syntax tree as a pretty-printable document, using a given prefix
-- to all generated names. Use this with distinct prefixes to ensure distinct
-- generated names between independent calls to render(Prefix)Js.
-renderPrefixJs :: (JsToDoc a, JMacro a) => a -> Doc
+renderPrefixJs :: (JsToDoc a, JMacro a) => a -> SDoc
renderPrefixJs = renderPrefixJs' defaultRenderJs
-renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
+renderPrefixJs' :: (JsToDoc a, JMacro a, JsRender doc) => RenderJs doc -> a -> doc
renderPrefixJs' r = jsToDocR r
--------------------------------------------------------------------------------
-- Code Generator
--------------------------------------------------------------------------------
-class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc
+class JsToDoc a where jsToDocR :: JsRender doc => RenderJs doc -> a -> doc
instance JsToDoc JStat where jsToDocR r = renderJsS r r
instance JsToDoc JExpr where jsToDocR r = renderJsE r r
instance JsToDoc JVal where jsToDocR r = renderJsV r r
instance JsToDoc Ident where jsToDocR r = renderJsI r r
-instance JsToDoc [JExpr] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
-instance JsToDoc [JStat] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
+instance JsToDoc [JExpr] where jsToDocR r = jcat . map (addSemi . jsToDocR r)
+instance JsToDoc [JStat] where jsToDocR r = jcat . map (addSemi . jsToDocR r)
-defRenderJsS :: RenderJs -> JStat -> Doc
+defRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc
defRenderJsS r = \case
- IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond))
- (jsToDocR r x)
- $$ mbElse
- where mbElse | y == BlockStat [] = PP.empty
- | otherwise = hangBrace (text "else") (jsToDocR r y)
+ IfStat cond x y -> hangBrace (text "if" <+?> parens (jsToDocR r cond))
+ (jnest $ optBlock r x)
+ <+?> mbElse
+ where mbElse | y == BlockStat [] = empty
+ | otherwise = hangBrace (text "else") (jnest $ optBlock r y)
DeclStat x Nothing -> text "var" <+> jsToDocR r x
- DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e
- WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b)
- WhileStat True p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p)
- BreakStat l -> maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l
- ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l
- LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s
+ DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+?> char '=' <+?> jsToDocR r e
+ WhileStat False p b -> hangBrace (text "while" <+?> parens (jsToDocR r p)) (jnest $ optBlock r b)
+ WhileStat True p b -> hangBrace (text "do") (jnest $ optBlock r b) <+?> text "while" <+?> parens (jsToDocR r p)
+ BreakStat l -> addSemi $ maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l
+ ContinueStat l -> addSemi $ maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l
+ LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$$ printBS s
where
- printBS (BlockStat ss) = vcat $ interSemi $ map (jsToDocR r) ss
+ printBS (BlockStat ss) = interSemi $ map (jsToDocR r) ss
printBS x = jsToDocR r x
- ForStat init p s1 sb -> hangBrace (text "for" <> forCond) (jsToDocR r sb)
+ ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (jnest $ optBlock r sb)
where
- forCond = parens $ hcat $ interSemi
- [ jsToDocR r init
- , jsToDocR r p
- , parens (jsToDocR r s1)
- ]
- ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b)
+ forCond = jsToDocR r init <> semi <+?> jsToDocR r p <> semi <+?> parens (jsToDocR r s1)
+ ForInStat each i e b -> hangBrace (text txt <+?> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jnest $ optBlock r b)
where txt | each = "for each"
| otherwise = "for"
- SwitchStat e l d -> hangBrace (text "switch" <+> parens (jsToDocR r e)) cases
- where l' = map (\(c,s) -> (text "case" <+> parens (jsToDocR r c) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)]
- cases = vcat l'
+ SwitchStat e l d -> hangBrace (text "switch" <+?> parens (jsToDocR r e)) cases
+ where l' = map (\(c,s) -> (text "case" <+?> parens (jsToDocR r c) <> colon) $$$ jnest (optBlock r s)) l
+ ++ [(text "default:") $$$ jnest (optBlock r d)]
+ cases = foldl1 ($$$) l'
ReturnStat e -> text "return" <+> jsToDocR r e
- ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es)
+ ApplStat e es -> jsToDocR r e <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) es)
FuncStat i is b -> hangBrace (text "function" <+> jsToDocR r i
- <> parens (fsep . punctuate comma . map (jsToDocR r) $ is))
- (jsToDocR r b)
- TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally
- where mbCatch | s1 == BlockStat [] = PP.empty
- | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1)
- mbFinally | s2 == BlockStat [] = PP.empty
- | otherwise = hangBrace (text "finally") (jsToDocR r s2)
+ <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is))
+ (jnest $ optBlock r b)
+ TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) <+?> mbCatch <+?> mbFinally
+ where mbCatch | s1 == BlockStat [] = empty
+ | otherwise = hangBrace (text "catch" <+?> parens (jsToDocR r i)) (jnest $ optBlock r s1)
+ mbFinally | s2 == BlockStat [] = empty
+ | otherwise = hangBrace (text "finally") (jnest $ optBlock r s2)
AssignStat i op x -> case x of
-- special treatment for functions, otherwise there is too much left padding
-- (more than the length of the expression assigned to). E.g.
@@ -183,36 +183,41 @@ defRenderJsS r = \case
-- ...
-- });
--
- ValExpr (JFunc is b) -> sep [jsToDocR r i <+> ftext (aOpText op) <+> text " function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"]
- _ -> jsToDocR r i <+> ftext (aOpText op) <+> jsToDocR r x
+ ValExpr (JFunc is b) -> jsToDocR r i <> ftext (aOpText op) <> text " function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is) <> braceNest (jsToDocR r b)
+ _ -> jsToDocR r i <+?> ftext (aOpText op) <+?> jsToDocR r x
UOpStat op x
| isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
- | isPre op -> ftext (uOpText op) <> optParens r x
- | otherwise -> optParens r x <> ftext (uOpText op)
+ | isPre op -> ftext (uOpText op) <+> optParens r x
+ | otherwise -> optParens r x <+> ftext (uOpText op)
BlockStat xs -> jsToDocR r xs
-optParens :: RenderJs -> JExpr -> Doc
+optBlock :: JsRender doc => RenderJs doc -> JStat -> doc
+optBlock r x = case x of
+ BlockStat{} -> jsToDocR r x
+ _ -> addSemi $ jsToDocR r x
+
+optParens :: JsRender doc => RenderJs doc -> JExpr -> doc
optParens r x = case x of
UOpExpr _ _ -> parens (jsToDocR r x)
_ -> jsToDocR r x
-defRenderJsE :: RenderJs -> JExpr -> Doc
+defRenderJsE :: JsRender doc => RenderJs doc -> JExpr -> doc
defRenderJsE r = \case
ValExpr x -> jsToDocR r x
SelExpr x y -> jsToDocR r x <> char '.' <> jsToDocR r y
IdxExpr x y -> jsToDocR r x <> brackets (jsToDocR r y)
- IfExpr x y z -> parens (jsToDocR r x <+> char '?' <+> jsToDocR r y <+> char ':' <+> jsToDocR r z)
- InfixExpr op x y -> parens $ hsep [jsToDocR r x, ftext (opText op), jsToDocR r y]
+ IfExpr x y z -> parens (jsToDocR r x <+?> char '?' <+?> jsToDocR r y <+?> colon <+?> jsToDocR r z)
+ InfixExpr op x y -> parens $ jsToDocR r x <+?> ftext (opText op) <+?> jsToDocR r y
UOpExpr op x
| isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
- | isPre op -> ftext (uOpText op) <> optParens r x
- | otherwise -> optParens r x <> ftext (uOpText op)
- ApplExpr je xs -> jsToDocR r je <> (parens . hsep . punctuate comma $ map (jsToDocR r) xs)
+ | isPre op -> ftext (uOpText op) <+> optParens r x
+ | otherwise -> optParens r x <+> ftext (uOpText op)
+ ApplExpr je xs -> jsToDocR r je <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs)
-defRenderJsV :: RenderJs -> JVal -> Doc
+defRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc
defRenderJsV r = \case
JVar i -> jsToDocR r i
- JList xs -> brackets . hsep . punctuate comma $ map (jsToDocR r) xs
+ JList xs -> brackets . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs
JDouble (SaneDouble d)
| d < 0 || isNegativeZero d -> parens (double d)
| otherwise -> double d
@@ -220,17 +225,17 @@ defRenderJsV r = \case
| i < 0 -> parens (integer i)
| otherwise -> integer i
JStr s -> pprStringLit s
- JRegEx s -> hcat [char '/',ftext s, char '/']
+ JRegEx s -> char '/' <> ftext s <> char '/'
JHash m
| isNullUniqMap m -> text "{}"
- | otherwise -> braceNest . hsep . punctuate comma .
- map (\(x,y) -> squotes (ftext x) <> colon <+> jsToDocR r y)
+ | otherwise -> braceNest . foldl' (<+?>) empty . punctuate comma .
+ map (\(x,y) -> char '\'' <> ftext x <> char '\'' <> colon <+?> jsToDocR r y)
-- nonDetKeysUniqMap doesn't introduce non-determinism here
-- because we sort the elements lexically
$ sortOn (LexicalFastString . fst) (nonDetUniqMapToList m)
- JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)
+ JFunc is b -> parens $ hangBrace (text "function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)
-defRenderJsI :: RenderJs -> Ident -> Doc
+defRenderJsI :: JsRender doc => RenderJs doc -> Ident -> doc
defRenderJsI _ (TxtI t) = ftext t
aOpText :: AOp -> FastString
@@ -298,17 +303,17 @@ isAlphaOp = \case
VoidOp -> True
_ -> False
-pprStringLit :: FastString -> Doc
-pprStringLit s = hcat [char '\"',encodeJson s, char '\"']
+pprStringLit :: IsLine doc => FastString -> doc
+pprStringLit s = char '\"' <> encodeJson s <> char '\"'
--------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------
-encodeJson :: FastString -> Doc
+encodeJson :: IsLine doc => FastString -> doc
encodeJson xs = hcat (map encodeJsonChar (unpackFS xs))
-encodeJsonChar :: Char -> Doc
+encodeJsonChar :: IsLine doc => Char -> doc
encodeJsonChar = \case
'/' -> text "\\/"
'\b' -> text "\\b"
@@ -329,24 +334,54 @@ encodeJsonChar = \case
let h = showHex cp ""
in text (prefix ++ replicate (pad - length h) '0' ++ h)
-braceNest :: Doc -> Doc
-braceNest x = char '{' <+> nest 2 x $$ char '}'
-
-interSemi :: [Doc] -> [Doc]
-interSemi [] = []
-interSemi [s] = [s]
-interSemi (x:xs) = x <> text ";" : interSemi xs
-addSemi :: Doc -> Doc
-addSemi x = x <> text ";"
-
--- | Hang with braces:
---
--- hdr {
--- body
--- }
-hangBrace :: Doc -> Doc -> Doc
-hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ]
-
-($$$) :: Doc -> Doc -> Doc
-x $$$ y = nest 2 $ x $+$ y
+interSemi :: JsRender doc => [doc] -> doc
+interSemi = foldl ($$$) empty . punctuateFinal semi semi
+
+addSemi :: IsLine doc => doc -> doc
+addSemi x = x <> semi <> char '\n'
+
+-- | The structure `{body}`, optionally indented over multiple lines
+{-# INLINE braceNest #-}
+braceNest :: JsRender doc => doc -> doc
+braceNest x = lbrace $$$ jnest x $$$ rbrace
+
+-- | The structure `hdr {body}`, optionally indented over multiple lines
+{-# INLINE hangBrace #-}
+hangBrace :: JsRender doc => doc -> doc -> doc
+hangBrace hdr body = hdr <+?> braceNest body
+
+-- | JsRender controls the differences in whitespace between HLine and SDoc.
+-- Generally, this involves the indentation and newlines in the human-readable
+-- SDoc implementation being replaced in the HLine version by the minimal
+-- whitespace required for valid JavaScript syntax.
+class IsLine doc => JsRender doc where
+
+ -- | Concatenate with an optional single space
+ (<+?>) :: doc -> doc -> doc
+ -- | Concatenate with an optional newline
+ ($$$) :: doc -> doc -> doc
+ -- | Concatenate these `doc`s, either vertically (SDoc) or horizontally (HLine)
+ jcat :: [doc] -> doc
+ -- | Optionally indent the following
+ jnest :: doc -> doc
+
+instance JsRender SDoc where
+ (<+?>) = (<+>)
+ {-# INLINE (<+?>) #-}
+ ($$$) = ($$)
+ {-# INLINE ($$$) #-}
+ jcat = vcat
+ {-# INLINE jcat #-}
+ jnest = nest 2
+ {-# INLINE jnest #-}
+
+instance JsRender HLine where
+ (<+?>) = (<>)
+ {-# INLINE (<+?>) #-}
+ ($$$) = (<>)
+ {-# INLINE ($$$) #-}
+ jcat = hcat
+ {-# INLINE jcat #-}
+ jnest = id
+ {-# INLINE jnest #-}
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -0,0 +1,411 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections, RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHC.Linker.Deps
+ ( LinkDepsOpts (..)
+ , LinkDeps (..)
+ , getLinkDeps
+ )
+where
+
+import GHC.Prelude
+
+import GHC.Platform.Ways
+
+import GHC.Runtime.Interpreter
+
+import GHC.Linker.Types
+
+import GHC.Types.SourceFile
+import GHC.Types.SrcLoc
+import GHC.Types.Unique.DSet
+import GHC.Types.Unique.DFM
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Error
+
+import GHC.Unit.Env
+import GHC.Unit.Finder
+import GHC.Unit.Module
+import GHC.Unit.Module.ModIface
+import GHC.Unit.Module.WholeCoreBindings
+import GHC.Unit.Module.Deps
+import GHC.Unit.Module.Graph
+import GHC.Unit.Home.ModInfo
+
+import GHC.Iface.Errors.Types
+import GHC.Iface.Errors.Ppr
+
+import GHC.Utils.Misc
+import GHC.Unit.Home
+import GHC.Data.Maybe
+
+import Control.Monad
+import Control.Applicative
+
+import qualified Data.Set as Set
+import qualified Data.Map as M
+import Data.List (isSuffixOf)
+import Data.Either
+
+import System.FilePath
+import System.Directory
+
+
+data LinkDepsOpts = LinkDepsOpts
+ { ldObjSuffix :: !String -- ^ Suffix of .o files
+ , ldOneShotMode :: !Bool -- ^ Is the driver in one-shot mode?
+ , ldModuleGraph :: !ModuleGraph -- ^ Module graph
+ , ldUnitEnv :: !UnitEnv -- ^ Unit environment
+ , ldPprOpts :: !SDocContext -- ^ Rendering options for error messages
+ , ldFinderCache :: !FinderCache -- ^ Finder cache
+ , ldFinderOpts :: !FinderOpts -- ^ Finder options
+ , ldUseByteCode :: !Bool -- ^ Use bytecode rather than objects
+ , ldMsgOpts :: !(DiagnosticOpts IfaceMessage) -- ^ Options for diagnostics
+ , ldWays :: !Ways -- ^ Enabled ways
+ , ldLoadIface :: SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
+ -- ^ Interface loader function
+ }
+
+data LinkDeps = LinkDeps
+ { ldNeededLinkables :: [Linkable]
+ , ldAllLinkables :: [Linkable]
+ , ldUnits :: [UnitId]
+ , ldNeededUnits :: UniqDSet UnitId
+ }
+
+-- | Find all the packages and linkables that a set of modules depends on
+--
+-- Return the module and package dependencies for the needed modules.
+-- See Note [Object File Dependencies]
+--
+-- Fails with an IO exception if it can't find enough files
+--
+getLinkDeps
+ :: LinkDepsOpts
+ -> Interp
+ -> LoaderState
+ -> SrcSpan -- for error messages
+ -> [Module] -- If you need these
+ -> IO LinkDeps -- ... then link these first
+getLinkDeps opts interp pls span mods = do
+ -- The interpreter and dynamic linker can only handle object code built
+ -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
+ -- So here we check the build tag: if we're building a non-standard way
+ -- then we need to find & link object files built the "normal" way.
+ maybe_normal_osuf <- checkNonStdWay opts interp span
+
+ get_link_deps opts pls maybe_normal_osuf span mods
+
+
+get_link_deps
+ :: LinkDepsOpts
+ -> LoaderState
+ -> Maybe FilePath -- replace object suffixes?
+ -> SrcSpan
+ -> [Module]
+ -> IO LinkDeps
+get_link_deps opts pls maybe_normal_osuf span mods = do
+ -- 1. Find the dependent home-pkg-modules/packages from each iface
+ -- (omitting modules from the interactive package, which is already linked)
+ (mods_s, pkgs_s) <-
+ -- Why two code paths here? There is a significant amount of repeated work
+ -- performed calculating transitive dependencies
+ -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)
+ if ldOneShotMode opts
+ then follow_deps (filterOut isInteractiveModule mods)
+ emptyUniqDSet emptyUniqDSet;
+ else do
+ (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods
+ return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs))
+
+ let
+ -- 2. Exclude ones already linked
+ -- Main reason: avoid findModule calls in get_linkable
+ (mods_needed, links_got) = partitionEithers (map split_mods mods_s)
+ pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls
+
+ split_mods mod =
+ let is_linked = lookupModuleEnv (objs_loaded pls) mod
+ <|> lookupModuleEnv (bcos_loaded pls) mod
+ in case is_linked of
+ Just linkable -> Right linkable
+ Nothing -> Left mod
+
+ -- 3. For each dependent module, find its linkable
+ -- This will either be in the HPT or (in the case of one-shot
+ -- compilation) we may need to use maybe_getFileLinkable
+ lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed
+
+ return $ LinkDeps
+ { ldNeededLinkables = lnks_needed
+ , ldAllLinkables = links_got ++ lnks_needed
+ , ldUnits = pkgs_needed
+ , ldNeededUnits = pkgs_s
+ }
+ where
+ mod_graph = ldModuleGraph opts
+ unit_env = ldUnitEnv opts
+
+ -- This code is used in `--make` mode to calculate the home package and unit dependencies
+ -- for a set of modules.
+ --
+ -- It is significantly more efficient to use the shared transitive dependency
+ -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.
+
+ -- It is also a matter of correctness to use the module graph so that dependencies between home units
+ -- is resolved correctly.
+ make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)
+ make_deps_loop found [] = found
+ make_deps_loop found@(found_units, found_mods) (nk:nexts)
+ | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
+ | otherwise =
+ case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of
+ Just trans_deps ->
+ let deps = Set.insert (NodeKey_Module nk) trans_deps
+ -- See #936 and the ghci.prog007 test for why we have to continue traversing through
+ -- boot modules.
+ todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]
+ in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
+ Nothing ->
+ let (ModNodeKeyWithUid _ uid) = nk
+ in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
+
+ mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
+ (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)
+
+ all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]
+
+ get_mod_info (ModNodeKeyWithUid gwib uid) =
+ case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of
+ Just hmi ->
+ let iface = (hm_iface hmi)
+ mmod = case mi_hsc_src iface of
+ HsBootFile -> link_boot_mod_error (mi_module iface)
+ _ -> return $ Just (mi_module iface)
+
+ in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod
+ Nothing -> throwProgramError opts $
+ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid
+
+
+ -- This code is used in one-shot mode to traverse downwards through the HPT
+ -- to find all link dependencies.
+ -- The ModIface contains the transitive closure of the module dependencies
+ -- within the current package, *except* for boot modules: if we encounter
+ -- a boot module, we have to find its real interface and discover the
+ -- dependencies of that. Hence we need to traverse the dependency
+ -- tree recursively. See bug #936, testcase ghci/prog007.
+ follow_deps :: [Module] -- modules to follow
+ -> UniqDSet Module -- accum. module dependencies
+ -> UniqDSet UnitId -- accum. package dependencies
+ -> IO ([Module], UniqDSet UnitId) -- result
+ follow_deps [] acc_mods acc_pkgs
+ = return (uniqDSetToList acc_mods, acc_pkgs)
+ follow_deps (mod:mods) acc_mods acc_pkgs
+ = do
+ mb_iface <- ldLoadIface opts msg mod
+ iface <- case mb_iface of
+ Failed err -> throwProgramError opts $
+ missingInterfaceErrorDiagnostic (ldMsgOpts opts) err
+ Succeeded iface -> return iface
+
+ when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
+
+ let
+ pkg = moduleUnit mod
+ deps = mi_deps iface
+
+ pkg_deps = dep_direct_pkgs deps
+ (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
+ \case
+ (_, GWIB m IsBoot) -> Left m
+ (_, GWIB m NotBoot) -> Right m
+
+ mod_deps' = case ue_homeUnit unit_env of
+ Nothing -> []
+ Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))
+ acc_mods' = case ue_homeUnit unit_env of
+ Nothing -> acc_mods
+ Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)
+ acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
+
+ case ue_homeUnit unit_env of
+ Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods)
+ acc_mods' acc_pkgs'
+ _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
+ where
+ msg = text "need to link module" <+> ppr mod <+>
+ text "due to use of Template Haskell"
+
+
+
+ link_boot_mod_error :: Module -> IO a
+ link_boot_mod_error mod = throwProgramError opts $
+ text "module" <+> ppr mod <+>
+ text "cannot be linked; it is only available as a boot module"
+
+ no_obj :: Outputable a => a -> IO b
+ no_obj mod = dieWith opts span $
+ text "cannot find object file for module " <>
+ quotes (ppr mod) $$
+ while_linking_expr
+
+ while_linking_expr = text "while linking an interpreted expression"
+
+
+ -- See Note [Using Byte Code rather than Object Code for Template Haskell]
+ homeModLinkable :: HomeModInfo -> Maybe Linkable
+ homeModLinkable hmi =
+ if ldUseByteCode opts
+ then homeModInfoByteCode hmi <|> homeModInfoObject hmi
+ else homeModInfoObject hmi <|> homeModInfoByteCode hmi
+
+ get_linkable osuf mod -- A home-package module
+ | Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env)
+ = adjust_linkable (expectJust "getLinkDeps" (homeModLinkable mod_info))
+ | otherwise
+ = do -- It's not in the HPT because we are in one shot mode,
+ -- so use the Finder to get a ModLocation...
+ case ue_homeUnit unit_env of
+ Nothing -> no_obj mod
+ Just home_unit -> do
+
+ let fc = ldFinderCache opts
+ let fopts = ldFinderOpts opts
+ mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
+ case mb_stuff of
+ Found loc mod -> found loc mod
+ _ -> no_obj (moduleName mod)
+ where
+ found loc mod = do {
+ -- ...and then find the linkable for it
+ mb_lnk <- findObjectLinkableMaybe mod loc ;
+ case mb_lnk of {
+ Nothing -> no_obj mod ;
+ Just lnk -> adjust_linkable lnk
+ }}
+
+ adjust_linkable lnk
+ | Just new_osuf <- maybe_normal_osuf = do
+ new_uls <- mapM (adjust_ul new_osuf)
+ (linkableUnlinked lnk)
+ return lnk{ linkableUnlinked=new_uls }
+ | otherwise =
+ return lnk
+
+ adjust_ul new_osuf (DotO file) = do
+ massert (osuf `isSuffixOf` file)
+ let file_base = fromJust (stripExtension osuf file)
+ new_file = file_base <.> new_osuf
+ ok <- doesFileExist new_file
+ if (not ok)
+ then dieWith opts span $
+ text "cannot find object file "
+ <> quotes (text new_file) $$ while_linking_expr
+ else return (DotO new_file)
+ adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
+ adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
+ adjust_ul _ l@(BCOs {}) = return l
+ adjust_ul _ l at LoadedBCOs{} = return l
+ adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod)
+
+{-
+Note [Using Byte Code rather than Object Code for Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The `-fprefer-byte-code` flag allows a user to specify that they want to use
+byte code (if availble) rather than object code for home module dependenices
+when executing Template Haskell splices.
+
+Why might you want to use byte code rather than object code?
+
+* Producing object code is much slower than producing byte code (for example if you're using -fno-code)
+* Linking many large object files, which happens once per splice, is quite expensive. (#21700)
+
+So we allow the user to choose to use byte code rather than object files if they want to avoid these
+two pitfalls.
+
+When using `-fprefer-byte-code` you have to arrange to have the byte code availble.
+In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`.
+See Note [Home module build products] for some more information about that.
+
+The only other place where the flag is consulted is when enabling code generation
+with `-fno-code`, which does so to anticipate what decision we will make at the
+splice point about what we would prefer.
+
+-}
+
+dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a
+dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg)
+
+throwProgramError :: LinkDepsOpts -> SDoc -> IO a
+throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc))
+
+checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath)
+checkNonStdWay _opts interp _srcspan
+ | ExternalInterp {} <- interpInstance interp = return Nothing
+ -- with -fexternal-interpreter we load the .o files, whatever way
+ -- they were built. If they were built for a non-std way, then
+ -- we will use the appropriate variant of the iserv binary to load them.
+
+-- #if-guard the following equations otherwise the pattern match checker will
+-- complain that they are redundant.
+#if defined(HAVE_INTERNAL_INTERPRETER)
+checkNonStdWay opts _interp srcspan
+ | hostFullWays == targetFullWays = return Nothing
+ -- Only if we are compiling with the same ways as GHC is built
+ -- with, can we dynamically load those object files. (see #3604)
+
+ | ldObjSuffix opts == normalObjectSuffix && not (null targetFullWays)
+ = failNonStd opts srcspan
+
+ | otherwise = return (Just (hostWayTag ++ "o"))
+ where
+ targetFullWays = fullWays (ldWays opts)
+ hostWayTag = case waysTag hostFullWays of
+ "" -> ""
+ tag -> tag ++ "_"
+
+ normalObjectSuffix :: String
+ normalObjectSuffix = "o"
+
+data Way' = Normal | Prof | Dyn
+
+failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe FilePath)
+failNonStd opts srcspan = dieWith opts srcspan $
+ text "Cannot load" <+> pprWay' compWay <+>
+ text "objects when GHC is built" <+> pprWay' ghciWay $$
+ text "To fix this, either:" $$
+ text " (1) Use -fexternal-interpreter, or" $$
+ buildTwiceMsg
+ where compWay
+ | ldWays opts `hasWay` WayDyn = Dyn
+ | ldWays opts `hasWay` WayProf = Prof
+ | otherwise = Normal
+ ghciWay
+ | hostIsDynamic = Dyn
+ | hostIsProfiled = Prof
+ | otherwise = Normal
+ buildTwiceMsg = case (ghciWay, compWay) of
+ (Normal, Dyn) -> dynamicTooMsg
+ (Dyn, Normal) -> dynamicTooMsg
+ _ ->
+ text " (2) Build the program twice: once" <+>
+ pprWay' ghciWay <> text ", and then" $$
+ text " " <> pprWay' compWay <+>
+ text "using -osuf to set a different object file suffix."
+ dynamicTooMsg = text " (2) Use -dynamic-too," <+>
+ text "and use -osuf and -dynosuf to set object file suffixes as needed."
+ pprWay' :: Way' -> SDoc
+ pprWay' way = text $ case way of
+ Normal -> "the normal way"
+ Prof -> "with -prof"
+ Dyn -> "with -dynamic"
+#endif
+
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -50,7 +50,7 @@ import GHC.Tc.Utils.Monad
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
-
+import GHC.Iface.Load
import GHC.ByteCode.Linker
import GHC.ByteCode.Asm
@@ -67,24 +67,18 @@ import GHC.Types.Unique.DFM
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Unit.Env
-import GHC.Unit.Finder
import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.WholeCoreBindings
-import GHC.Unit.Module.Deps
-import GHC.Unit.Home.ModInfo
import GHC.Unit.State as Packages
import qualified GHC.Data.ShortText as ST
-import qualified GHC.Data.Maybe as Maybes
import GHC.Data.FastString
+import GHC.Linker.Deps
import GHC.Linker.MacOS
import GHC.Linker.Dynamic
import GHC.Linker.Types
@@ -93,10 +87,9 @@ import GHC.Linker.Types
import Control.Monad
import qualified Data.Set as Set
-import qualified Data.Map as M
import Data.Char (isSpace)
import Data.IORef
-import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)
+import Data.List (intercalate, isPrefixOf, nub, partition)
import Data.Maybe
import Control.Concurrent.MVar
import qualified Control.Monad.Catch as MC
@@ -112,15 +105,6 @@ import System.Win32.Info (getSystemDirectory)
import GHC.Utils.Exception
-import GHC.Unit.Module.Graph
-import GHC.Types.SourceFile
-import GHC.Utils.Misc
-import GHC.Iface.Load
-import GHC.Unit.Home
-import Data.Either
-import Control.Applicative
-import GHC.Iface.Errors.Ppr
-
uninitialised :: a
uninitialised = panic "Loader not initialised"
@@ -207,28 +191,23 @@ loadDependencies
-> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required
loadDependencies interp hsc_env pls span needed_mods = do
-- initLoaderState (hsc_dflags hsc_env) dl
- let dflags = hsc_dflags hsc_env
- -- The interpreter and dynamic linker can only handle object code built
- -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
- -- So here we check the build tag: if we're building a non-standard way
- -- then we need to find & link object files built the "normal" way.
- maybe_normal_osuf <- checkNonStdWay dflags interp span
+ let opts = initLinkDepsOpts hsc_env
-- Find what packages and linkables are required
- (lnks, all_lnks, pkgs, this_pkgs_needed)
- <- getLinkDeps hsc_env pls
- maybe_normal_osuf span needed_mods
+ deps <- getLinkDeps opts interp pls span needed_mods
+
+ let this_pkgs_needed = ldNeededUnits deps
-- Link the packages and modules required
- pls1 <- loadPackages' interp hsc_env pkgs pls
- (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 lnks
+ pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls
+ (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps)
let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed
all_pkgs_loaded = pkgs_loaded pls2
trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg
| pkg_id <- uniqDSetToList this_pkgs_needed
, Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id]
])
- return (pls2, succ, all_lnks, this_pkgs_loaded)
+ return (pls2, succ, ldAllLinkables deps, this_pkgs_loaded)
-- | Temporarily extend the loaded env.
@@ -614,315 +593,27 @@ loadExpr interp hsc_env span root_ul_bco = do
-- All wired-in names are in the base package, which we link
-- by default, so we can safely ignore them here.
-dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a
-dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg)))
-
-
-checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)
-checkNonStdWay _dflags interp _srcspan
- | ExternalInterp {} <- interpInstance interp = return Nothing
- -- with -fexternal-interpreter we load the .o files, whatever way
- -- they were built. If they were built for a non-std way, then
- -- we will use the appropriate variant of the iserv binary to load them.
-
--- #if-guard the following equations otherwise the pattern match checker will
--- complain that they are redundant.
-#if defined(HAVE_INTERNAL_INTERPRETER)
-checkNonStdWay dflags _interp srcspan
- | hostFullWays == targetFullWays = return Nothing
- -- Only if we are compiling with the same ways as GHC is built
- -- with, can we dynamically load those object files. (see #3604)
-
- | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays)
- = failNonStd dflags srcspan
-
- | otherwise = return (Just (hostWayTag ++ "o"))
- where
- targetFullWays = fullWays (ways dflags)
- hostWayTag = case waysTag hostFullWays of
- "" -> ""
- tag -> tag ++ "_"
-
- normalObjectSuffix :: String
- normalObjectSuffix = phaseInputExt StopLn
-
-data Way' = Normal | Prof | Dyn
-
-failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
-failNonStd dflags srcspan = dieWith dflags srcspan $
- text "Cannot load" <+> pprWay' compWay <+>
- text "objects when GHC is built" <+> pprWay' ghciWay $$
- text "To fix this, either:" $$
- text " (1) Use -fexternal-interpreter, or" $$
- buildTwiceMsg
- where compWay
- | ways dflags `hasWay` WayDyn = Dyn
- | ways dflags `hasWay` WayProf = Prof
- | otherwise = Normal
- ghciWay
- | hostIsDynamic = Dyn
- | hostIsProfiled = Prof
- | otherwise = Normal
- buildTwiceMsg = case (ghciWay, compWay) of
- (Normal, Dyn) -> dynamicTooMsg
- (Dyn, Normal) -> dynamicTooMsg
- _ ->
- text " (2) Build the program twice: once" <+>
- pprWay' ghciWay <> text ", and then" $$
- text " " <> pprWay' compWay <+>
- text "using -osuf to set a different object file suffix."
- dynamicTooMsg = text " (2) Use -dynamic-too," <+>
- text "and use -osuf and -dynosuf to set object file suffixes as needed."
- pprWay' :: Way' -> SDoc
- pprWay' way = text $ case way of
- Normal -> "the normal way"
- Prof -> "with -prof"
- Dyn -> "with -dynamic"
-#endif
-
-getLinkDeps :: HscEnv
- -> LoaderState
- -> Maybe FilePath -- replace object suffixes?
- -> SrcSpan -- for error messages
- -> [Module] -- If you need these
- -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first
- -- The module and package dependencies for the needed modules are returned.
- -- See Note [Object File Dependencies]
--- Fails with an IO exception if it can't find enough files
-
-getLinkDeps hsc_env pls replace_osuf span mods
--- Find all the packages and linkables that a set of modules depends on
- = do {
- -- 1. Find the dependent home-pkg-modules/packages from each iface
- -- (omitting modules from the interactive package, which is already linked)
- ; (mods_s, pkgs_s) <-
- -- Why two code paths here? There is a significant amount of repeated work
- -- performed calculating transitive dependencies
- -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)
- if isOneShot (ghcMode dflags)
- then follow_deps (filterOut isInteractiveModule mods)
- emptyUniqDSet emptyUniqDSet;
- else do
- (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods
- return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs))
-
- ; let
- -- 2. Exclude ones already linked
- -- Main reason: avoid findModule calls in get_linkable
- (mods_needed, links_got) = partitionEithers (map split_mods mods_s)
- pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls
-
- split_mods mod =
- let is_linked = findModuleLinkable_maybe (objs_loaded pls) mod <|> findModuleLinkable_maybe (bcos_loaded pls) mod
- in case is_linked of
- Just linkable -> Right linkable
- Nothing -> Left mod
-
- -- 3. For each dependent module, find its linkable
- -- This will either be in the HPT or (in the case of one-shot
- -- compilation) we may need to use maybe_getFileLinkable
- ; let { osuf = objectSuf dflags }
- ; lnks_needed <- mapM (get_linkable osuf) mods_needed
-
- ; return (lnks_needed, links_got ++ lnks_needed, pkgs_needed, pkgs_s) }
+initLinkDepsOpts :: HscEnv -> LinkDepsOpts
+initLinkDepsOpts hsc_env = opts
where
+ opts = LinkDepsOpts
+ { ldObjSuffix = objectSuf dflags
+ , ldOneShotMode = isOneShot (ghcMode dflags)
+ , ldModuleGraph = hsc_mod_graph hsc_env
+ , ldUnitEnv = hsc_unit_env hsc_env
+ , ldLoadIface = load_iface
+ , ldPprOpts = initSDocContext dflags defaultUserStyle
+ , ldFinderCache = hsc_FC hsc_env
+ , ldFinderOpts = initFinderOpts dflags
+ , ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags
+ , ldMsgOpts = initIfaceMessageOpts dflags
+ , ldWays = ways dflags
+ }
dflags = hsc_dflags hsc_env
- mod_graph = hsc_mod_graph hsc_env
+ load_iface msg mod = initIfaceCheck (text "loader") hsc_env
+ $ loadInterface msg mod (ImportByUser NotBoot)
- -- This code is used in `--make` mode to calculate the home package and unit dependencies
- -- for a set of modules.
- --
- -- It is significantly more efficient to use the shared transitive dependency
- -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.
-
- -- It is also a matter of correctness to use the module graph so that dependencies between home units
- -- is resolved correctly.
- make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)
- make_deps_loop found [] = found
- make_deps_loop found@(found_units, found_mods) (nk:nexts)
- | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
- | otherwise =
- case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of
- Just trans_deps ->
- let deps = Set.insert (NodeKey_Module nk) trans_deps
- -- See #936 and the ghci.prog007 test for why we have to continue traversing through
- -- boot modules.
- todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]
- in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
- Nothing ->
- let (ModNodeKeyWithUid _ uid) = nk
- in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
-
- mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
- (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)
-
- all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]
-
- get_mod_info (ModNodeKeyWithUid gwib uid) =
- case lookupHug (hsc_HUG hsc_env) uid (gwib_mod gwib) of
- Just hmi ->
- let iface = (hm_iface hmi)
- mmod = case mi_hsc_src iface of
- HsBootFile -> link_boot_mod_error (mi_module iface)
- _ -> return $ Just (mi_module iface)
-
- in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod
- Nothing ->
- let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid
- in throwGhcExceptionIO (ProgramError (showSDoc dflags err))
-
-
- -- This code is used in one-shot mode to traverse downwards through the HPT
- -- to find all link dependencies.
- -- The ModIface contains the transitive closure of the module dependencies
- -- within the current package, *except* for boot modules: if we encounter
- -- a boot module, we have to find its real interface and discover the
- -- dependencies of that. Hence we need to traverse the dependency
- -- tree recursively. See bug #936, testcase ghci/prog007.
- follow_deps :: [Module] -- modules to follow
- -> UniqDSet Module -- accum. module dependencies
- -> UniqDSet UnitId -- accum. package dependencies
- -> IO ([Module], UniqDSet UnitId) -- result
- follow_deps [] acc_mods acc_pkgs
- = return (uniqDSetToList acc_mods, acc_pkgs)
- follow_deps (mod:mods) acc_mods acc_pkgs
- = do
- mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
- loadInterface msg mod (ImportByUser NotBoot)
- iface <- case mb_iface of
- Maybes.Failed err ->
- let opts = initIfaceMessageOpts dflags
- err_txt = missingInterfaceErrorDiagnostic opts err
- in throwGhcExceptionIO (ProgramError (showSDoc dflags err_txt))
- Maybes.Succeeded iface -> return iface
-
- when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
-
- let
- pkg = moduleUnit mod
- deps = mi_deps iface
-
- pkg_deps = dep_direct_pkgs deps
- (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
- \case
- (_, GWIB m IsBoot) -> Left m
- (_, GWIB m NotBoot) -> Right m
-
- mod_deps' = case hsc_home_unit_maybe hsc_env of
- Nothing -> []
- Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))
- acc_mods' = case hsc_home_unit_maybe hsc_env of
- Nothing -> acc_mods
- Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)
- acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
-
- case hsc_home_unit_maybe hsc_env of
- Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods)
- acc_mods' acc_pkgs'
- _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
- where
- msg = text "need to link module" <+> ppr mod <+>
- text "due to use of Template Haskell"
-
-
-
- link_boot_mod_error :: Module -> IO a
- link_boot_mod_error mod =
- throwGhcExceptionIO (ProgramError (showSDoc dflags (
- text "module" <+> ppr mod <+>
- text "cannot be linked; it is only available as a boot module")))
-
- no_obj :: Outputable a => a -> IO b
- no_obj mod = dieWith dflags span $
- text "cannot find object file for module " <>
- quotes (ppr mod) $$
- while_linking_expr
-
- while_linking_expr = text "while linking an interpreted expression"
-
-
- -- See Note [Using Byte Code rather than Object Code for Template Haskell]
- homeModLinkable :: DynFlags -> HomeModInfo -> Maybe Linkable
- homeModLinkable dflags hmi =
- if gopt Opt_UseBytecodeRatherThanObjects dflags
- then homeModInfoByteCode hmi <|> homeModInfoObject hmi
- else homeModInfoObject hmi <|> homeModInfoByteCode hmi
-
- get_linkable osuf mod -- A home-package module
- | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env)
- = adjust_linkable (Maybes.expectJust "getLinkDeps" (homeModLinkable dflags mod_info))
- | otherwise
- = do -- It's not in the HPT because we are in one shot mode,
- -- so use the Finder to get a ModLocation...
- case hsc_home_unit_maybe hsc_env of
- Nothing -> no_obj mod
- Just home_unit -> do
-
- let fc = hsc_FC hsc_env
- let dflags = hsc_dflags hsc_env
- let fopts = initFinderOpts dflags
- mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
- case mb_stuff of
- Found loc mod -> found loc mod
- _ -> no_obj (moduleName mod)
- where
- found loc mod = do {
- -- ...and then find the linkable for it
- mb_lnk <- findObjectLinkableMaybe mod loc ;
- case mb_lnk of {
- Nothing -> no_obj mod ;
- Just lnk -> adjust_linkable lnk
- }}
-
- adjust_linkable lnk
- | Just new_osuf <- replace_osuf = do
- new_uls <- mapM (adjust_ul new_osuf)
- (linkableUnlinked lnk)
- return lnk{ linkableUnlinked=new_uls }
- | otherwise =
- return lnk
-
- adjust_ul new_osuf (DotO file) = do
- massert (osuf `isSuffixOf` file)
- let file_base = fromJust (stripExtension osuf file)
- new_file = file_base <.> new_osuf
- ok <- doesFileExist new_file
- if (not ok)
- then dieWith dflags span $
- text "cannot find object file "
- <> quotes (text new_file) $$ while_linking_expr
- else return (DotO new_file)
- adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
- adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
- adjust_ul _ l@(BCOs {}) = return l
- adjust_ul _ l at LoadedBCOs{} = return l
- adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod)
-
-{-
-Note [Using Byte Code rather than Object Code for Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The `-fprefer-byte-code` flag allows a user to specify that they want to use
-byte code (if availble) rather than object code for home module dependenices
-when executing Template Haskell splices.
-
-Why might you want to use byte code rather than object code?
-* Producing object code is much slower than producing byte code (for example if you're using -fno-code)
-* Linking many large object files, which happens once per splice, is quite expensive. (#21700)
-
-So we allow the user to choose to use byte code rather than object files if they want to avoid these
-two pitfalls.
-
-When using `-fprefer-byte-code` you have to arrange to have the byte code availble.
-In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`.
-See Note [Home module build products] for some more information about that.
-
-The only other place where the flag is consulted is when enabling code generation
-with `-fno-code`, which does so to anticipate what decision we will make at the
-splice point about what we would prefer.
-
--}
{- **********************************************************************
@@ -1019,12 +710,9 @@ partitionLinkable li
li {linkableUnlinked=li_uls_bco}]
_ -> [li]
-findModuleLinkable_maybe :: LinkableSet -> Module -> Maybe Linkable
-findModuleLinkable_maybe = lookupModuleEnv
-
linkableInSet :: Linkable -> LinkableSet -> Bool
linkableInSet l objs_loaded =
- case findModuleLinkable_maybe objs_loaded (linkableModule l) of
+ case lookupModuleEnv objs_loaded (linkableModule l) of
Nothing -> False
Just m -> linkableTime l == linkableTime m
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -91,7 +91,7 @@ stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_
-- Doc to dump when -ddump-js is enabled
when (logHasDumpFlag logger Opt_D_dump_js) $ do
putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
- $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus)
+ $ vcat (fmap (jsToDoc . oiStat . luObjUnit) lus)
-- Write the object file
bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -59,6 +59,7 @@ import GHC.Unit.Types
import GHC.Unit.Module (moduleStableString)
import GHC.Utils.Outputable hiding ((<>))
+import GHC.Utils.BufHandle
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Logger (Logger, logVerbAtLeast)
@@ -80,7 +81,6 @@ import Control.Monad
import Data.Array
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import Data.Function (on)
@@ -118,6 +118,9 @@ newtype ArchiveState = ArchiveState { loadedArchives :: IORef (Map FilePath Ar.A
emptyArchiveState :: IO ArchiveState
emptyArchiveState = ArchiveState <$> newIORef M.empty
+defaultJsContext :: SDocContext
+defaultJsContext = defaultSDocContext{sdocStyle = PprCode}
+
jsLinkBinary
:: JSLinkConfig
-> StgToJSConfig
@@ -173,7 +176,7 @@ link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun ex
-- LTO + rendering of JS code
link_stats <- withBinaryFile (out </> "out.js") WriteMode $ \h ->
- renderLinker h mods jsFiles
+ renderLinker h (csPrettyRender cfg) mods jsFiles
-------------------------------------------------------------
@@ -194,8 +197,13 @@ link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun ex
-- link generated RTS parts into rts.js
unless (lcNoRts lc_cfg) $ do
- BL.writeFile (out </> "rts.js") ( BLC.pack rtsDeclsText
- <> BLC.pack (rtsText cfg))
+ withFile (out </> "rts.js") WriteMode $ \h -> do
+ if csPrettyRender cfg
+ then printSDoc defaultJsContext (Ppr.PageMode True) h (rtsDeclsText $$ rtsText cfg)
+ else do
+ bh <- newBufHandle h
+ bPutHDoc bh defaultJsContext (line rtsDeclsText $$ line (rtsText cfg))
+ bFlush bh
-- link dependencies' JS files into lib.js
withBinaryFile (out </> "lib.js") WriteMode $ \h -> do
@@ -302,10 +310,11 @@ data CompactedModuleCode = CompactedModuleCode
-- | Link modules and pretty-print them into the given Handle
renderLinker
:: Handle
+ -> Bool -- ^ should we render readable JS for debugging?
-> [ModuleCode] -- ^ linked code per module
-> [FilePath] -- ^ additional JS files
-> IO LinkerStats
-renderLinker h mods jsFiles = do
+renderLinker h render_pretty mods jsFiles = do
-- link modules
let (compacted_mods, meta) = linkModules mods
@@ -314,8 +323,14 @@ renderLinker h mods jsFiles = do
putBS = B.hPut h
putJS x = do
before <- hTell h
- Ppr.printLeftRender h (pretty x)
- hPutChar h '\n'
+ if render_pretty
+ then do
+ printSDoc defaultJsContext (Ppr.PageMode True) h (pretty x)
+ else do
+ bh <- newBufHandle h
+ -- Append an empty line to correctly end the file in a newline
+ bPutHDoc bh defaultJsContext ((line $ pretty x) $$ empty)
+ bFlush bh
after <- hTell h
pure $! (after - before)
=====================================
compiler/GHC/StgToJS/Linker/Opt.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Exts
import GHC.JS.Syntax
import GHC.JS.Ppr
-import GHC.Utils.Ppr as PP
+import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Unique.Map
@@ -39,10 +39,10 @@ import Data.List (sortOn)
import Data.Char (isAlpha,isDigit,ord)
import qualified Data.ByteString.Short as SBS
-pretty :: JStat -> Doc
+pretty :: JsRender doc => JStat -> doc
pretty = jsToDocR ghcjsRenderJs
-ghcjsRenderJs :: RenderJs
+ghcjsRenderJs :: RenderJs doc
ghcjsRenderJs = defaultRenderJs
{ renderJsV = ghcjsRenderJsV
, renderJsS = ghcjsRenderJsS
@@ -52,7 +52,7 @@ ghcjsRenderJs = defaultRenderJs
hdd :: SBS.ShortByteString
hdd = SBS.pack (map (fromIntegral . ord) "h$$")
-ghcjsRenderJsI :: RenderJs -> Ident -> Doc
+ghcjsRenderJsI :: IsLine doc => RenderJs doc -> Ident -> doc
ghcjsRenderJsI _ (TxtI fs)
-- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by
-- name in user code, only in compiled code. Hence we can rename them if we do
@@ -75,7 +75,7 @@ ghcjsRenderJsI _ (TxtI fs)
-- | Render as an hexadecimal number in reversed order (because it's faster and we
-- don't care about the actual value).
-hexDoc :: Word -> Doc
+hexDoc :: IsLine doc => Word -> doc
hexDoc 0 = char '0'
hexDoc v = text $ go v
where
@@ -91,23 +91,23 @@ hexDoc v = text $ go v
-- attempt to resugar some of the common constructs
-ghcjsRenderJsS :: RenderJs -> JStat -> Doc
+ghcjsRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc
ghcjsRenderJsS r s = renderJsS defaultRenderJs r s
-- don't quote keys in our object literals, so closure compiler works
-ghcjsRenderJsV :: RenderJs -> JVal -> Doc
+ghcjsRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc
ghcjsRenderJsV r (JHash m)
| isNullUniqMap m = text "{}"
- | otherwise = braceNest . PP.fsep . punctuate comma .
- map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y)
+ | otherwise = braceNest . fsep . punctuate comma .
+ map (\(x,y) -> quoteIfRequired x <> colon <+> jsToDocR r y)
-- nonDetEltsUniqMap doesn't introduce non-determinism here because
-- we sort the elements lexically
. sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m
where
- quoteIfRequired :: FastString -> Doc
+ quoteIfRequired :: IsLine doc => FastString -> doc
quoteIfRequired x
| isUnquotedKey x = ftext x
- | otherwise = PP.squotes (ftext x)
+ | otherwise = char '\'' <> ftext x <> char '\''
isUnquotedKey :: FastString -> Bool
isUnquotedKey fs = case unpackFS fs of
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -O0 #-}
@@ -45,6 +46,7 @@ import GHC.StgToJS.Linker.Opt
import GHC.Data.FastString
import GHC.Types.Unique.Map
+import GHC.JS.Ppr
import Data.Array
import Data.Monoid
@@ -314,12 +316,12 @@ rtsDecls = satJStat (Just "h$RTSD") $
, declRets]
-- | print the embedded RTS to a String
-rtsText :: StgToJSConfig -> String
-rtsText = show . pretty . jsOptimize . rts
+rtsText :: forall doc. JsRender doc => StgToJSConfig -> doc
+rtsText = pretty @doc . jsOptimize . rts
-- | print the RTS declarations to a String.
-rtsDeclsText :: String
-rtsDeclsText = show . pretty . jsOptimize $ rtsDecls
+rtsDeclsText :: forall doc. JsRender doc => doc
+rtsDeclsText = pretty @doc . jsOptimize $ rtsDecls
-- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform'
rts :: StgToJSConfig -> Sat.JStat
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -86,6 +86,7 @@ data StgToJSConfig = StgToJSConfig
, csInlineLoadRegs :: !Bool
, csInlineEnter :: !Bool
, csInlineAlloc :: !Bool
+ , csPrettyRender :: !Bool
, csTraceRts :: !Bool
, csAssertRts :: !Bool
, csBoundsCheck :: !Bool
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1070,7 +1070,7 @@ Wrinkle [GADT result type in tcRecordUpd]
-}
--- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2}@ into a case expression
+-- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression
-- that matches on the constructors of the record @r@, as described in
-- Note [Record Updates].
--
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -42,7 +42,7 @@ module GHC.Tc.Types(
-- Renamer types
ErrCtxt, pushErrCtxt, pushErrCtxtSameOrigin,
ImportAvails(..), emptyImportAvails, plusImportAvails,
- WhereFrom(..), mkModDeps,
+ mkModDeps,
-- Typechecker types
TcTypeEnv, TcBinderStack, TcBinder(..),
@@ -1407,29 +1407,6 @@ plusImportAvails
imp_orphs = unionListsOrd orphs1 orphs2,
imp_finsts = unionListsOrd finsts1 finsts2 }
-{-
-************************************************************************
-* *
-\subsection{Where from}
-* *
-************************************************************************
-
-The @WhereFrom@ type controls where the renamer looks for an interface file
--}
-
-data WhereFrom
- = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-})
- | ImportBySystem -- Non user import.
- | ImportByPlugin -- Importing a plugin;
- -- See Note [Care with plugin imports] in GHC.Iface.Load
-
-instance Outputable WhereFrom where
- ppr (ImportByUser IsBoot) = text "{- SOURCE -}"
- ppr (ImportByUser NotBoot) = empty
- ppr ImportBySystem = text "{- SYSTEM -}"
- ppr ImportByPlugin = text "{- PLUGIN -}"
-
-
{- *********************************************************************
* *
Type signatures
=====================================
compiler/ghc.cabal.in
=====================================
@@ -541,6 +541,7 @@ Library
GHC.JS.Unsat.Syntax
GHC.Linker
GHC.Linker.Config
+ GHC.Linker.Deps
GHC.Linker.Dynamic
GHC.Linker.ExtraObj
GHC.Linker.Loader
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -723,6 +723,16 @@ assembler.
Dump the final JavaScript code produced by the JavaScript code generator.
+JavaScript code generator
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+.. ghc-flag:: -ddisable-js-minifier
+ :shortdesc: Generate pretty-printed JavaScript code instead of minified (compacted) code.
+ :type: dynamic
+
+ Include human-readable spacing and indentation when generating JavaScript.
+
+
Miscellaneous backend dumps
~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -145,11 +145,13 @@ enableDebugInfo = addArgs $ notStage0 ? mconcat
-- | Enable the ticky-ticky profiler in stage2 GHC
enableTickyGhc :: Flavour -> Flavour
-enableTickyGhc =
- addArgs $ orM [stage1, cross] ? mconcat
+enableTickyGhc f =
+ (addArgs (orM [stage1, cross] ? mconcat
[ builder (Ghc CompileHs) ? tickyArgs
, builder (Ghc LinkHs) ? tickyArgs
- ]
+ ]) f) { ghcThreaded = (< Stage2) }
+ -- Build single-threaded ghc because ticky profiling is racy with threaded
+ -- RTS and the C counters are disabled. (See #23439)
tickyArgs :: Args
tickyArgs = mconcat
=====================================
testsuite/tests/linters/notes.stdout
=====================================
@@ -37,7 +37,6 @@ ref compiler/GHC/Tc/TyCl.hs:1130:6: Note [Unification variables need fres
ref compiler/GHC/Tc/TyCl.hs:4982:17: Note [Missing role annotations warning]
ref compiler/GHC/Tc/TyCl.hs:5008:3: Note [Missing role annotations warning]
ref compiler/GHC/Tc/Types.hs:692:33: Note [Extra dependencies from .hs-boot files]
-ref compiler/GHC/Tc/Types.hs:1423:47: Note [Care with plugin imports]
ref compiler/GHC/Tc/Types/Constraint.hs:226:34: Note [NonCanonical Semantics]
ref compiler/GHC/Types/Demand.hs:302:25: Note [Preserving Boxity of results is rarely a win]
ref compiler/GHC/Unit/Module/Deps.hs:81:13: Note [Structure of dep_boot_mods]
=====================================
testsuite/tests/pmcheck/should_compile/T23445.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE GADTs #-}
+
+module T23445 where
+
+data GADT a where
+ IsUnit :: GADT ()
+
+data Foo b where
+ FooUnit :: Foo ()
+ FooInt :: Foo Int
+
+data SomeRec = SomeRec { fld :: () }
+
+bug :: GADT a -> Foo a -> SomeRec -> SomeRec
+bug IsUnit foo r =
+ r { fld = case foo of { FooUnit -> () } }
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -112,6 +112,10 @@ test('CaseOfKnownCon', [], compile, [overlapping_incomplete])
test('TooManyDeltas', [], compile, [overlapping_incomplete+'-fmax-pmcheck-models=0'])
test('LongDistanceInfo', [], compile, [overlapping_incomplete])
test('T21662', [], compile, [overlapping_incomplete])
+test('T19271', [], compile, [overlapping_incomplete])
+test('T21761', [], compile, [overlapping_incomplete])
+test('T22964', [], compile, [overlapping_incomplete])
+test('T23445', [], compile, [overlapping_incomplete])
# Series (inspired) by Luke Maranget
@@ -156,6 +160,4 @@ test('EmptyCase007', [], compile, [overlapping_incomplete])
test('EmptyCase008', [], compile, [overlapping_incomplete])
test('EmptyCase009', [], compile, [overlapping_incomplete])
test('EmptyCase010', [], compile, [overlapping_incomplete])
-test('T19271', [], compile, [overlapping_incomplete])
-test('T21761', [], compile, [overlapping_incomplete])
-test('T22964', [], compile, [overlapping_incomplete])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1882aed59297fd4ae492d577dedfc88eefc5bca8...74a2a9d636575f5dda7a33f824ece32e75dc8584
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1882aed59297fd4ae492d577dedfc88eefc5bca8...74a2a9d636575f5dda7a33f824ece32e75dc8584
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/20230526/b06e4ad2/attachment-0001.html>
More information about the ghc-commits
mailing list