[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: ghc-heap: Fix decoding of TSO closures
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Aug 18 15:57:34 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
436867d6 by Matthew Pickering at 2022-08-18T09:24:08-04:00
ghc-heap: Fix decoding of TSO closures
An extra field was added to the TSO structure in 6d1700b6 but the
decoding logic in ghc-heap was not updated for this new field.
Fixes #22046
- - - - -
a740a4c5 by Matthew Pickering at 2022-08-18T09:24:44-04:00
driver: Honour -x option
The -x option is used to manually specify which phase a file should be
started to be compiled from (even if it lacks the correct extension). I
just failed to implement this when refactoring the driver.
In particular Cabal calls GHC with `-E -cpp -x hs Foo.cpphs` to
preprocess source files using GHC.
I added a test to exercise this case.
Fixes #22044
- - - - -
e293029d by Simon Peyton Jones at 2022-08-18T09:25:19-04:00
Be more careful in chooseInferredQuantifiers
This fixes #22065. We were failing to retain a quantifier that
was mentioned in the kind of another retained quantifier.
Easy to fix.
- - - - -
04640cb2 by Bryan Richter at 2022-08-18T11:57:07-04:00
testsuite: Add test for #21583
- - - - -
dd7a14e5 by Ben Gamari at 2022-08-18T11:57:14-04:00
compiler: Drop --build-id=none hack
Since 2011 the object-joining implementation has had a hack to pass
`--build-id=none` to `ld` when supported, seemingly to work around a
linker bug. This hack is now unnecessary and may break downstream users
who expect objects to have valid build-ids. Remove it.
Closes #22060.
- - - - -
27 changed files:
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/Monad.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Settings/IO.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Types/Var.hs
- hadrian/bindist/Makefile
- hadrian/cfg/system.config.in
- hadrian/src/Rules/Generate.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- − m4/fp_prog_ld_build_id.m4
- mk/config.mk.in
- rts/include/ghc.mk
- testsuite/tests/driver/Makefile
- + testsuite/tests/driver/T22044.bazoo
- testsuite/tests/driver/all.T
- + testsuite/tests/partial-sigs/should_compile/T16152.hs
- + testsuite/tests/partial-sigs/should_compile/T16152.stderr
- + testsuite/tests/partial-sigs/should_compile/T22065.hs
- + testsuite/tests/partial-sigs/should_compile/T22065.stderr
- testsuite/tests/partial-sigs/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T21583.hs
- + testsuite/tests/typecheck/should_fail/T21583.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -171,7 +171,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
-> Just (DriverPsHeaderMessage (PsHeaderMessage msg))
_ -> Nothing
- pipe_env = mkPipeEnv StopPreprocess input_fn (Temporary TFL_GhcSession)
+ pipe_env = mkPipeEnv StopPreprocess input_fn mb_phase (Temporary TFL_GhcSession)
mkInputFn =
case mb_input_buf of
Just input_buf -> do
@@ -237,7 +237,7 @@ compileOne' mHscMessage
[ml_obj_file $ ms_location summary]
plugin_hsc_env <- initializePlugins hsc_env
- let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput
+ let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput
status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary
mb_old_iface mb_old_linkable (mod_index, nmods)
let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)
@@ -512,7 +512,7 @@ oneShot hsc_env stop_phase srcs = do
NoStop -> doLink hsc_env o_files
compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
-compileFile hsc_env stop_phase (src, _mb_phase) = do
+compileFile hsc_env stop_phase (src, mb_phase) = do
exists <- doesFileExist src
when (not exists) $
throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
@@ -533,8 +533,8 @@ compileFile hsc_env stop_phase (src, _mb_phase) = do
| isJust mb_o_file = SpecificFile
-- -o foo applies to the file we are compiling now
| otherwise = Persistent
- pipe_env = mkPipeEnv stop_phase src output
- pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src
+ pipe_env = mkPipeEnv stop_phase src mb_phase output
+ pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase
runPipeline (hsc_hooks hsc_env) pipeline
@@ -583,7 +583,7 @@ compileForeign hsc_env lang stub_c = do
#if __GLASGOW_HASKELL__ < 811
RawObject -> panic "compileForeign: should be unreachable"
#endif
- pipe_env = mkPipeEnv NoStop stub_c (Temporary TFL_GhcSession)
+ pipe_env = mkPipeEnv NoStop stub_c Nothing (Temporary TFL_GhcSession)
res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c)
case res of
-- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.
@@ -607,7 +607,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
let home_unit = hsc_home_unit hsc_env
src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
- let pipe_env = (mkPipeEnv NoStop empty_stub Persistent) { src_basename = basename}
+ let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
_ <- runPipeline (hsc_hooks hsc_env) pipeline
return ()
@@ -617,15 +617,17 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
mkPipeEnv :: StopPhase -- End phase
-> FilePath -- input fn
+ -> Maybe Phase
-> PipelineOutput -- Output
-> PipeEnv
-mkPipeEnv stop_phase input_fn output =
+mkPipeEnv stop_phase input_fn start_phase output =
let (basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix -- strip off the .
env = PipeEnv{ stop_phase,
src_filename = input_fn,
src_basename = basename,
src_suffix = suffix',
+ start_phase = fromMaybe (startPhase suffix') start_phase,
output_spec = output }
in env
@@ -695,8 +697,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do
where platform = targetPlatform (hsc_dflags hsc_env)
runAfter :: P p => Phase
-> a -> p a -> p a
- runAfter = phaseIfAfter platform start_phase
- start_phase = startPhase (src_suffix pipe_env)
+ runAfter = phaseIfAfter platform (start_phase pipe_env)
runAfterFlag :: P p
=> HscEnv
-> Phase
@@ -829,9 +830,9 @@ applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing
-- Pipeline from a given suffix
-pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
-pipelineStart pipe_env hsc_env input_fn =
- fromSuffix (src_suffix pipe_env)
+pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)
+pipelineStart pipe_env hsc_env input_fn mb_phase =
+ fromPhase (fromMaybe (startPhase $ src_suffix pipe_env) mb_phase)
where
stop_after = stop_phase pipe_env
frontend :: P m => HscSource -> m (Maybe FilePath)
@@ -863,33 +864,24 @@ pipelineStart pipe_env hsc_env input_fn =
objFromLinkable _ = Nothing
- fromSuffix :: P m => String -> m (Maybe FilePath)
- fromSuffix "lhs" = frontend HsSrcFile
- fromSuffix "lhs-boot" = frontend HsBootFile
- fromSuffix "lhsig" = frontend HsigFile
- fromSuffix "hs" = frontend HsSrcFile
- fromSuffix "hs-boot" = frontend HsBootFile
- fromSuffix "hsig" = frontend HsigFile
- fromSuffix "hscpp" = frontend HsSrcFile
- fromSuffix "hspp" = frontend HsSrcFile
- fromSuffix "hc" = c HCc
- fromSuffix "c" = c Cc
- fromSuffix "cpp" = c Ccxx
- fromSuffix "C" = c Cc
- fromSuffix "m" = c Cobjc
- fromSuffix "M" = c Cobjcxx
- fromSuffix "mm" = c Cobjcxx
- fromSuffix "cc" = c Ccxx
- fromSuffix "cxx" = c Ccxx
- fromSuffix "s" = as False
- fromSuffix "S" = as True
- fromSuffix "ll" = llvmPipeline pipe_env hsc_env Nothing input_fn
- fromSuffix "bc" = llvmLlcPipeline pipe_env hsc_env Nothing input_fn
- fromSuffix "lm_s" = llvmManglePipeline pipe_env hsc_env Nothing input_fn
- fromSuffix "o" = return (Just input_fn)
- fromSuffix "cmm" = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
- fromSuffix "cmmcpp" = Just <$> cmmPipeline pipe_env hsc_env input_fn
- fromSuffix _ = return (Just input_fn)
+ fromPhase :: P m => Phase -> m (Maybe FilePath)
+ fromPhase (Unlit p) = frontend p
+ fromPhase (Cpp p) = frontend p
+ fromPhase (HsPp p) = frontend p
+ fromPhase (Hsc p) = frontend p
+ fromPhase HCc = c HCc
+ fromPhase Cc = c Cc
+ fromPhase Ccxx = c Ccxx
+ fromPhase Cobjc = c Cobjc
+ fromPhase Cobjcxx = c Cobjcxx
+ fromPhase (As p) = as p
+ fromPhase LlvmOpt = llvmPipeline pipe_env hsc_env Nothing input_fn
+ fromPhase LlvmLlc = llvmLlcPipeline pipe_env hsc_env Nothing input_fn
+ fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn
+ fromPhase StopLn = return (Just input_fn)
+ fromPhase CmmCpp = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
+ fromPhase Cmm = Just <$> cmmPipeline pipe_env hsc_env input_fn
+ fromPhase MergeForeign = panic "fromPhase: MergeForeign"
{-
Note [The Pipeline Monad]
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -1184,17 +1184,10 @@ joinObjectFiles hsc_env o_files output_fn
let toolSettings' = toolSettings dflags
ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
- map GHC.SysTools.Option ld_build_id
- ++ [ GHC.SysTools.Option "-o",
+ [ GHC.SysTools.Option "-o",
GHC.SysTools.FileOption "" output_fn ]
++ args)
- -- suppress the generation of the .note.gnu.build-id section,
- -- which we don't need and sometimes causes ld to emit a
- -- warning:
- ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]
- | otherwise = []
-
if ldIsGnuLd
then do
script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript"
=====================================
compiler/GHC/Driver/Pipeline/Monad.hs
=====================================
@@ -29,6 +29,7 @@ data PipeEnv = PipeEnv {
src_filename :: String, -- ^ basename of original input source
src_basename :: String, -- ^ basename of original input source
src_suffix :: String, -- ^ its extension
+ start_phase :: Phase,
output_spec :: PipelineOutput -- ^ says where to put the pipeline output
}
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -81,7 +81,6 @@ module GHC.Driver.Session (
sTopDir,
sGlobalPackageDatabasePath,
sLdSupportsCompactUnwind,
- sLdSupportsBuildId,
sLdSupportsFilelist,
sLdIsGnuLd,
sGccSupportsNoPie,
=====================================
compiler/GHC/Settings.hs
=====================================
@@ -18,7 +18,6 @@ module GHC.Settings
, sTopDir
, sGlobalPackageDatabasePath
, sLdSupportsCompactUnwind
- , sLdSupportsBuildId
, sLdSupportsFilelist
, sLdIsGnuLd
, sGccSupportsNoPie
@@ -87,7 +86,6 @@ data Settings = Settings
-- platform-specific and platform-agnostic.
data ToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind :: Bool
- , toolSettings_ldSupportsBuildId :: Bool
, toolSettings_ldSupportsFilelist :: Bool
, toolSettings_ldIsGnuLd :: Bool
, toolSettings_ccSupportsNoPie :: Bool
@@ -189,8 +187,6 @@ sGlobalPackageDatabasePath = fileSettings_globalPackageDatabase . sFileSettings
sLdSupportsCompactUnwind :: Settings -> Bool
sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings
-sLdSupportsBuildId :: Settings -> Bool
-sLdSupportsBuildId = toolSettings_ldSupportsBuildId . sToolSettings
sLdSupportsFilelist :: Settings -> Bool
sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings
sLdIsGnuLd :: Settings -> Bool
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -94,7 +94,6 @@ initSettings top_dir = do
cc_args = words cc_args_str ++ unreg_cc_args
cxx_args = words cxx_args_str
ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
- ldSupportsBuildId <- getBooleanSetting "ld supports build-id"
ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
arSupportsDashL <- getBooleanSetting "ar supports -L"
@@ -163,7 +162,6 @@ initSettings top_dir = do
, sToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind
- , toolSettings_ldSupportsBuildId = ldSupportsBuildId
, toolSettings_ldSupportsFilelist = ldSupportsFilelist
, toolSettings_ldIsGnuLd = ldIsGnuLd
, toolSettings_ccSupportsNoPie = gccSupportsNoPie
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -43,6 +43,7 @@ import GHC.Tc.Solver
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
+import GHC.Core.TyCo.Ppr( pprTyVars )
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
@@ -59,7 +60,7 @@ import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.Var as Var
import GHC.Types.Var.Set
-import GHC.Types.Var.Env( TidyEnv )
+import GHC.Types.Var.Env( TidyEnv, TyVarEnv, mkVarEnv, lookupVarEnv )
import GHC.Unit.Module
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -934,7 +935,8 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
; let psig_qtvs = map binderVar psig_qtv_bndrs
psig_qtv_set = mkVarSet psig_qtvs
psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs
-
+ psig_bndr_map :: TyVarEnv InvisTVBinder
+ psig_bndr_map = mkVarEnv [ (binderVar tvb, tvb) | tvb <- psig_qtv_bndrs ]
-- Check whether the quantified variables of the
-- partial signature have been unified together
@@ -950,32 +952,35 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
; annotated_theta <- zonkTcTypes annotated_theta
; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx
+ -- NB: free_tvs includes tau_tvs
+
+ ; let (_,final_qtvs) = foldr (choose_qtv psig_bndr_map) (free_tvs, []) qtvs
+ -- Pulling from qtvs maintains original order
+ -- NB: qtvs is already in dependency order
- ; let keep_me = free_tvs `unionVarSet` psig_qtv_set
- final_qtvs = [ mkTyVarBinder vis tv
- | tv <- qtvs -- Pulling from qtvs maintains original order
- , tv `elemVarSet` keep_me
- , let vis = case lookupVarBndr tv psig_qtv_bndrs of
- Just spec -> spec
- Nothing -> InferredSpec ]
+ ; traceTc "chooseInferredQuantifiers" $
+ vcat [ text "qtvs" <+> pprTyVars qtvs
+ , text "psig_qtv_bndrs" <+> ppr psig_qtv_bndrs
+ , text "free_tvs" <+> ppr free_tvs
+ , text "final_tvs" <+> ppr final_qtvs ]
; return (final_qtvs, my_theta) }
where
- report_dup_tyvar_tv_err (n1,n2)
- = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty)
-
- report_mono_sig_tv_err (n,tv)
- = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)
- where
- m_unif_ty = listToMaybe
- [ rhs
- -- recall that residuals are always implications
- | residual_implic <- bagToList $ wc_impl residual
- , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic)
- , let residual_pred = ctPred residual_ct
- , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ]
- , Just lhs_tv <- [ tcGetTyVar_maybe lhs ]
- , lhs_tv == tv ]
+ choose_qtv :: TyVarEnv InvisTVBinder -> TcTyVar
+ -> (TcTyVarSet, [InvisTVBinder]) -> (TcTyVarSet, [InvisTVBinder])
+ -- Pick which of the original qtvs should be retained
+ -- Keep it if (a) it is mentioned in the body of the type (free_tvs)
+ -- (b) it is a forall'd variable of the partial signature (psig_qtv_bndrs)
+ -- (c) it is mentioned in the kind of a retained qtv (#22065)
+ choose_qtv psig_bndr_map tv (free_tvs, qtvs)
+ | Just psig_bndr <- lookupVarEnv psig_bndr_map tv
+ = (free_tvs', psig_bndr : qtvs)
+ | tv `elemVarSet` free_tvs
+ = (free_tvs', mkTyVarBinder InferredSpec tv : qtvs)
+ | otherwise -- Do not pick it
+ = (free_tvs, qtvs)
+ where
+ free_tvs' = free_tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv)
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
-> TcM (VarSet, TcThetaType)
@@ -1019,6 +1024,22 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
-- Return (annotated_theta ++ diff_theta)
-- See Note [Extra-constraints wildcards]
+ report_dup_tyvar_tv_err (n1,n2)
+ = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty)
+
+ report_mono_sig_tv_err (n,tv)
+ = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)
+ where
+ m_unif_ty = listToMaybe
+ [ rhs
+ -- recall that residuals are always implications
+ | residual_implic <- bagToList $ wc_impl residual
+ , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic)
+ , let residual_pred = ctPred residual_ct
+ , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ]
+ , Just lhs_tv <- [ tcGetTyVar_maybe lhs ]
+ , lhs_tv == tv ]
+
mk_ctuple preds = mkBoxedTupleTy preds
-- Hack alert! See GHC.Tc.Gen.HsType:
-- Note [Extra-constraint holes in partial type signatures]
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -79,7 +79,7 @@ module GHC.Types.Var (
mkTyVarBinder, mkTyVarBinders,
isTyVarBinder,
tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders,
- mapVarBndr, mapVarBndrs, lookupVarBndr,
+ mapVarBndr, mapVarBndrs,
-- ** Constructing TyVar's
mkTyVar, mkTcTyVar,
@@ -696,11 +696,6 @@ mapVarBndr f (Bndr v fl) = Bndr (f v) fl
mapVarBndrs :: (var -> var') -> [VarBndr var flag] -> [VarBndr var' flag]
mapVarBndrs f = map (mapVarBndr f)
-lookupVarBndr :: Eq var => var -> [VarBndr var flag] -> Maybe flag
-lookupVarBndr var bndrs = lookup var zipped_bndrs
- where
- zipped_bndrs = map (\(Bndr v f) -> (v,f)) bndrs
-
instance Outputable tv => Outputable (VarBndr tv ArgFlag) where
ppr (Bndr v Required) = ppr v
ppr (Bndr v Specified) = char '@' <> ppr v
=====================================
hadrian/bindist/Makefile
=====================================
@@ -91,7 +91,6 @@ lib/settings :
@echo ',("ld command", "$(SettingsLdCommand)")' >> $@
@echo ',("ld flags", "$(SettingsLdFlags)")' >> $@
@echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@
- @echo ',("ld supports build-id", "$(LdHasBuildId)")' >> $@
@echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@
@echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@
@echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -136,7 +136,6 @@ conf-merge-objects-args-stage3 = @MergeObjsArgs@
gcc-extra-via-c-opts = @GccExtraViaCOpts@
ld-has-no-compact-unwind = @LdHasNoCompactUnwind@
-ld-has-build-id = @LdHasBuildId@
ld-has-filelist = @LdHasFilelist@
ld-is-gnu-ld = @LdIsGNULd@
ar-args = @ArArgs@
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -311,7 +311,6 @@ generateSettings = do
, ("ld command", expr $ settingsFileSetting SettingsFileSetting_LdCommand)
, ("ld flags", expr $ settingsFileSetting SettingsFileSetting_LdFlags)
, ("ld supports compact unwind", expr $ lookupSystemConfig "ld-has-no-compact-unwind")
- , ("ld supports build-id", expr $ lookupSystemConfig "ld-has-build-id")
, ("ld supports filelist", expr $ lookupSystemConfig "ld-has-filelist")
, ("ld is GNU ld", expr $ lookupSystemConfig "ld-is-gnu-ld")
, ("Merge objects command", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsCommand)
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -350,7 +350,7 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
[p] -> Just p
_ -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts)
}
- TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
+ TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- pts
-> withArray rawHeapWords (\ptr -> do
fields <- FFIClosures.peekTSOFields decodeCCS ptr
pure $ TSOClosure
@@ -361,6 +361,10 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
, trec = u_trec
, blocked_exceptions = u_blk_ex
, bq = u_bq
+ , thread_label = case other of
+ [tl] -> Just tl
+ [] -> Nothing
+ _ -> error $ "thead_label:Expected 0 or 1 extra arguments"
, what_next = FFIClosures.tso_what_next fields
, why_blocked = FFIClosures.tso_why_blocked fields
, flags = FFIClosures.tso_flags fields
@@ -372,7 +376,7 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
, prof = FFIClosures.tso_prof fields
})
| otherwise
- -> fail $ "Expected 6 ptr arguments to TSO, found "
+ -> fail $ "Expected at least 6 ptr arguments to TSO, found "
++ show (length pts)
STACK
| [] <- pts
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -280,6 +280,7 @@ data GenClosure b
, trec :: !b
, blocked_exceptions :: !b
, bq :: !b
+ , thread_label :: !(Maybe b)
-- values
, what_next :: !WhatNext
, why_blocked :: !WhyBlocked
=====================================
m4/fp_prog_ld_build_id.m4 deleted
=====================================
@@ -1,20 +0,0 @@
-# FP_PROG_LD_BUILD_ID
-# ------------
-# Sets the output variable LdHasBuildId to YES if ld supports
-# --build-id, or NO otherwise.
-AC_DEFUN([FP_PROG_LD_BUILD_ID],
-[
-AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id],
-[echo 'int foo() { return 0; }' > conftest.c
-${CC-cc} -c conftest.c
-if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then
- fp_cv_ld_build_id=yes
-else
- fp_cv_ld_build_id=no
-fi
-rm -rf conftest*])
-FP_CAPITALIZE_YES_NO(["$fp_cv_ld_build_id"], [LdHasBuildId])
-AC_SUBST([LdHasBuildId])
-])# FP_PROG_LD_BUILD_ID
-
-
=====================================
mk/config.mk.in
=====================================
@@ -724,10 +724,6 @@ OPT = @OptCmd@
# overflowing command-line length limits.
LdIsGNULd = @LdIsGNULd@
-# Set to YES if ld has the --build-id flag. Sometimes we need to
-# disable it with --build-id=none.
-LdHasBuildId = @LdHasBuildId@
-
# Set to YES if ld has the --no_compact_unwind flag. See #5019
# and GHC.Driver.Pipeline.
LdHasNoCompactUnwind = @LdHasNoCompactUnwind@
=====================================
rts/include/ghc.mk
=====================================
@@ -202,7 +202,6 @@ $(includes_SETTINGS) : rts/include/Makefile | $$(dir $$@)/.
@echo ',("ld command", "$(SettingsLdCommand)")' >> $@
@echo ',("ld flags", "$(SettingsLdFlags)")' >> $@
@echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@
- @echo ',("ld supports build-id", "$(LdHasBuildId)")' >> $@
@echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@
@echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@
@echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@
=====================================
testsuite/tests/driver/Makefile
=====================================
@@ -779,3 +779,11 @@ T21869:
"$(TEST_HC)" $(TEST_HC_OPTS) -v0 T21869.hs -S
[ -f T21869.s ] || (echo "assembly file does not exist" && exit 2)
[ ! -f T21869.o ] || (echo "object file exists" && exit 2)
+
+.PHONY: T22044
+T22044:
+ "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -E -cpp -x hs T22044.bazoo -o T22044.hs -DBAZOO=1
+ # Test the file exists and is preprocessed
+ "$(TEST_HC)" $(TEST_HC_OPTS) -v0 T22044.hs
+
+
=====================================
testsuite/tests/driver/T22044.bazoo
=====================================
@@ -0,0 +1,3 @@
+module T22044 where
+
+bazoo = BAZOO
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -311,3 +311,4 @@ test('T20569', extra_files(["T20569/"]), makefile_test, [])
test('T21866', normal, multimod_compile, ['T21866','-no-link'])
test('T21349', extra_files(['T21349']), makefile_test, [])
test('T21869', [normal, when(unregisterised(), skip)], makefile_test, [])
+test('T22044', normal, makefile_test, [])
=====================================
testsuite/tests/partial-sigs/should_compile/T16152.hs
=====================================
@@ -0,0 +1,8 @@
+{-# Language PartialTypeSignatures #-}
+{-# Language PolyKinds #-}
+{-# Language ScopedTypeVariables #-}
+
+module T16152 where
+
+top :: forall f. _
+top = undefined
=====================================
testsuite/tests/partial-sigs/should_compile/T16152.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T16152.hs:7:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘w’
+ Where: ‘w’ is a rigid type variable bound by
+ the inferred type of top :: w
+ at T16152.hs:8:1-15
+ • In the type signature: top :: forall f. _
=====================================
testsuite/tests/partial-sigs/should_compile/T22065.hs
=====================================
@@ -0,0 +1,30 @@
+{-# Options_GHC -dcore-lint #-}
+{-# Language PartialTypeSignatures #-}
+
+module T22065 where
+
+data Foo where
+ Apply :: (x -> Int) -> x -> Foo
+
+foo :: Foo
+foo = Apply f x :: forall a. _ where
+
+ f :: [_] -> Int
+ f = length @[] @_
+
+ x :: [_]
+ x = mempty @[_]
+
+{-
+Smaller version I used when debuggging
+
+apply :: (x->Int) -> x -> Bool
+apply = apply
+
+foo :: Bool
+foo = apply f x :: forall a. _
+ where
+ f = length @[]
+ x = mempty
+
+-}
=====================================
testsuite/tests/partial-sigs/should_compile/T22065.stderr
=====================================
@@ -0,0 +1,53 @@
+
+T22065.hs:10:30: warning: [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘Foo’
+ • In an expression type signature: forall a. _
+ In the expression: Apply f x :: forall a. _
+ In an equation for ‘foo’:
+ foo
+ = Apply f x :: forall a. _
+ where
+ f :: [_] -> Int
+ f = length @[] @_
+ x :: [_]
+ x = mempty @[_]
+ • Relevant bindings include
+ f :: forall {w}. [w] -> Int (bound at T22065.hs:13:3)
+ x :: forall {w}. [w] (bound at T22065.hs:16:3)
+ foo :: Foo (bound at T22065.hs:10:1)
+
+T22065.hs:12:9: warning: [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘w’
+ Where: ‘w’ is a rigid type variable bound by
+ the inferred type of f :: [w] -> Int
+ at T22065.hs:13:3-19
+ • In the type ‘[_] -> Int’
+ In the type signature: f :: [_] -> Int
+ In an equation for ‘foo’:
+ foo
+ = Apply f x :: forall a. _
+ where
+ f :: [_] -> Int
+ f = length @[] @_
+ x :: [_]
+ x = mempty @[_]
+ • Relevant bindings include
+ x :: forall {w}. [w] (bound at T22065.hs:16:3)
+ foo :: Foo (bound at T22065.hs:10:1)
+
+T22065.hs:15:9: warning: [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘w’
+ Where: ‘w’ is a rigid type variable bound by
+ the inferred type of x :: [w]
+ at T22065.hs:16:3-17
+ • In the type ‘[_]’
+ In the type signature: x :: [_]
+ In an equation for ‘foo’:
+ foo
+ = Apply f x :: forall a. _
+ where
+ f :: [_] -> Int
+ f = length @[] @_
+ x :: [_]
+ x = mempty @[_]
+ • Relevant bindings include foo :: Foo (bound at T22065.hs:10:1)
=====================================
testsuite/tests/partial-sigs/should_compile/all.T
=====================================
@@ -105,3 +105,5 @@ test('T20921', normal, compile, [''])
test('T21719', normal, compile, [''])
test('InstanceGivenOverlap3', expect_broken(20076), compile, [''])
test('T21667', normal, compile, [''])
+test('T22065', normal, compile, [''])
+test('T16152', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_fail/T21583.hs
=====================================
@@ -0,0 +1,90 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Telomare.Possible where
+
+data PartExprF f
+ = ZeroSF
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+newtype EnhancedExpr f = EnhancedExpr {unEnhanceExpr :: SplitFunctor f PartExprF (EnhancedExpr f)} -- deriving (Eq, Show)
+
+type family Base t :: * -> *
+
+type instance Base (EnhancedExpr f) = SplitFunctor f PartExprF
+
+class Functor (Base t) => Recursive t where
+ project :: t -> Base t t
+
+instance Functor f => Recursive (EnhancedExpr f) where
+ project = unEnhanceExpr
+
+class Functor (Base t) => Corecursive t where
+ embed :: Base t t -> t
+
+instance Functor f => Corecursive (EnhancedExpr f) where
+ embed = EnhancedExpr
+
+type SimpleExpr = EnhancedExpr VoidF
+type BasicBase f = SplitFunctor f PartExprF
+type SuperBase f = BasicBase (SplitFunctor f SuperPositionF)
+type AbortBase f = SuperBase (SplitFunctor f AbortableF)
+type UnsizedBase = AbortBase UnsizedRecursionF
+
+pattern UnsizedFW :: UnsizedRecursionF a -> UnsizedBase a
+pattern UnsizedFW x = SplitFunctor (Left (SplitFunctor (Left (SplitFunctor (Left x)))))
+pattern BasicExpr :: PartExprF (EnhancedExpr f) -> EnhancedExpr f
+pattern BasicExpr x = EnhancedExpr (SplitFunctor (Right x))
+pattern UnsizedWrap :: UnsizedRecursionF UnsizedExpr -> UnsizedExpr
+pattern UnsizedWrap x = EnhancedExpr (UnsizedFW x)
+
+data VoidF f
+ deriving (Functor, Foldable, Traversable)
+
+data SuperPositionF f
+ = AnyPF
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+data AbortableF f
+ = AbortF
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+newtype SplitFunctor g f x = SplitFunctor { unSplitF :: Either (g x) (f x) } deriving (Eq, Show)
+
+instance (Functor f, Functor g) => Functor (SplitFunctor g f) where
+
+instance (Foldable f, Foldable g) => Foldable (SplitFunctor g f) where
+
+instance (Traversable f, Traversable g) => Traversable (SplitFunctor g f) where
+
+type SuperExpr f = EnhancedExpr (SplitFunctor f SuperPositionF)
+
+type AbortExpr f = SuperExpr (SplitFunctor f AbortableF)
+
+type BreakExtras = ()
+
+data UnsizedRecursionF f
+ = UnsizedRecursionF BreakExtras f
+ | UnsizedBarrierF f
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+type UnsizedExpr = AbortExpr UnsizedRecursionF
+
+cata :: Recursive t => (Base t a -> a) -> t -> a
+cata = undefined
+
+sizeTerm :: UnsizedExpr -> Maybe (AbortExpr VoidF)
+sizeTerm term =
+ let sizingTerm = eval term
+ eval :: UnsizedExpr -> UnsizedExpr
+ eval = undefined
+ setSizes sizes = cata $ \case
+ UnsizedFW (UnsizedRecursionF be env) -> BasicExpr ZeroSF
+ clean = undefined
+ hoist = undefined
+ maybeSized = pure sizingTerm
+ in hoist clean <$> maybeSized
+
+
=====================================
testsuite/tests/typecheck/should_fail/T21583.stderr
=====================================
@@ -0,0 +1,22 @@
+T21583.hs:14:23: error: [-Wstar-is-type (in -Wall, -Wcompat), -Werror=star-is-type]
+ Using ‘*’ (or its Unicode variant) to mean ‘Data.Kind.Type’
+ relies on the StarIsType extension, which will become
+ deprecated in the future.
+ Suggested fix: Use ‘Type’ from ‘Data.Kind’ instead.
+T21583.hs:14:28: error: [-Wstar-is-type (in -Wall, -Wcompat), -Werror=star-is-type]
+ Using ‘*’ (or its Unicode variant) to mean ‘Data.Kind.Type’
+ relies on the StarIsType extension, which will become
+ deprecated in the future.
+ Suggested fix: Use ‘Type’ from ‘Data.Kind’ instead.
+T21583.hs:56:10: warning: [-Wmissing-methods (in -Wdefault)]
+ • No explicit implementation for
+ ‘fmap’
+ • In the instance declaration for ‘Functor (SplitFunctor g f)’
+T21583.hs:58:10: warning: [-Wmissing-methods (in -Wdefault)]
+ • No explicit implementation for
+ either ‘foldMap’ or ‘foldr’
+ • In the instance declaration for ‘Foldable (SplitFunctor g f)’
+T21583.hs:60:10: warning: [-Wmissing-methods (in -Wdefault)]
+ • No explicit implementation for
+ either ‘traverse’ or ‘sequenceA’
+ • In the instance declaration for ‘Traversable (SplitFunctor g f)’
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -657,3 +657,4 @@ test('T20768_fail', normal, compile_fail, [''])
test('T21327', normal, compile_fail, [''])
test('T21338', normal, compile_fail, [''])
test('T21158', normal, compile_fail, [''])
+test('T21583', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d2a1257ad73f2aa8b80e21303738d84e6b9c8b5...dd7a14e5cb04e9a65e212f56f62896adeb95dde7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d2a1257ad73f2aa8b80e21303738d84e6b9c8b5...dd7a14e5cb04e9a65e212f56f62896adeb95dde7
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/20220818/bb597a40/attachment-0001.html>
More information about the ghc-commits
mailing list