[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 14 commits: Don't attempt pattern synonym error recovery
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Aug 23 13:13:59 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e7db36c1 by sheaf at 2023-08-23T08:41:28-04:00
Don't attempt pattern synonym error recovery
This commit gets rid of the pattern synonym error recovery mechanism
(recoverPSB). The rationale is that the fake pattern synonym binding
that the recovery mechanism introduced could lead to undesirable
knock-on errors, and it isn't really feasible to conjure up a
satisfactory binding as pattern synonyms can be used both in expressions
and patterns.
See Note [Pattern synonym error recovery] in GHC.Tc.TyCl.PatSyn.
It isn't such a big deal to eagerly fail compilation on a pattern synonym
that doesn't typecheck anyway.
Fixes #23467
- - - - -
6ccd9d65 by Ben Gamari at 2023-08-23T08:42:05-04:00
base: Don't use Data.ByteString.Internals.memcpy
This function is now deprecated from `bytestring`. Use
`Foreign.Marshal.Utils.copyBytes` instead.
Fixes #23880.
- - - - -
e07535a8 by Matthew Pickering at 2023-08-23T09:13:27-04:00
hadrian: Uniformly pass buildOptions to all builders in runBuilder
In Builder.hs, runBuilderWith mostly ignores the buildOptions in BuildInfo.
This leads to hard to diagnose bugs as any build options you pass with
runBuilderWithCmdOptions are ignored for many builders.
Solution: Uniformly pass buildOptions to the invocation of cmd.
Fixes #23845
- - - - -
89073cde by Matthew Pickering at 2023-08-23T09:13:27-04:00
Abstract windows toolchain setup
This commit splits up the windows toolchain setup logic into two
functions.
* FP_INSTALL_WINDOWS_TOOLCHAIN - deals with downloading the toolchain if
it isn't already downloaded
* FP_SETUP_WINDOWS_TOOLCHAIN - sets the environment variables to point
to the correct place
FP_SETUP_WINDOWS_TOOLCHAIN is abstracted from the location of the mingw
toolchain and also the eventual location where we will install the
toolchain in the installed bindist.
This is the first step towards #23608
- - - - -
883c2a9f by Matthew Pickering at 2023-08-23T09:13:27-04:00
Generate build.mk for bindists
The config.mk.in script was relying on some variables which were
supposed to be set by build.mk but therefore never were when used to
install a bindist.
Specifically
* BUILD_PROF_LIBS to determine whether we had profiled libraries or not
* DYNAMIC_GHC_PROGRAMS to determine whether we had shared libraries or
not
Not only were these never set but also not really accurate because you
could have shared libaries but still statically linked ghc executable.
In addition variables like GhcLibWays were just never used, so those
have been deleted from the script.
Now instead we generate a build.mk file which just directly specifies
which RtsWays we have supplied in the bindist and whether we have
DYNAMIC_GHC_PROGRAMS.
- - - - -
a819aa06 by Matthew Pickering at 2023-08-23T09:13:27-04:00
hadrian: Add reloc-binary-dist-* targets
This adds a command line option to build a "relocatable" bindist.
The bindist is created by first creating a normal bindist and then
installing it using the `RelocatableBuild=YES` option. This creates a
bindist without any wrapper scripts pointing to the libdir.
The motivation for this feature is that we want to ship relocatable
bindists on windows and this method is more uniform than the ad-hoc
method which lead to bugs such as #23608 and #23476
The relocatable bindist can be built with the "reloc-binary-dist" target
and supports the same suffixes as the normal "binary-dist" command to
specify the compression style.
- - - - -
a75d8ffe by Matthew Pickering at 2023-08-23T09:13:27-04:00
packaging: Fix installation scripts on windows/RelocatableBuild case
This includes quite a lot of small fixes which fix the installation
makefile to work on windows properly. This also required fixing the
RelocatableBuild variable which seemed to have been broken for a long
while.
Sam helped me a lot writing this patch by providing a windows machine to
test the changes. Without him it would have taken ages to tweak
everything.
Co-authored-by: sheaf <sam.derbyshire at gmail.com>
- - - - -
8717cb44 by Matthew Pickering at 2023-08-23T09:13:27-04:00
ci: Build relocatable bindist on windows
We now build the relocatable bindist target on windows, which means we
test and distribute the new method of creating a relocatable bindist.
- - - - -
cb0333c2 by Matthew Pickering at 2023-08-23T09:13:27-04:00
hadrian: Add error when trying to build binary-dist target on windows
The binary dist produced by `binary-dist` target doesn't work on windows
because of the wrapper script the makefile installs. In order to not
surprise any packagers we just give an error if someone tries to build
the old binary-dist target rather than the reloc-binary-dist target.
- - - - -
3b48b86b by Matthew Pickering at 2023-08-23T09:13:27-04:00
hadrian: Remove query' logic to use tooldir
- - - - -
60047dc1 by Matthew Pickering at 2023-08-23T09:13:27-04:00
configure: Set WindresCmd directly and removed unused variables
For some reason there was an indirection via the Windres variable before
setting WindresCmd. That indirection led to #23855.
I then also noticed that these other variables were just not used
anywhere when trying to work out what the correct condition was for this
bit of the configure script.
- - - - -
fa7273ff by sheaf at 2023-08-23T09:13:27-04:00
Apply shellcheck suggestion to SUBST_TOOLDIR
- - - - -
8602ee3a by sheaf at 2023-08-23T09:13:30-04:00
Compute hints from TcSolverReportMsg
This commit changes how hints are handled in conjunction with
constraint solver report messages.
Instead of storing `[GhcHint]` in the TcRnSolverReport error constructor,
we compute the hints depending on the underlying TcSolverReportMsg.
This disentangles the logic and makes it easier to add new hints for
certain errors.
- - - - -
1ffd2354 by Alexander Esgen at 2023-08-23T09:13:35-04:00
users-guide: remove note about fatal Haddock parse failures
- - - - -
21 changed files:
- .gitlab/ci.sh
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- configure.ac
- distrib/configure.ac.in
- docs/users_guide/using.rst
- hadrian/README.md
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/src/Builder.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/Generate.hs
- m4/fp_settings.m4
- m4/fp_setup_windows_toolchain.m4
- + testsuite/tests/patsyn/should_fail/T23467.hs
- + testsuite/tests/patsyn/should_fail/T23467.stderr
- testsuite/tests/patsyn/should_fail/all.T
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -490,8 +490,16 @@ function build_hadrian() {
if [[ -n "${REINSTALL_GHC:-}" ]]; then
run_hadrian build-cabal -V
else
- run_hadrian test:all_deps binary-dist -V
- mv _build/bindist/ghc*.tar.xz "$BIN_DIST_NAME.tar.xz"
+ case "$(uname)" in
+ MSYS_*|MINGW*)
+ run_hadrian test:all_deps reloc-binary-dist -V
+ mv _build/reloc-bindist/ghc*.tar.xz "$BIN_DIST_NAME.tar.xz"
+ ;;
+ *)
+ run_hadrian test:all_deps binary-dist -V
+ mv _build/bindist/ghc*.tar.xz "$BIN_DIST_NAME.tar.xz"
+ ;;
+ esac
fi
}
=====================================
compiler/GHC/StgToCmm/InfoTableProv.hs
=====================================
@@ -6,6 +6,7 @@ import Foreign
#if defined(HAVE_LIBZSTD)
import Foreign.C.Types
+import Foreign.Marshal.Utils (copyBytes)
import qualified Data.ByteString.Internal as BSI
import GHC.IO (unsafePerformIO)
#endif
@@ -274,7 +275,7 @@ compress clvl (BSI.PS srcForeignPtr off len) = unsafePerformIO $
(srcPtr `plusPtr` off)
(fromIntegral len)
(fromIntegral clvl)
- BSI.create compressedSize $ \p -> BSI.memcpy p dstPtr compressedSize
+ BSI.create compressedSize $ \p -> copyBytes p dstPtr compressedSize
foreign import ccall unsafe "ZSTD_compress"
zstd_compress ::
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -13,7 +13,7 @@ module GHC.Tc.Errors(
warnDefaulting,
-- * GHC API helper functions
- solverReportMsg_ExpectedActuals,
+ solverReportMsg_ExpectedActuals, mismatchMsg_ExpectedActuals
) where
import GHC.Prelude
@@ -262,17 +262,12 @@ report_unsolved type_errors expr_holes
important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport
important ctxt doc
= SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc
- , sr_supplementary = []
- , sr_hints = [] }
+ , sr_supplementary = [] }
add_relevant_bindings :: RelevantBindings -> SolverReport -> SolverReport
add_relevant_bindings binds report@(SolverReport { sr_supplementary = supp })
= report { sr_supplementary = SupplementaryBindings binds : supp }
-add_report_hints :: [GhcHint] -> SolverReport -> SolverReport
-add_report_hints hints report@(SolverReport { sr_hints = prev_hints })
- = report { sr_hints = prev_hints ++ hints }
-
-- | Returns True <=> the SolverReportErrCtxt indicates that something is deferred
deferringAnyBindings :: SolverReportErrCtxt -> Bool
-- Don't check cec_type_holes, as these don't cause bindings to be deferred
@@ -434,7 +429,7 @@ reportBadTelescope :: SolverReportErrCtxt -> CtLocEnv -> SkolemInfoAnon -> [TcTy
reportBadTelescope ctxt env (ForAllSkol telescope) skols
= do { msg <- mkErrorReport
env
- (TcRnSolverReport report ErrorWithoutFlag noHints)
+ (TcRnSolverReport report ErrorWithoutFlag)
(Just ctxt)
[]
; reportDiagnostic msg }
@@ -1031,7 +1026,7 @@ reportNotConcreteErrs ctxt errs@(err0:_)
frr_origins = acc_errors errs
diag = TcRnSolverReport
(SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins))
- ErrorWithoutFlag noHints
+ ErrorWithoutFlag
-- Accumulate the different kind of errors arising from syntactic equality.
-- (Only SynEq_FRR origin for the moment.)
@@ -1090,9 +1085,7 @@ mkGivenErrorReporter ctxt (item:|_)
-- For given constraints we overwrite the env (and hence src-loc)
-- with one from the immediately-enclosing implication.
-- See Note [Inaccessible code]
-
- ; (eq_err_msg, _hints) <- mkEqErr_help ctxt item' ty1 ty2
- -- The hints wouldn't help in this situation, so we discard them.
+ ; eq_err_msg <- mkEqErr_help ctxt item' ty1 ty2
; let supplementary = [ SupplementaryBindings relevant_binds ]
msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg)
; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary
@@ -1191,8 +1184,7 @@ maybeReportError :: SolverReportErrCtxt
-> NonEmpty ErrorItem -- items covered by the Report
-> SolverReport -> TcM ()
maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important
- , sr_supplementary = supp
- , sr_hints = hints })
+ , sr_supplementary = supp })
= unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic
|| all ei_suppress items) $
-- if they're all to be suppressed, report nothing
@@ -1202,7 +1194,7 @@ maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = import
do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag
| otherwise = cec_defer_type_errors ctxt
-- See Note [No deferring for multiplicity errors]
- diag = TcRnSolverReport important reason hints
+ diag = TcRnSolverReport important reason
msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp
reportDiagnostic msg
@@ -1230,7 +1222,7 @@ mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type -- of the error term
mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msg = important, sr_supplementary = supp })
= do { msg <- mkErrorReport
(ctLocEnv ct_loc)
- (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp
+ (TcRnSolverReport important ErrorWithoutFlag) (Just ctxt) supp
-- This will be reported at runtime, so we always want "error:" in the report, never "warning:"
; dflags <- getDynFlags
; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg
@@ -1417,7 +1409,6 @@ mkIrredErr ctxt items
{- Note [Constructing Hole Errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
Whether or not 'mkHoleError' returns an error is not influenced by cec_suppress. In other terms,
these "hole" errors are /not/ suppressed by cec_suppress. We want to see them!
@@ -1457,11 +1448,14 @@ mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc
= do { (imp_errs, hints)
<- unknownNameSuggestions (ctl_rdr lcl_env) WL_Anything occ
; let
- err = SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)
- report = SolverReport err [] hints
+ err = SolverReportWithCtxt ctxt
+ $ ReportHoleError hole
+ $ OutOfScopeHole imp_errs hints
+ report = SolverReport err []
; maybeAddDeferredBindings ctxt hole report
- ; mkErrorReport lcl_env (TcRnSolverReport err (cec_out_of_scope_holes ctxt) hints) Nothing []
+ ; mkErrorReport lcl_env (TcRnSolverReport err (cec_out_of_scope_holes ctxt))
+ Nothing []
-- Pass the value 'Nothing' for the context, as it's generally not helpful
-- to include the context here.
}
@@ -1491,14 +1485,16 @@ mkHoleError lcl_name_cache tidy_simples ctxt
; (grouped_skvs, other_tvs) <- liftZonkM $ zonkAndGroupSkolTvs hole_ty
; let reason | ExprHole _ <- sort = cec_expr_holes ctxt
| otherwise = cec_type_holes ctxt
- err = SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs
+ err = SolverReportWithCtxt ctxt
+ $ ReportHoleError hole
+ $ HoleError sort other_tvs grouped_skvs
supp = [ SupplementaryBindings rel_binds
, SupplementaryCts relevant_cts
, SupplementaryHoleFits hole_fits ]
- ; maybeAddDeferredBindings ctxt hole (SolverReport err supp [])
+ ; maybeAddDeferredBindings ctxt hole (SolverReport err supp)
- ; mkErrorReport lcl_env (TcRnSolverReport err reason noHints) (Just ctxt) supp
+ ; mkErrorReport lcl_env (TcRnSolverReport err reason) (Just ctxt) supp
}
where
@@ -1527,12 +1523,10 @@ zonkAndGroupSkolTvs hole_ty = do
{- Note [Adding deferred bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
When working with typed holes we have to deal with the case where
we want holes to be reported as warnings to users during compile time but
as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings'
so that the correct 'Severity' can be computed out of that later on.
-
-}
@@ -1708,10 +1702,9 @@ mkEqErr1 ctxt item -- Wanted only
-- givens handled in mkGivenErrorReporter
= do { (ctxt, binds, item) <- relevantBindings True ctxt item
; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item))
- ; (err_msg, hints) <- mkEqErr_help ctxt item ty1 ty2
+ ; err_msg <- mkEqErr_help ctxt item ty1 ty2
; let
report = add_relevant_bindings binds
- $ add_report_hints hints
$ important ctxt err_msg
; return report }
where
@@ -1760,7 +1753,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
mkEqErr_help :: SolverReportErrCtxt
-> ErrorItem
- -> TcType -> TcType -> TcM (TcSolverReportMsg, [GhcHint])
+ -> TcType -> TcType -> TcM TcSolverReportMsg
mkEqErr_help ctxt item ty1 ty2
| Just casted_tv1 <- getCastedTyVar_maybe ty1
= mkTyVarEqErr ctxt item casted_tv1 ty2
@@ -1770,8 +1763,7 @@ mkEqErr_help ctxt item ty1 ty2
= mkTyVarEqErr ctxt item casted_tv2 ty1
| otherwise
- = do { err <- reportEqErr ctxt item ty1 ty2
- ; return (err, noHints) }
+ = reportEqErr ctxt item ty1 ty2
reportEqErr :: SolverReportErrCtxt
-> ErrorItem
@@ -1801,14 +1793,14 @@ coercible_msg ty1 ty2
return $ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem
- -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint])
+ -> (TcTyVar, TcCoercionN) -> TcType -> TcM TcSolverReportMsg
-- tv1 and ty2 are already tidied
mkTyVarEqErr ctxt item casted_tv1 ty2
= do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2)
; mkTyVarEqErr' ctxt item casted_tv1 ty2 }
mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem
- -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint])
+ -> (TcTyVar, TcCoercionN) -> TcType -> TcM TcSolverReportMsg
mkTyVarEqErr' ctxt item (tv1, co1) ty2
-- Is this a representation-polymorphism error, e.g.
@@ -1816,7 +1808,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
| Just frr_info <- mb_concrete_reason
= do
(_, infos) <- liftZonkM $ zonkTidyFRRInfos (cec_tidy ctxt) [frr_info]
- return (FixedRuntimeRepError infos, [])
+ return $ FixedRuntimeRepError infos
-- Impredicativity is a simple error to understand;
-- try it before anything more complicated.
@@ -1837,13 +1829,13 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
-- Unlike the other reports, this discards the old 'report_important'
-- instead of augmenting it. This is because the details are not likely
-- to be helpful since this is just an unimplemented feature.
- return (main_msg, [])
+ return main_msg
-- Incompatible kinds
-- This is wrinkle (EIK2) in Note [Equalities with incompatible kinds]
-- in GHC.Tc.Solver.Equality
| hasCoercionHoleCo co1 || hasCoercionHoleTy ty2
- = return (mkBlockedEqErr item, [])
+ = return $ mkBlockedEqErr item
| isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have
-- swapped in Solver.Equality.canEqTyVarHomo
@@ -1858,7 +1850,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
let main_msg = CannotUnifyVariable
{ mismatchMsg = headline_msg
, cannotUnifyReason = reason }
- return (main_msg, add_sig)
+ return main_msg
| tv1 `elemVarSet` tyCoVarsOfType ty2
-- We report an "occurs check" even for a ~ F t a, where F is a type
@@ -1883,7 +1875,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
{ mismatchMsg = headline_msg
, cannotUnifyReason = occurs_err }
- in return (main_msg, [])
+ in return main_msg
-- If the immediately-enclosing implication has 'tv' a skolem, and
-- we know by now its an InferSkol kind of skolem, then presumably
@@ -1899,7 +1891,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
, mismatchTyVarInfo = Just tv_extra
, mismatchAmbiguityInfo = []
, mismatchCoercibleInfo = Nothing }
- return (msg, [])
+ return msg
-- Check for skolem escape
| (implic:_) <- cec_encl ctxt -- Get the innermost context
@@ -1911,7 +1903,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
{ mismatchMsg = mismatch_msg
, cannotUnifyReason = SkolemEscape item implic esc_skols }
- in return (main_msg, [])
+ in return main_msg
-- Nastiest case: attempt to unify an untouchable variable
-- So tv is a meta tyvar (or started that way before we
@@ -1929,18 +1921,16 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2
, mismatchTyVarInfo = Just tv_extra'
, mismatchAmbiguityInfo = []
, mismatchCoercibleInfo = Nothing }
- return (msg, add_sig)
+ return msg
| otherwise
- = do { err <- reportEqErr ctxt item (mkTyVarTy tv1) ty2
- ; return (err, []) }
+ = reportEqErr ctxt item (mkTyVarTy tv1) ty2
-- This *can* happen (#6123)
-- Consider an ambiguous top-level constraint (a ~ F a)
-- Not an occurs check, because F is a type function.
where
headline_msg = misMatchOrCND ctxt item ty1 ty2
mismatch_msg = mkMismatchMsg item ty1 ty2
- add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2
-- The following doesn't use the cterHasProblem mechanism because
-- we need to retrieve the ConcreteTvOrigin. Just knowing whether
@@ -2098,32 +2088,6 @@ extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $
return $ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps)
_ -> return tv
-
-suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint
--- See Note [Suggest adding a type signature]
-suggestAddSig ctxt ty1 _ty2
- | bndr : bndrs <- inferred_bndrs
- = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)
- | otherwise
- = Nothing
- where
- inferred_bndrs =
- case getTyVar_maybe ty1 of
- Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv
- _ -> []
-
- -- 'find' returns the binders of an InferSkol for 'tv',
- -- provided there is an intervening implication with
- -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)
- find [] _ _ = []
- find (implic:implics) seen_eqs tv
- | tv `elem` ic_skols implic
- , InferSkol prs <- ic_info implic
- , seen_eqs
- = map fst prs
- | otherwise
- = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv
-
--------------------
mkMismatchMsg :: ErrorItem -> Type -> Type -> MismatchMsg
mkMismatchMsg item ty1 ty2 =
@@ -2212,33 +2176,7 @@ sameOccExtras ty1 ty2
| otherwise
= Nothing
-{- Note [Suggest adding a type signature]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The OutsideIn algorithm rejects GADT programs that don't have a principal
-type, and indeed some that do. Example:
- data T a where
- MkT :: Int -> T Int
-
- f (MkT n) = n
-
-Does this have type f :: T a -> a, or f :: T a -> Int?
-The error that shows up tends to be an attempt to unify an
-untouchable type variable. So suggestAddSig sees if the offending
-type variable is bound by an *inferred* signature, and suggests
-adding a declared signature instead.
-
-More specifically, we suggest adding a type sig if we have p ~ ty, and
-p is a skolem bound by an InferSkol. Those skolems were created from
-unification variables in simplifyInfer. Why didn't we unify? It must
-have been because of an intervening GADT or existential, making it
-untouchable. Either way, a type signature would help. For GADTs, it
-might make it typeable; for existentials the attempt to write a
-signature will fail -- or at least will produce a better error message
-next time
-
-This initially came up in #8968, concerning pattern synonyms.
-
-Note [Disambiguating (X ~ X) errors]
+{- Note [Disambiguating (X ~ X) errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #8278
@@ -2648,20 +2586,12 @@ are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.
-- Prefer using this over manually inspecting the 'TcSolverReportMsg' datatype
-- if you just want this information, as the datatype itself is subject to change
-- across GHC versions.
-solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)]
+solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> Maybe (Type, Type)
solverReportMsg_ExpectedActuals
= \case
Mismatch { mismatchMsg = mismatch_msg } ->
- case mismatch_msg of
- BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->
- [(exp, act)]
- KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->
- [(exp, act)]
- TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->
- [(exp,act)]
- CouldNotDeduce {} ->
- []
- _ -> []
+ mismatchMsg_ExpectedActuals mismatch_msg
+ _ -> Nothing
-- | Filter the list by the given predicate, but if that would be empty,
-- just give back the original list.
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
@@ -23,6 +24,9 @@ module GHC.Tc.Errors.Ppr
, pprTyThingUsedWrong
, pprUntouchableVariable
+ --
+ , mismatchMsg_ExpectedActuals
+
-- | Useful when overriding message printing.
, messageWithInfoDiagnosticMessage
, messageWithHsDocContext
@@ -141,7 +145,7 @@ instance Diagnostic TcRnMessage where
(diagnosticMessage opts msg)
TcRnWithHsDocContext ctxt msg
-> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg)
- TcRnSolverReport msg _ _
+ TcRnSolverReport msg _
-> mkSimpleDecorated $ pprSolverReportWithCtxt msg
TcRnSolverDepthError ty depth -> mkSimpleDecorated msg
where
@@ -1862,7 +1866,7 @@ instance Diagnostic TcRnMessage where
TcRnMessageDetailed _ m -> diagnosticReason m
TcRnWithHsDocContext _ msg
-> diagnosticReason msg
- TcRnSolverReport _ reason _
+ TcRnSolverReport _ reason
-> reason -- Error, or a Warning if we are deferring type errors
TcRnSolverDepthError {}
-> ErrorWithoutFlag
@@ -2467,8 +2471,8 @@ instance Diagnostic TcRnMessage where
TcRnMessageDetailed _ m -> diagnosticHints m
TcRnWithHsDocContext _ msg
-> diagnosticHints msg
- TcRnSolverReport _ _ hints
- -> hints
+ TcRnSolverReport (SolverReportWithCtxt ctxt msg) _
+ -> tcSolverReportMsgHints ctxt msg
TcRnSolverDepthError {}
-> [SuggestIncreaseReductionDepth]
TcRnRedundantConstraints{}
@@ -4490,7 +4494,7 @@ pprSameOccInfo (SameOcc same_pkg n1 n2) =
**********************************************************************-}
pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc
-pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) (OutOfScopeHole imp_errs)
+pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) (OutOfScopeHole imp_errs _hints)
= out_of_scope_msg $$ vcat (map ppr imp_errs)
where
herald | isDataOcc (rdrNameOcc rdr) = text "Data constructor not in scope:"
@@ -4614,6 +4618,128 @@ scopeErrorHints scope_err =
UnknownSubordinate {} -> noHints
NotInScopeTc _ -> noHints
+tcSolverReportMsgHints :: SolverReportErrCtxt -> TcSolverReportMsg -> [GhcHint]
+tcSolverReportMsgHints ctxt = \case
+ BadTelescope {}
+ -> noHints
+ UserTypeError {}
+ -> noHints
+ UnsatisfiableError {}
+ -> noHints
+ ReportHoleError hole err
+ -> holeErrorHints hole err
+ CannotUnifyVariable mismatch_msg rea
+ -> mismatchMsgHints ctxt mismatch_msg ++ cannotUnifyVariableHints rea
+ Mismatch { mismatchMsg = mismatch_msg }
+ -> mismatchMsgHints ctxt mismatch_msg
+ FixedRuntimeRepError {}
+ -> noHints
+ BlockedEquality {}
+ -> noHints
+ ExpectingMoreArguments {}
+ -> noHints
+ UnboundImplicitParams {}
+ -> noHints
+ AmbiguityPreventsSolvingCt {}
+ -> noHints
+ CannotResolveInstance {}
+ -> noHints
+ OverlappingInstances {}
+ -> noHints
+ UnsafeOverlap {}
+ -> noHints
+
+mismatchMsgHints :: SolverReportErrCtxt -> MismatchMsg -> [GhcHint]
+mismatchMsgHints ctxt msg =
+ maybeToList [ hint | (exp,act) <- mismatchMsg_ExpectedActuals msg
+ , hint <- suggestAddSig ctxt exp act ]
+
+mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type)
+mismatchMsg_ExpectedActuals = \case
+ BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->
+ Just (exp, act)
+ KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->
+ Just (exp, act)
+ TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->
+ Just (exp,act)
+ CouldNotDeduce { cnd_extra = cnd_extra }
+ | Just (CND_Extra _ exp act) <- cnd_extra
+ -> Just (exp, act)
+ | otherwise
+ -> Nothing
+
+holeErrorHints :: Hole -> HoleError -> [GhcHint]
+holeErrorHints _hole = \case
+ OutOfScopeHole _ hints
+ -> hints
+ HoleError {}
+ -> noHints
+
+cannotUnifyVariableHints :: CannotUnifyVariableReason -> [GhcHint]
+cannotUnifyVariableHints = \case
+ CannotUnifyWithPolytype {}
+ -> noHints
+ OccursCheck {}
+ -> noHints
+ SkolemEscape {}
+ -> noHints
+ DifferentTyVars {}
+ -> noHints
+ RepresentationalEq {}
+ -> noHints
+
+suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint
+-- See Note [Suggest adding a type signature]
+suggestAddSig ctxt ty1 _ty2
+ | bndr : bndrs <- inferred_bndrs
+ = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)
+ | otherwise
+ = Nothing
+ where
+ inferred_bndrs =
+ case getTyVar_maybe ty1 of
+ Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv
+ _ -> []
+
+ -- 'find' returns the binders of an InferSkol for 'tv',
+ -- provided there is an intervening implication with
+ -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)
+ find [] _ _ = []
+ find (implic:implics) seen_eqs tv
+ | tv `elem` ic_skols implic
+ , InferSkol prs <- ic_info implic
+ , seen_eqs
+ = map fst prs
+ | otherwise
+ = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv
+
+{- Note [Suggest adding a type signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The OutsideIn algorithm rejects GADT programs that don't have a principal
+type, and indeed some that do. Example:
+ data T a where
+ MkT :: Int -> T Int
+
+ f (MkT n) = n
+
+Does this have type f :: T a -> a, or f :: T a -> Int?
+The error that shows up tends to be an attempt to unify an
+untouchable type variable. So suggestAddSig sees if the offending
+type variable is bound by an *inferred* signature, and suggests
+adding a declared signature instead.
+
+More specifically, we suggest adding a type sig if we have p ~ ty, and
+p is a skolem bound by an InferSkol. Those skolems were created from
+unification variables in simplifyInfer. Why didn't we unify? It must
+have been because of an intervening GADT or existential, making it
+untouchable. Either way, a type signature would help. For GADTs, it
+might make it typeable; for existentials the attempt to write a
+signature will fail -- or at least will produce a better error message
+next time
+
+This initially came up in #8968, concerning pattern synonyms.
+-}
+
{- *********************************************************************
* *
Outputting ImportError messages
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -329,11 +329,7 @@ data TcRnMessage where
-}
TcRnSolverReport :: SolverReportWithCtxt
-> DiagnosticReason
- -> [GhcHint]
-> TcRnMessage
- -- TODO: split up TcRnSolverReport into several components,
- -- so that we can compute the reason and hints, as opposed
- -- to having to pass them here.
{-| TcRnSolverDepthError is an error that occurs when the constraint solver
exceeds the maximum recursion depth.
@@ -4983,7 +4979,6 @@ data SolverReport
= SolverReport
{ sr_important_msg :: SolverReportWithCtxt
, sr_supplementary :: [SolverReportSupplementary]
- , sr_hints :: [GhcHint]
}
-- | Additional information to print in a 'SolverReport', after the
@@ -5541,7 +5536,7 @@ data HoleError
-- See 'NotInScopeError' for other not-in-scope errors.
--
-- Test cases: T9177a.
- = OutOfScopeHole [ImportError]
+ = OutOfScopeHole [ImportError] [GhcHint]
-- | Report a typed hole, or wildcard, with additional information.
| HoleError HoleSort
[TcTyVar] -- Other type variables which get computed on the way.
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isMan
import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
import GHC.Core.Predicate
-import GHC.Builtin.Types.Prim
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
@@ -86,36 +85,12 @@ tcPatSynDecl (L loc psb@(PSB { psb_id = L _ name })) sig_fn prag_fn
= setSrcSpanA loc $
addErrCtxt (text "In the declaration for pattern synonym"
<+> quotes (ppr name)) $
- recoverM (recoverPSB psb) $
- case (sig_fn name) of
+ -- See Note [Pattern synonym error recovery]
+ case sig_fn name of
Nothing -> tcInferPatSynDecl psb prag_fn
Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn
_ -> panic "tcPatSynDecl"
-recoverPSB :: PatSynBind GhcRn GhcRn
- -> TcM (LHsBinds GhcTc, TcGblEnv)
--- See Note [Pattern synonym error recovery]
-recoverPSB (PSB { psb_id = L _ name
- , psb_args = details })
- = do { matcher_name <- newImplicitBinder name mkMatcherOcc
- ; let placeholder = AConLike $ PatSynCon $
- mk_placeholder matcher_name
- ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
- ; return (emptyBag, gbl_env) }
- where
- (_arg_names, is_infix) = collectPatSynArgInfo details
- mk_placeholder matcher_name
- = mkPatSyn name is_infix
- ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], [])
- [] -- Arg tys
- alphaTy
- (matcher_name, matcher_ty, True) Nothing
- [] -- Field labels
- where
- -- The matcher_id is used only by the desugarer, so actually
- -- and error-thunk would probably do just as well here.
- matcher_ty = mkSpecForAllTys [alphaTyVar] alphaTy
-
{- Note [Pattern synonym error recovery]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If type inference for a pattern synonym fails, we can't continue with
@@ -134,14 +109,19 @@ reporting no end (#15685).
So we use simplifyTop to completely solve the constraint, report
any errors, throw an exception.
-Even in the event of such an error we can recover and carry on, just
-as we do for value bindings, provided we plug in placeholder for the
-pattern synonym: see recoverPSB. The goal of the placeholder is not
-to cause a raft of follow-on errors. I've used the simplest thing for
-now, but we might need to elaborate it a bit later. (e.g. I've given
-it zero args, which may cause knock-on errors if it is used in a
-pattern.) But it'll do for now.
+Unlike for value bindings, we don't create a placeholder pattern
+synonym binding in an attempt to recover from the error, as this placeholder
+was occasionally the cause of strange follow-up errors to occur, as reported in #23467.
+It seems rather difficult to come up with a satisfactory placeholder:
+
+ - it would need to have the right number of arguments,
+ with the appropriate field names (if any),
+ - we could give each argument the type `forall a. a`; this would generally
+ work OK in pattern occurrences of the PatSyn, but not so in expressions,
+ e.g. "let x = Con y" would require (y :: forall a. a) which would cause
+ confusing errors.
+So, for now at least, we don't attempt to recover at all.
-}
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
=====================================
configure.ac
=====================================
@@ -346,7 +346,8 @@ FP_FIND_ROOT
# Extract and configure the Windows toolchain
if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then
- FP_SETUP_WINDOWS_TOOLCHAIN
+ FP_INSTALL_WINDOWS_TOOLCHAIN
+ FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/inplace/mingw], [$hardtop/inplace/mingw])
else
AC_PATH_TOOL([CC],[gcc], [clang])
AC_PATH_TOOL([CXX],[g++], [clang++])
@@ -356,28 +357,19 @@ else
AC_PATH_TOOL([AR],[ar])
AC_PATH_TOOL([RANLIB],[ranlib])
AC_PATH_TOOL([OBJDUMP],[objdump])
- AC_PATH_TOOL([Windres],[windres])
+ AC_PATH_TOOL([WindresCmd],[windres])
AC_PATH_TOOL([Genlib],[genlib])
- HAVE_GENLIB=False
if test "$HostOS" = "mingw32"; then
- AC_CHECK_TARGET_TOOL([Windres],[windres])
+ AC_CHECK_TARGET_TOOL([WindresCmd],[windres])
AC_CHECK_TARGET_TOOL([OBJDUMP],[objdump])
if test "$Genlib" != ""; then
GenlibCmd="$(cygpath -m $Genlib)"
- HAVE_GENLIB=True
fi
fi
fi
-if test "$HostOS" = "mingw32"; then
- WindresCmd="$Windres"
- AC_SUBST([WindresCmd])
- AC_SUBST([GenlibCmd])
- AC_SUBST([HAVE_GENLIB])
-fi
-
FP_ICONV
FP_GMP
FP_CURSES
=====================================
distrib/configure.ac.in
=====================================
@@ -103,6 +103,10 @@ AC_ARG_ENABLE(distro-toolchain,
[EnableDistroToolchain=@SettingsUseDistroMINGW@]
)
+if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then
+ FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$\$topdir/../mingw/])
+fi
+
dnl ** Which gcc to use?
dnl --------------------------------------------------------------
AC_PROG_CC([gcc clang])
@@ -288,6 +292,7 @@ if test "x$UseLibdw" = "xYES" ; then
fi
AC_SUBST(UseLibdw)
+
FP_SETTINGS
AC_CONFIG_FILES([config.mk])
=====================================
docs/users_guide/using.rst
=====================================
@@ -1765,8 +1765,8 @@ Haddock
top-level type-signature. With this flag GHC will parse Haddock comments
and include them in the interface file it produces.
- Note that this flag makes GHC's parser more strict so programs which are
- accepted without Haddock may be rejected with :ghc-flag:`-haddock`.
+ Consider using :ghc-flag:`-Winvalid-haddock` to be informed about discarded
+ documentation comments.
Miscellaneous flags
-------------------
=====================================
hadrian/README.md
=====================================
@@ -325,6 +325,13 @@ $ ./configure [--prefix=PATH] && make install
workflow, for now.
+Note: On windows you need to use the `reloc-binary-dist` target.
+
+#### Relocatable Binary Distribution
+
+If you require a relocatable binary distribution (for example on Windows), then you
+can build the `reloc-binary-dist` target.
+
### Building and installing GHC
You can get Hadrian to build _and_ install a binary distribution in one go
=====================================
hadrian/bindist/Makefile
=====================================
@@ -62,20 +62,29 @@ show:
.PHONY: install
-ifeq "$(TargetOS_CPP)" "mingw32"
-install_bin: install_mingw install_bin_direct
+ifeq "$(EnableDistroToolchain)" "NO"
+install_extra: install_mingw
+else
+install_extra:
+endif
+
+ifeq "$(RelocatableBuild)" "YES"
+install_bin: install_bin_direct
else
install_bin: install_bin_libdir install_wrappers
endif
-install: install_bin install_lib
+
+
+install: install_bin install_lib install_extra
install: install_man install_docs update_package_db
-ActualBinsDir=${ghclibdir}/bin
ifeq "$(RelocatableBuild)" "YES"
ActualLibsDir=${ghclibdir}
+ActualBinsDir=${bindir}
else
ActualLibsDir=${ghclibdir}/lib
+ActualBinsDir=${ghclibdir}/bin
endif
WrapperBinsDir=${bindir}
=====================================
hadrian/bindist/config.mk.in
=====================================
@@ -27,6 +27,10 @@
# string "${docdir}", not the value of docdir! This is crucial for the GNU
# coding standards. See #1924.
+# The build.mk contains information about the bindist such as whether there are
+# profiled libraries.
+include build.mk
+
define set_default
# $1 = variable to set
# $2 = default value to use, if configure didn't expand it
@@ -63,6 +67,13 @@ $(eval $(call set_default,dvidir,$${docdir}))
$(eval $(call set_default,pdfdir,$${docdir}))
$(eval $(call set_default,psdir,$${docdir}))
+# On Windows we can only make a relocatable bindist because the normal install
+# script creates wrapper scripts which do not work on windows. Therefore we force
+# RelocatableBuild = YES here until/if that is ever fixed.
+ifeq "$(Windows_Host)" "YES"
+RelocatableBuild = YES
+endif
+
ifeq "$(RelocatableBuild)" "YES"
# Hack: our directory layouts tend to be different on Windows, so
@@ -149,72 +160,12 @@ else
GhcWithInterpreter=$(if $(findstring YES,$(DYNAMIC_GHC_PROGRAMS)),YES,NO)
endif
-# On Windows we normally want to make a relocatable bindist, to we
-# ignore flags like libdir
-ifeq "$(Windows_Host)" "YES"
-RelocatableBuild = YES
-else
-RelocatableBuild = NO
-endif
-# runhaskell and hsc2hs are special, in that other compilers besides
-# GHC might provide them. Systems with a package manager often come
-# with tools to manage this kind of clash, e.g. RPM's
-# update-alternatives. When building a distribution for such a system,
-# we recommend setting both of the following to 'YES'.
-#
-# NO_INSTALL_RUNHASKELL = YES
-# NO_INSTALL_HSC2HS = YES
-#
-# NB. we use negative tests here because for binary-distributions we cannot
-# test build-time variables at install-time, so they must default to on.
-
ifneq "$(DESTDIR)" ""
override DESTDIR := $(abspath $(DESTDIR))
endif
-# We build the libraries at least the "vanilla" way (way "v")
-# Technically we don't need the v way if DYNAMIC_GHC_PROGRAMS is YES,
-# but with -dynamic-too it's cheap, and makes life easier.
-GhcLibWays = v
-
-# In addition to the normal sequential way, the default is to also build
-# profiled prelude libraries
-# $(if $(filter ...)) allows controlling this expression from build.mk.
-GhcLibWays += $(if $(filter $(BUILD_PROF_LIBS),NO),,p)
-
-# Backward compatibility: although it would be cleaner to test for
-# PlatformSupportsSharedLibs, or perhaps a new variable BUILD_SHARED_LIBS,
-# some users currently expect that DYNAMIC_GHC_PROGRAMS=NO in build.mk implies
-# that dyn is not added to GhcLibWays.
-GhcLibWays += $(if $(filter $(DYNAMIC_GHC_PROGRAMS),NO),,dyn)
-
-# Handy way to test whether we're building shared libs or not.
-BuildSharedLibs=$(strip $(if $(findstring dyn,$(GhcLibWays)),YES,NO))
-
-# In addition, the RTS is built in some further variations. Ways that
-# make sense here:
-#
-# thr : threaded
-# thr_p : threaded + profiled
-# debug : debugging
-# thr_debug : debugging + threaded
-# p : profiled
-#
-# While the eventlog used to be enabled in only a subset of ways, we now always
-# enable it.
-
-# Usually want the debug version
-GhcRTSWays = debug
-
-# We always have the threaded versions, but note that SMP support may be disabled
-# (see GhcWithSMP).
-GhcRTSWays += thr thr_debug
-GhcRTSWays += $(if $(findstring p, $(GhcLibWays)),thr_p,)
-GhcRTSWays += $(if $(findstring dyn, $(GhcLibWays)),dyn debug_dyn thr_dyn thr_debug_dyn,)
-GhcRTSWays += $(if $(findstring p, $(GhcLibWays)),thr_debug_p debug_p,)
-
# We can only build GHCi threaded if we have a threaded RTS:
GhcThreaded = $(if $(findstring thr,$(GhcRTSWays)),YES,NO)
=====================================
hadrian/src/Builder.hs
=====================================
@@ -313,20 +313,20 @@ instance H.Builder Builder where
msgOut = "[runBuilderWith] Exactly one output file expected."
-- Capture stdout and write it to the output file.
captureStdout = do
- Stdout stdout <- cmd' [path] buildArgs
+ Stdout stdout <- cmd' [path] buildArgs buildOptions
-- see Note [Capture stdout as a ByteString]
writeFileChangedBS output stdout
case builder of
Ar Pack stg -> do
useTempFile <- arSupportsAtFile stg
- if useTempFile then runAr path buildArgs buildInputs
- else runArWithoutTempFile path buildArgs buildInputs
+ if useTempFile then runAr path buildArgs buildInputs buildOptions
+ else runArWithoutTempFile path buildArgs buildInputs buildOptions
- Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs
+ Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions
Autoreconf dir -> do
bash <- bashPath
- cmd' [Cwd dir] [bash, path] buildArgs
+ cmd' [Cwd dir] [bash, path] buildArgs buildOptions
Configure dir -> do
-- Inject /bin/bash into `libtool`, instead of /bin/sh,
@@ -339,7 +339,7 @@ instance H.Builder Builder where
GenPrimopCode -> do
stdin <- readFile' input
- Stdout stdout <- cmd' (Stdin stdin) [path] buildArgs
+ Stdout stdout <- cmd' (Stdin stdin) [path] buildArgs buildOptions
-- see Note [Capture stdout as a ByteString]
writeFileChangedBS output stdout
@@ -350,47 +350,47 @@ instance H.Builder Builder where
, "describe"
, input -- the package name
]
- cmd' (Stdin pkgDesc) [path] (buildArgs ++ ["-"])
+ cmd' (Stdin pkgDesc) [path] (buildArgs ++ ["-"]) buildOptions
GhcPkg Unregister _ -> do
-- unregistering is allowed to fail (e.g. when a package
-- isn't already present)
- Exit _ <- cmd' [path] (buildArgs ++ [input])
+ Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions
return ()
Haddock BuildPackage -> runHaddock path buildArgs buildInputs
HsCpp -> captureStdout
- Make dir -> cmd' path ["-C", dir] buildArgs
+ Make dir -> cmd' buildOptions path ["-C", dir] buildArgs
Makeinfo -> do
- cmd' [path] "--no-split" [ "-o", output] [input]
+ cmd' [path] "--no-split" [ "-o", output] [input] buildOptions
Xelatex ->
-- xelatex produces an incredible amount of output, almost
-- all of which is useless. Suppress it unless user
-- requests a loud build.
if verbosity >= Diagnostic
- then cmd' [Cwd output] [path] buildArgs
- else do (Stdouterr out, Exit code) <- cmd' [Cwd output] [path] buildArgs
+ then cmd' [Cwd output] [path] buildArgs buildOptions
+ else do (Stdouterr out, Exit code) <- cmd' [Cwd output] [path] buildArgs buildOptions
when (code /= ExitSuccess) $ do
liftIO $ BSL.hPutStrLn stderr out
putFailure "xelatex failed!"
fail "xelatex failed"
- Makeindex -> unit $ cmd' [Cwd output] [path] (buildArgs ++ [input])
+ Makeindex -> unit $ cmd' [Cwd output] [path] (buildArgs ++ [input]) buildOptions
Tar _ -> cmd' buildOptions [path] buildArgs
-- RunTest produces a very large amount of (colorised) output;
-- Don't attempt to capture it.
Testsuite RunTest -> do
- Exit code <- cmd [path] buildArgs
+ Exit code <- cmd [path] buildArgs buildOptions
when (code /= ExitSuccess) $ do
fail "tests failed"
- _ -> cmd' [path] buildArgs
+ _ -> cmd' [path] buildArgs buildOptions
-- | Invoke @haddock@ given a path to it and a list of arguments. The arguments
-- are passed in a response file.
=====================================
hadrian/src/Hadrian/Builder/Ar.hs
=====================================
@@ -38,10 +38,11 @@ instance NFData ArMode
runAr :: FilePath -- ^ path to @ar@
-> [String] -- ^ other arguments
-> [FilePath] -- ^ input file paths
+ -> [CmdOption] -- ^ Additional options
-> Action ()
-runAr arPath flagArgs fileArgs = withTempFile $ \tmp -> do
+runAr arPath flagArgs fileArgs buildOptions = withTempFile $ \tmp -> do
writeFile' tmp $ unwords fileArgs
- cmd [arPath] flagArgs ('@' : tmp)
+ cmd [arPath] flagArgs ('@' : tmp) buildOptions
-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
-- will be called multiple times if the list of files to be archived is too
@@ -50,7 +51,8 @@ runAr arPath flagArgs fileArgs = withTempFile $ \tmp -> do
runArWithoutTempFile :: FilePath -- ^ path to @ar@
-> [String] -- ^ other arguments
-> [FilePath] -- ^ input file paths
+ -> [CmdOption] -- ^ Additional options
-> Action ()
-runArWithoutTempFile arPath flagArgs fileArgs =
+runArWithoutTempFile arPath flagArgs fileArgs buildOptions =
forM_ (chunksOfSize cmdLineLengthLimit fileArgs) $ \argsChunk ->
- unit . cmd [arPath] $ flagArgs ++ argsChunk
+ unit (cmd [arPath] (flagArgs ++ argsChunk) buildOptions)
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -17,6 +17,8 @@ import qualified System.Directory.Extra as IO
import Data.Either
import GHC.Toolchain (ccProgram, tgtCCompiler, ccLinkProgram, tgtCCompilerLink)
import GHC.Toolchain.Program (prgFlags)
+import qualified Data.Set as Set
+import Oracles.Flavour
{-
Note [Binary distributions]
@@ -108,20 +110,40 @@ other, the install script:
-}
+data Relocatable = Relocatable | NotRelocatable
+
+installTo :: Relocatable -> String -> Action ()
+installTo relocatable prefix = do
+ root <- buildRoot
+ version <- setting ProjectVersion
+ targetPlatform <- setting TargetPlatformFull
+ let ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform
+ bindistFilesDir = root -/- "bindist" -/- ghcVersionPretty
+ runBuilder (Configure bindistFilesDir) ["--prefix="++prefix] [] []
+ let env = case relocatable of
+ Relocatable -> [AddEnv "RelocatableBuild" "YES"]
+ NotRelocatable -> []
+ runBuilderWithCmdOptions env (Make bindistFilesDir) ["install"] [] []
+
bindistRules :: Rules ()
bindistRules = do
root <- buildRootRules
- phony "install" $ do
+ phony "reloc-binary-dist-dir" $ do
need ["binary-dist-dir"]
+ cwd <- liftIO $ IO.getCurrentDirectory
version <- setting ProjectVersion
targetPlatform <- setting TargetPlatformFull
let ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform
- bindistFilesDir = root -/- "bindist" -/- ghcVersionPretty
- prefixErr = "You must specify a path with --prefix when using the"
+ let prefix = cwd -/- root -/- "reloc-bindist" -/- ghcVersionPretty
+ installTo Relocatable prefix
+
+
+ phony "install" $ do
+ need ["binary-dist-dir"]
+ let prefixErr = "You must specify a path with --prefix when using the"
++ " 'install' rule"
installPrefix <- fromMaybe (error prefixErr) <$> cmdPrefix
- runBuilder (Configure bindistFilesDir) ["--prefix="++installPrefix] [] []
- runBuilder (Make bindistFilesDir) ["install"] [] []
+ installTo NotRelocatable installPrefix
phony "binary-dist-dir" $ do
-- We 'need' all binaries and libraries
@@ -207,16 +229,6 @@ bindistRules = do
cmd_ (bindistFilesDir -/- "bin" -/- ghcPkgName) ["recache"]
- -- The settings file must be regenerated by the bindist installation
- -- logic to account for the environment discovered by the bindist
- -- configure script on the host. Not on Windows, however, where
- -- we do not ship a configure script with the bindist. See #20254.
- --
- -- N.B. we must do this after ghc-pkg has been run as it will go
- -- looking for the settings files.
- unless windowsHost $
- removeFile (bindistFilesDir -/- "lib" -/- "settings")
-
unless cross $ need ["docs"]
-- TODO: we should only embed the docs that have been generated
@@ -250,41 +262,43 @@ bindistRules = do
whenM (liftIO (IO.doesDirectoryExist (root -/- "manpage"))) $ do
copyDirectory (root -/- "manpage") bindistFilesDir
- -- These scripts are only necessary in the configure/install
- -- workflow which is not supported on windows.
- -- TODO: Instead of guarding against windows, we could offer the
- -- option to make a relocatable, but not installable bindist on any
- -- platform.
- unless windowsHost $ do
- -- We then 'need' all the files necessary to configure and install
- -- (as in, './configure [...] && make install') this build on some
- -- other machine.
- need $ map (bindistFilesDir -/-)
- (["configure", "Makefile"] ++ bindistInstallFiles)
- copyFile ("hadrian" -/- "bindist" -/- "config.mk.in") (bindistFilesDir -/- "config.mk.in")
- copyFile ("hadrian" -/- "cfg" -/- "default.target.in") (bindistFilesDir -/- "default.target.in")
- copyFile ("hadrian" -/- "cfg" -/- "default.host.target.in") (bindistFilesDir -/- "default.host.target.in")
- forM_ bin_targets $ \(pkg, _) -> do
- needed_wrappers <- pkgToWrappers pkg
- forM_ needed_wrappers $ \wrapper_name -> do
- let suffix = if useGhcPrefix pkg
- then "ghc-" ++ version
- else version
- wrapper_content <- wrapper wrapper_name
- let unversioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- wrapper_name
- versioned_wrapper = wrapper_name ++ "-" ++ suffix
- versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper
- -- Write the wrapper to the versioned path
- writeFile' versioned_wrapper_path wrapper_content
- -- Create a symlink from the non-versioned to the versioned.
- liftIO $ do
- IO.removeFile unversioned_wrapper_path <|> return ()
- IO.createFileLink versioned_wrapper unversioned_wrapper_path
-
-
- let buildBinDist :: Compressor -> Action ()
- buildBinDist compressor = do
- need ["binary-dist-dir"]
+ -- We then 'need' all the files necessary to configure and install
+ -- (as in, './configure [...] && make install') this build on some
+ -- other machine.
+ need $ map (bindistFilesDir -/-)
+ (["configure", "Makefile"] ++ bindistInstallFiles)
+ copyFile ("hadrian" -/- "bindist" -/- "config.mk.in") (bindistFilesDir -/- "config.mk.in")
+ generateBuildMk >>= writeFile' (bindistFilesDir -/- "build.mk")
+ copyFile ("hadrian" -/- "cfg" -/- "default.target.in") (bindistFilesDir -/- "default.target.in")
+ copyFile ("hadrian" -/- "cfg" -/- "default.host.target.in") (bindistFilesDir -/- "default.host.target.in")
+
+ -- todo: do we need these wrappers on windows
+ forM_ bin_targets $ \(pkg, _) -> do
+ needed_wrappers <- pkgToWrappers pkg
+ forM_ needed_wrappers $ \wrapper_name -> do
+ let suffix = if useGhcPrefix pkg
+ then "ghc-" ++ version
+ else version
+ wrapper_content <- wrapper wrapper_name
+ let unversioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- wrapper_name
+ versioned_wrapper = wrapper_name ++ "-" ++ suffix
+ versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper
+ -- Write the wrapper to the versioned path
+ writeFile' versioned_wrapper_path wrapper_content
+ -- Create a symlink from the non-versioned to the versioned.
+ liftIO $ do
+ IO.removeFile unversioned_wrapper_path <|> return ()
+ IO.createFileLink versioned_wrapper unversioned_wrapper_path
+
+ let buildBinDist compressor = do
+ win_target <- isWinTarget
+ when win_target (error "normal binary-dist does not work for windows target, use `reloc-binary-dist-*` target instead.")
+ buildBinDistX "binary-dist-dir" "bindist" compressor
+ buildBinDistReloc = buildBinDistX "reloc-binary-dist-dir" "reloc-bindist"
+
+ buildBinDistX :: String -> FilePath -> Compressor -> Action ()
+ buildBinDistX target bindist_folder compressor = do
+ need [target]
version <- setting ProjectVersion
targetPlatform <- setting TargetPlatformFull
@@ -293,15 +307,16 @@ bindistRules = do
-- Finally, we create the archive <root>/bindist/ghc-X.Y.Z-platform.tar.xz
tarPath <- builderPath (Tar Create)
- cmd [Cwd $ root -/- "bindist"] tarPath
+ cmd [Cwd $ root -/- bindist_folder] tarPath
[ "-c", compressorTarFlag compressor, "-f"
, ghcVersionPretty <.> "tar" <.> compressorExtension compressor
, ghcVersionPretty ]
- phony "binary-dist" $ buildBinDist Xz
- phony "binary-dist-gzip" $ buildBinDist Gzip
- phony "binary-dist-bzip2" $ buildBinDist Bzip2
- phony "binary-dist-xz" $ buildBinDist Xz
+ forM_ [("binary", buildBinDist), ("reloc-binary", buildBinDistReloc)] $ \(name, mk_bindist) -> do
+ phony (name <> "-dist") $ mk_bindist Xz
+ phony (name <> "-dist-gzip") $ mk_bindist Gzip
+ phony (name <> "-dist-bzip2") $ mk_bindist Bzip2
+ phony (name <> "-dist-xz") $ mk_bindist Xz
-- Prepare binary distribution configure script
-- (generated under <ghc root>/distrib/configure by 'autoreconf')
@@ -339,6 +354,21 @@ bindistRules = do
data Compressor = Gzip | Bzip2 | Xz
deriving (Eq, Ord, Show)
+
+-- Information from the build configuration which needs to be propagated to config.mk.in
+generateBuildMk :: Action String
+generateBuildMk = do
+ dynamicGhc <- askDynGhcPrograms
+ rtsWays <- unwords . map show . Set.toList <$> interpretInContext (vanillaContext Stage1 rts) getRtsWays
+ return $ unlines [ "GhcRTSWays" =. rtsWays
+ , "DYNAMIC_GHC_PROGRAMS" =. yesNo dynamicGhc ]
+
+
+ where
+ yesNo True = "YES"
+ yesNo False = "NO"
+ a =. b = a ++ " = " ++ b
+
-- | Flag to pass to tar to use the given 'Compressor'.
compressorTarFlag :: Compressor -> String
compressorTarFlag Gzip = "--gzip"
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -7,7 +7,6 @@ module Rules.Generate (
import Development.Shake.FilePath
import qualified Data.Set as Set
-import qualified Data.Text as T
import Base
import qualified Context
import Expression
@@ -430,44 +429,44 @@ generateSettings :: Expr String
generateSettings = do
ctx <- getContext
settings <- traverse sequence $
- [ ("C compiler command", queryTarget' ccPath)
- , ("C compiler flags", queryTarget' ccFlags)
- , ("C++ compiler command", queryTarget' cxxPath)
- , ("C++ compiler flags", queryTarget' cxxFlags)
- , ("C compiler link flags", queryTarget' clinkFlags)
- , ("C compiler supports -no-pie", queryTarget' linkSupportsNoPie)
- , ("CPP command", queryTarget' cppPath)
- , ("CPP flags", queryTarget' cppFlags)
- , ("Haskell CPP command", queryTarget' hsCppPath)
- , ("Haskell CPP flags", queryTarget' hsCppFlags)
- , ("ld supports compact unwind", queryTarget' linkSupportsCompactUnwind)
- , ("ld supports filelist", queryTarget' linkSupportsFilelist)
- , ("ld is GNU ld", queryTarget' linkIsGnu)
- , ("Merge objects command", queryTarget' mergeObjsPath)
- , ("Merge objects flags", queryTarget' mergeObjsFlags)
- , ("Merge objects supports response files", queryTarget' mergeObjsSupportsResponseFiles')
- , ("ar command", queryTarget' arPath)
- , ("ar flags", queryTarget' arFlags)
- , ("ar supports at file", queryTarget' arSupportsAtFile')
- , ("ar supports -L", queryTarget' arSupportsDashL')
- , ("ranlib command", queryTarget' ranlibPath)
+ [ ("C compiler command", queryTarget ccPath)
+ , ("C compiler flags", queryTarget ccFlags)
+ , ("C++ compiler command", queryTarget cxxPath)
+ , ("C++ compiler flags", queryTarget cxxFlags)
+ , ("C compiler link flags", queryTarget clinkFlags)
+ , ("C compiler supports -no-pie", queryTarget linkSupportsNoPie)
+ , ("CPP command", queryTarget cppPath)
+ , ("CPP flags", queryTarget cppFlags)
+ , ("Haskell CPP command", queryTarget hsCppPath)
+ , ("Haskell CPP flags", queryTarget hsCppFlags)
+ , ("ld supports compact unwind", queryTarget linkSupportsCompactUnwind)
+ , ("ld supports filelist", queryTarget linkSupportsFilelist)
+ , ("ld is GNU ld", queryTarget linkIsGnu)
+ , ("Merge objects command", queryTarget mergeObjsPath)
+ , ("Merge objects flags", queryTarget mergeObjsFlags)
+ , ("Merge objects supports response files", queryTarget mergeObjsSupportsResponseFiles')
+ , ("ar command", queryTarget arPath)
+ , ("ar flags", queryTarget arFlags)
+ , ("ar supports at file", queryTarget arSupportsAtFile')
+ , ("ar supports -L", queryTarget arSupportsDashL')
+ , ("ranlib command", queryTarget ranlibPath)
, ("otool command", expr $ settingsFileSetting ToolchainSetting_OtoolCommand)
, ("install_name_tool command", expr $ settingsFileSetting ToolchainSetting_InstallNameToolCommand)
, ("touch command", expr $ settingsFileSetting ToolchainSetting_TouchCommand)
- , ("windres command", queryTarget' (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me.
+ , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me.
, ("unlit command", ("$topdir/bin/" <>) <$> expr (programName (ctx { Context.package = unlit })))
, ("cross compiling", expr $ yesNo <$> flag CrossCompiling)
- , ("target platform string", queryTarget' targetPlatformTriple)
- , ("target os", queryTarget' (show . archOS_OS . tgtArchOs))
- , ("target arch", queryTarget' (show . archOS_arch . tgtArchOs))
- , ("target word size", queryTarget' wordSize)
- , ("target word big endian", queryTarget' isBigEndian)
- , ("target has GNU nonexec stack", queryTarget' (yesNo . Toolchain.tgtSupportsGnuNonexecStack))
- , ("target has .ident directive", queryTarget' (yesNo . Toolchain.tgtSupportsIdentDirective))
- , ("target has subsections via symbols", queryTarget' (yesNo . Toolchain.tgtSupportsSubsectionsViaSymbols))
+ , ("target platform string", queryTarget targetPlatformTriple)
+ , ("target os", queryTarget (show . archOS_OS . tgtArchOs))
+ , ("target arch", queryTarget (show . archOS_arch . tgtArchOs))
+ , ("target word size", queryTarget wordSize)
+ , ("target word big endian", queryTarget isBigEndian)
+ , ("target has GNU nonexec stack", queryTarget (yesNo . Toolchain.tgtSupportsGnuNonexecStack))
+ , ("target has .ident directive", queryTarget (yesNo . Toolchain.tgtSupportsIdentDirective))
+ , ("target has subsections via symbols", queryTarget (yesNo . Toolchain.tgtSupportsSubsectionsViaSymbols))
, ("target has libm", expr $ lookupSystemConfig "target-has-libm")
- , ("Unregisterised", queryTarget' (yesNo . tgtUnregisterised))
- , ("LLVM target", queryTarget' tgtLlvmTarget)
+ , ("Unregisterised", queryTarget (yesNo . tgtUnregisterised))
+ , ("LLVM target", queryTarget tgtLlvmTarget)
, ("LLVM llc command", expr $ settingsFileSetting ToolchainSetting_LlcCommand)
, ("LLVM opt command", expr $ settingsFileSetting ToolchainSetting_OptCommand)
, ("Use inplace MinGW toolchain", expr $ settingsFileSetting ToolchainSetting_DistroMinGW)
@@ -475,8 +474,8 @@ generateSettings = do
, ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter)
, ("Support SMP", expr $ yesNo <$> targetSupportsSMP)
, ("RTS ways", unwords . map show . Set.toList <$> getRtsWays)
- , ("Tables next to code", queryTarget' (yesNo . tgtTablesNextToCode))
- , ("Leading underscore", queryTarget' (yesNo . tgtSymbolsHaveLeadingUnderscore))
+ , ("Tables next to code", queryTarget (yesNo . tgtTablesNextToCode))
+ , ("Leading underscore", queryTarget (yesNo . tgtSymbolsHaveLeadingUnderscore))
, ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
, ("RTS expects libdw", yesNo <$> getFlag UseLibdw)
]
@@ -512,21 +511,6 @@ generateSettings = do
wordSize = show . wordSize2Bytes . tgtWordSize
mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs
- -- Like @'queryTarget'@ specialized to String, but replace occurrences of
- -- @topDirectory </> inplace/mingw@ with @$tooldir/mingw@ in the resulting string
- --
- -- See Note [How we configure the bundled windows toolchain]
- queryTarget' :: (Toolchain.Target -> String) -> Expr String
- queryTarget' f = do
- topdir <- expr $ topDirectory
- queryTarget (\t -> substTooldir topdir (archOS_OS $ tgtArchOs t) (f t))
- where
- substTooldir :: String -> OS -> String -> String
- substTooldir topdir OSMinGW32 s
- = T.unpack $
- T.replace (T.pack $ normalise $ topdir </> "inplace" </> "mingw") (T.pack "$tooldir/mingw") (T.pack $ normalise s)
- substTooldir _ _ s = s
-
-- | Generate @Config.hs@ files.
generateConfigHs :: Expr String
=====================================
m4/fp_settings.m4
=====================================
@@ -36,14 +36,15 @@ dnl ghc-toolchain.
# SUBST_TOOLDIR
# ----------------------------------
# $1 - the variable where to search for occurrences of the path to the
-# distributed mingw, and update by substituting said occurrences by
-# the literal '$tooldir/mingw'
+# inplace mingw, and update by substituting said occurrences by
+# the value of $mingw_install_prefix, where the mingw toolchain will be at
+# install time
#
# See Note [How we configure the bundled windows toolchain]
AC_DEFUN([SUBST_TOOLDIR],
[
dnl and Note [How we configure the bundled windows toolchain]
- $1=`echo $$1 | sed 's%'"$mingwpath"'%$$tooldir/mingw%'`
+set -- "$(echo "$$1" | sed 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g')"
])
# FP_SETTINGS
=====================================
m4/fp_setup_windows_toolchain.m4
=====================================
@@ -1,4 +1,5 @@
-AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[
+# Download and install the windows toolchain
+AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[
# Find the mingw-w64 archive file to extract.
if test "$HostArch" = "i386"
then
@@ -72,18 +73,28 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[
# NB. Download and extract the MingW-w64 distribution if required
set_up_tarballs
+])
+
+# Set up the environment variables
+# $1 The actual location of the windows toolchain (before install)
+# $2 the location that the windows toolchain will be installed in relative to the libdir
+AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[
+
# N.B. The parameters which get plopped in the `settings` file used by the
# resulting compiler are computed in `FP_SETTINGS`. Specifically, we use
# $$topdir-relative paths instead of fullpaths to the toolchain, by replacing
# occurrences of $hardtop/inplace/mingw with $$tooldir/mingw
+ mingw_prefix="$1"
+ mingw_install_prefix="$2"
+
# Our Windows toolchain is based around Clang and LLD. We use compiler-rt
# for the runtime, libc++ and libc++abi for the C++ standard library
# implementation, and libunwind for C++ unwinding.
- mingwbin="$hardtop/inplace/mingw/bin/"
- mingwlib="$hardtop/inplace/mingw/lib"
- mingwinclude="$hardtop/inplace/mingw/include"
- mingwpath="$hardtop/inplace/mingw"
+ mingwbin="$mingw_prefix/bin/"
+ mingwlib="$mingw_prefix/lib"
+ mingwinclude="$mingw_prefix/include"
+ mingw_mingw32_lib="$mingw_prefix/x86_64-w64-mingw32/lib"
CC="${mingwbin}clang.exe"
CXX="${mingwbin}clang++.exe"
@@ -106,8 +117,8 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[
HaskellCPPArgs="$HaskellCPPArgs -I$mingwinclude"
- CONF_GCC_LINKER_OPTS_STAGE1="-fuse-ld=lld $cflags -L$mingwlib -L$hardtop/inplace/mingw/x86_64-w64-mingw32/lib"
- CONF_GCC_LINKER_OPTS_STAGE2="-fuse-ld=lld $cflags -L$mingwlib -L$hardtop/inplace/mingw/x86_64-w64-mingw32/lib"
+ CONF_GCC_LINKER_OPTS_STAGE1="-fuse-ld=lld $cflags -L$mingwlib -L$mingw_mingw32_lib"
+ CONF_GCC_LINKER_OPTS_STAGE2="-fuse-ld=lld $cflags -L$mingwlib -L$mingw_mingw32_lib"
# N.BOn Windows we can't easily dynamically-link against libc++ since there is
# no RPATH support, meaning that the loader will have no way of finding our
@@ -121,7 +132,7 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[
RANLIB="${mingwbin}llvm-ranlib.exe"
OBJDUMP="${mingwbin}llvm-objdump.exe"
DLLTOOL="${mingwbin}llvm-dlltool.exe"
- Windres="${mingwbin}llvm-windres.exe"
+ WindresCmd="${mingwbin}llvm-windres.exe"
# N.B. LLD does not support -r
MergeObjsCmd=""
=====================================
testsuite/tests/patsyn/should_fail/T23467.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T23467 where
+
+data ConData = ConData { _pars :: Int }
+data Decl = ConDecl ConData
+
+pattern Con :: Decl -- The correct type would be Int -> Decl
+pattern Con { pars } = ConDecl (ConData pars)
+
+foo :: Decl -> Int
+foo (Con { pars }) = pars
=====================================
testsuite/tests/patsyn/should_fail/T23467.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T23467.hs:9:1: error: [GHC-18365]
+ • Pattern synonym ‘Con’ has one argument
+ but its type signature has 1 fewer arrows
+ • In the declaration for pattern synonym ‘Con’
=====================================
testsuite/tests/patsyn/should_fail/all.T
=====================================
@@ -48,3 +48,4 @@ test('T16900', normal, compile_fail, ['-fdiagnostics-show-caret'])
test('T14552', normal, compile_fail, [''])
test('T18856', normal, compile_fail, ['-fdiagnostics-show-caret'])
test('T21479', normal, compile_fail, [''])
+test('T23467', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f55ebf53b39c9cfa366f99145f2f4c3474daf592...1ffd2354c847bf288817816cd4033e5ed4ca1c33
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f55ebf53b39c9cfa366f99145f2f4c3474daf592...1ffd2354c847bf288817816cd4033e5ed4ca1c33
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/20230823/e30dceb1/attachment-0001.html>
More information about the ghc-commits
mailing list