[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: TNTC: set CmmProc entry_label properly (#25565)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Dec 14 22:08:20 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
62a2b25f by Sylvain Henry at 2024-12-14T04:31:09-05:00
TNTC: set CmmProc entry_label properly (#25565)
Before this patch we were renaming the entry label of a CmmProc late in
the CmmToAsm pass. It led to inconsistencies and to some labels being
used in info tables but not being emitted (#25565).
Now we set the CmmProc entry label earlier in the StgToCmm monad and we
don't renamed it afterwards.
- - - - -
b339e7c3 by Simon Hengel at 2024-12-14T04:31:47-05:00
Make filter functionality for system tools line-based
This is more efficient as:
- All existing filter functions were line-based anyway. They broke up
the input into lines and then joined it back together.
- We already break up the output from system tools into lines when
processing it.
Splitting up the output of system tools once and then filtering and
processing it reduces both code and runtime complexity.
- - - - -
39669077 by Simon Hengel at 2024-12-14T04:31:47-05:00
Refactoring: Don't use a `Chan` when parsing SysTools output
- - - - -
54207750 by Simon Peyton Jones at 2024-12-14T17:07:56-05:00
Tidy up the handling of `assert`
Fixes #25493
- - - - -
d6f995b8 by Rodrigo Mesquita at 2024-12-14T17:07:57-05:00
base: displayException for SomeAsyncException
Provide a better implementation of `SomeException` for
`SomeAsyncException`.
The previous, implicit, implementation, would not use the
`displayException` of the exception wrapped by `SomeAsyncException`.
Implements CLC-Proposal#309
Closes #25513
- - - - -
10 changed files:
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Driver/Config/Linker.hs
- compiler/GHC/Linker/Config.hs
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/SysTools/Process.hs
- compiler/GHC/SysTools/Tasks.hs
- compiler/GHC/Tc/Gen/Head.hs
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -76,14 +76,11 @@ pprNatCmmDecl config proc@(CmmProc top_info entry_lbl _ (ListGraph blocks)) =
let platform = ncgPlatform config
top_info_table = topInfoTable proc
-- we need a label to delimit the proc code (e.g. in debug builds). When
- -- we have an info table, we reuse the info table label. Otherwise we make
- -- a fresh "entry" label from the label of the entry block. We can't reuse
- -- the entry block label as-is, otherwise we get redundant labels:
- -- delimiters for the entry block and for the whole proc are the same (see
- -- #22792).
+ -- we have an info table, we reuse the info table label. Otherwise we use
+ -- the entry label.
proc_lbl = case top_info_table of
Just (CmmStaticsRaw info_lbl _) -> info_lbl
- Nothing -> toProcDelimiterLbl entry_lbl
+ Nothing -> entry_lbl
-- handle subsections_via_symbols when enabled and when we have an
-- info-table to link to. See Note [Subsections Via Symbols]
=====================================
compiler/GHC/Driver/Config/Linker.hs
=====================================
@@ -27,9 +27,8 @@ initLinkerConfig dflags =
ld_filter = case platformOS (targetPlatform dflags) of
OSSolaris2 -> sunos_ld_filter
_ -> id
- sunos_ld_filter :: String -> String
- sunos_ld_filter = unlines . sunos_ld_filter' . lines
- sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
+ sunos_ld_filter :: [String] -> [String]
+ sunos_ld_filter x = if (undefined_found x && ld_warning_found x)
then (ld_prefix x) ++ (ld_postfix x)
else x
breakStartsWith x y = break (isPrefixOf x) y
=====================================
compiler/GHC/Linker/Config.hs
=====================================
@@ -22,6 +22,6 @@ data LinkerConfig = LinkerConfig
, linkerOptionsPre :: [Option] -- ^ Linker options (before user options)
, linkerOptionsPost :: [Option] -- ^ Linker options (after user options)
, linkerTempDir :: TempDir -- ^ Temporary directory to use
- , linkerFilter :: String -> String -- ^ Output filter
+ , linkerFilter :: [String] -> [String] -- ^ Output filter
}
=====================================
compiler/GHC/StgToCmm/Monad.hs
=====================================
@@ -798,7 +798,17 @@ emitProc mb_info lbl live blocks offset do_layout
tinfo = TopInfo { info_tbls = DWrap infos
, stack_info=sinfo}
- proc_block = CmmProc tinfo lbl live blks
+ -- we must be careful to:
+ -- 1. not emit a proc label twice (#22792)
+ -- 2. emit it at least once! (#25565)
+ --
+ -- (2) happened because the entry label was the label of a basic
+ -- block that got dropped (empty basic block...), hence we never
+ -- generated a label for it after we fixed (1) where we were
+ -- always emitting entry label.
+ proc_lbl = toProcDelimiterLbl lbl
+
+ proc_block = CmmProc tinfo proc_lbl live blks
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
=====================================
compiler/GHC/SysTools/Process.hs
=====================================
@@ -149,7 +149,7 @@ runSomethingResponseFile
:: Logger
-> TmpFs
-> TempDir
- -> (String->String)
+ -> ([String] -> [String])
-> String
-> String
-> [Option]
@@ -195,7 +195,7 @@ runSomethingResponseFile logger tmpfs tmp_dir filter_fn phase_name pgm args mb_e
]
runSomethingFiltered
- :: Logger -> (String->String) -> String -> String -> [Option]
+ :: Logger -> ([String] -> [String]) -> String -> String -> [Option]
-> Maybe FilePath -> Maybe [(String,String)] -> IO ()
runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env =
@@ -235,7 +235,7 @@ withPipe = bracket createPipe $ \ (readEnd, writeEnd) -> do
hClose readEnd
hClose writeEnd
-builderMainLoop :: Logger -> (String -> String) -> FilePath
+builderMainLoop :: Logger -> ([String] -> [String]) -> FilePath
-> [String] -> Maybe FilePath -> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (readEnd, writeEnd) -> do
@@ -245,13 +245,11 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
associateHandle' =<< handleToHANDLE readEnd
#endif
- chan <- newChan
-
-- We use a mask here rather than a bracket because we want
-- to distinguish between cleaning up with and without an
-- exception. This is to avoid calling terminateProcess
-- unless an exception was raised.
- let safely inner = mask $ \restore -> do
+ mask $ \restore -> do
-- acquire
-- On Windows due to how exec is emulated the old process will exit and
-- a new process will be created. This means waiting for termination of
@@ -282,9 +280,9 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
getLocaleEncoding >>= hSetEncoding readEnd
hSetNewlineMode readEnd nativeNewlineMode
hSetBuffering readEnd LineBuffering
- let make_reader_proc h = forkIO $ readerProc chan h filter_fn
- bracketOnError (make_reader_proc readEnd) killThread $ \_ ->
- inner hProcess
+ messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd
+ mapM_ processBuildMessage messages
+ waitForProcess hProcess
hClose hStdIn
case r of
Left (SomeException e) -> do
@@ -292,70 +290,55 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
throw e
Right s -> do
return s
- safely $ \h -> do
- processBuildMessages chan
- waitForProcess h
where
- processBuildMessages :: Chan BuildMessage -> IO ()
- processBuildMessages chan = do
- msg <- readChan chan
+ processBuildMessage :: BuildMessage -> IO ()
+ processBuildMessage msg = do
case msg of
BuildMsg msg -> do
logInfo logger $ withPprStyle defaultUserStyle msg
- processBuildMessages chan
BuildError loc msg -> do
logMsg logger errorDiagnostic (mkSrcSpan loc loc)
$ withPprStyle defaultUserStyle msg
- processBuildMessages chan
- EOF ->
- return ()
-
-readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
-readerProc chan hdl filter_fn =
- (do str <- hGetContents hdl
- loop (lines (filter_fn str)) Nothing)
- `finally`
- writeChan chan EOF
- -- ToDo: check errors more carefully
- -- ToDo: in the future, the filter should be implemented as
- -- a stream transformer.
+
+parseBuildMessages :: [String] -> [BuildMessage]
+parseBuildMessages str = loop str Nothing
where
- loop [] Nothing = return ()
- loop [] (Just err) = writeChan chan err
+ loop :: [String] -> Maybe BuildMessage -> [BuildMessage]
+ loop [] Nothing = []
+ loop [] (Just err) = [err]
loop (l:ls) in_err =
case in_err of
Just err@(BuildError srcLoc msg)
| leading_whitespace l ->
loop ls (Just (BuildError srcLoc (msg $$ text l)))
- | otherwise -> do
- writeChan chan err
- checkError l ls
+ | otherwise ->
+ err : checkError l ls
Nothing ->
checkError l ls
- _ -> panic "readerProc/loop"
+ _ -> panic "parseBuildMessages/loop"
+ checkError :: String -> [String] -> [BuildMessage]
checkError l ls
= case parseError l of
- Nothing -> do
- writeChan chan (BuildMsg (text l))
- loop ls Nothing
- Just (file, lineNum, colNum, msg) -> do
- let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
+ Nothing ->
+ BuildMsg (text l) : loop ls Nothing
+ Just (srcLoc, msg) -> do
loop ls (Just (BuildError srcLoc (text msg)))
+ leading_whitespace :: String -> Bool
leading_whitespace [] = False
leading_whitespace (x:_) = isSpace x
-parseError :: String -> Maybe (String, Int, Int, String)
+parseError :: String -> Maybe (SrcLoc, String)
parseError s0 = case breakColon s0 of
Just (filename, s1) ->
case breakIntColon s1 of
Just (lineNum, s2) ->
case breakIntColon s2 of
Just (columnNum, s3) ->
- Just (filename, lineNum, columnNum, s3)
+ Just (mkSrcLoc (mkFastString filename) lineNum columnNum, s3)
Nothing ->
- Just (filename, lineNum, 0, s2)
+ Just (mkSrcLoc (mkFastString filename) lineNum 0, s2)
Nothing -> Nothing
Nothing -> Nothing
@@ -385,4 +368,3 @@ breakIntColon xs = case break (':' ==) xs of
data BuildMessage
= BuildMsg !SDoc
| BuildError !SrcLoc !SDoc
- | EOF
=====================================
compiler/GHC/SysTools/Tasks.hs
=====================================
@@ -63,8 +63,8 @@ augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirecto
augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)
-- | Discard some harmless warnings from gcc that we can't turn off
-cc_filter :: String -> String
-cc_filter = unlines . doFilter . lines where
+cc_filter :: [String] -> [String]
+cc_filter = doFilter where
{-
gcc gives warnings in chunks like so:
In file included from /foo/bar/baz.h:11,
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -805,32 +805,22 @@ tcCheckId name res_ty
tcInferId :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
-- Look up an occurrence of an Id
-- Do not instantiate its type
-tcInferId lname@(L _ id_name)
+tcInferId lname@(L loc id_name)
+
| id_name `hasKey` assertIdKey
- = do { dflags <- getDynFlags
+ = -- See Note [Overview of assertions]
+ do { dflags <- getDynFlags
; if gopt Opt_IgnoreAsserts dflags
then tc_infer_id lname
- else tc_infer_assert lname }
+ else tc_infer_id (L loc assertErrorName) }
| otherwise
- = do { (expr, ty) <- tc_infer_id lname
- ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
- ; return (expr, ty) }
-
-tc_infer_assert :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
--- Deal with an occurrence of 'assert'
--- See Note [Adding the implicit parameter to 'assert']
-tc_infer_assert (L loc assert_name)
- = do { assert_error_id <- tcLookupId assertErrorName
- ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
- (idType assert_error_id)
- ; return (mkHsWrap wrap (HsVar noExtField (L loc assert_error_id)), id_rho)
- }
+ = tc_infer_id lname
tc_infer_id :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id (L loc id_name)
= do { thing <- tcLookup id_name
- ; case thing of
+ ; (expr,ty) <- case thing of
ATcId { tct_id = id }
-> do { check_local_id id
; return_id id }
@@ -845,12 +835,45 @@ tc_infer_id (L loc id_name)
(tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc)
ATyVar name _ -> failIllegalTyVal name
- _ -> failWithTc $ TcRnExpectedValueId thing }
+ _ -> failWithTc $ TcRnExpectedValueId thing
+
+ ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
+ ; return (expr, ty) }
where
return_id id = return (HsVar noExtField (L loc id), idType id)
-{- Note [Suppress hints with RequiredTypeArguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Overview of assertions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you write (assert pred x) then
+
+ * If `-fignore-asserts` (which sets Opt_IgnoreAsserts) is on, the code is
+ typechecked as written, but `assert`, defined in GHC.Internal.Base
+ assert _pred r = r
+ simply ignores `pred`
+
+ * But without `-fignore-asserts`, GHC rewrites it to (assertError pred e)
+ and that is defined in GHC.Internal.IO.Exception as
+ assertError :: (?callStack :: CallStack) => Bool -> a -> a
+ which does test the predicate and, if it is not True, throws an exception,
+ capturing the CallStack.
+
+ This rewrite is done in `tcInferId`.
+
+So `-fignore-asserts` makes the assertion go away altogether, which may be good for
+production code.
+
+The reason that `assert` and `assertError` are defined in very different modules
+is a historical accident.
+
+Note: the Haddock for `assert` is on `GHC.Internal.Base.assert`, since that is
+what appears in the user's source proram.
+
+It's not entirely kosher to rewrite `assert` to `assertError`, because there's no
+way to "undo" if you want to see the original source code in the typechecker
+output. We can fix this if it becomes a problem.
+
+Note [Suppress hints with RequiredTypeArguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When a type variable is used at the term level, GHC assumes the user might
have made a typo and suggests a term variable with a similar name.
@@ -948,16 +971,8 @@ tcInferPatSyn ps
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr = TcRnPatSynNotBidirectional
-{- Note [Adding the implicit parameter to 'assert']
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The typechecker transforms (assert e1 e2) to (assertError e1 e2).
-This isn't really the Right Thing because there's no way to "undo"
-if you want to see the original source code in the typechecker
-output. We'll have fix this in due course, when we care more about
-being able to reconstruct the exact original program.
-
-Note [Typechecking data constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Typechecking data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As per Note [Polymorphisation of linear fields] in
GHC.Core.Multiplicity, linear fields of data constructors get a
polymorphic multiplicity when the data constructor is used as a term:
=====================================
libraries/base/changelog.md
=====================================
@@ -1,6 +1,8 @@
# Changelog for [`base` package](http://hackage.haskell.org/package/base)
## 4.22.0.0 *TBA*
+ * Define `displayException` of `SomeAsyncException` to unwrap the exception.
+ ([CLC proposal #309](https://github.com/haskell/core-libraries-committee/issues/309))
* Restrict `Data.List.NonEmpty.unzip` to `NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)`. ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86))
* Modify the implementation of `Control.Exception.throw` to avoid call-sites being inferred as diverging via precise exception.
([GHC #25066](https://gitlab.haskell.org/ghc/ghc/-/issues/25066), [CLC proposal #290](https://github.com/haskell/core-libraries-committee/issues/290))
=====================================
libraries/ghc-internal/src/GHC/Internal/Base.hs
=====================================
@@ -2107,6 +2107,9 @@ id x = x
-- Assertion function. This simply ignores its boolean argument.
-- The compiler may rewrite it to @('assertError' line)@.
+-- The Haddock below is attached to `assert`, since that is
+-- what occurs in source programs.
+-- See Note [Overview of assertions] in GHC.Tc.Gen.Head
-- | If the first argument evaluates to 'True', then the result is the
-- second argument. Otherwise an 'Control.Exception.AssertionFailed' exception
@@ -2115,14 +2118,9 @@ id x = x
--
-- Assertions can normally be turned on or off with a compiler flag
-- (for GHC, assertions are normally on unless optimisation is turned on
--- with @-O@ or the @-fignore-asserts@
--- option is given). When assertions are turned off, the first
--- argument to 'assert' is ignored, and the second argument is
--- returned as the result.
-
--- SLPJ: in 5.04 etc 'assert' is in GHC.Prim,
--- but from Template Haskell onwards it's simply
--- defined here in Base.hs
+-- with @-O@ or the @-fignore-asserts@ option is given). When assertions
+-- are turned off, the first argument to 'assert' is ignored, and the second
+-- argument is returned as the result.
assert :: Bool -> a -> a
assert _pred r = r
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
=====================================
@@ -187,7 +187,8 @@ instance Show SomeAsyncException where
showsPrec p (SomeAsyncException e) = showsPrec p e
-- | @since base-4.7.0.0
-instance Exception SomeAsyncException
+instance Exception SomeAsyncException where
+ displayException (SomeAsyncException e) = displayException e
-- | @since base-4.7.0.0
asyncExceptionToException :: Exception e => e -> SomeException
@@ -438,6 +439,7 @@ instance Show IOException where
_ -> showString " (" . showString s . showString ")")
assertError :: (?callStack :: CallStack) => Bool -> a -> a
+-- See Note [Overview of assertions] in GHC.Tc.Gen.Head
assertError predicate v
| predicate = v
| otherwise = lazy $ unsafeDupablePerformIO $ do -- lazy: See Note [Strictness of assertError]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c8fd6c74eb22e29f4f5397bf4deec1b6cded99f...d6f995b86abec29f058d374450036e34a1ae174a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c8fd6c74eb22e29f4f5397bf4deec1b6cded99f...d6f995b86abec29f058d374450036e34a1ae174a
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/20241214/9a1dc9ba/attachment-0001.html>
More information about the ghc-commits
mailing list