[Git][ghc/ghc][wip/andreask/bound_cmm_folding] 3 commits: Include diagnostic reason in -fdiagnostics-as-json
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Tue Nov 19 12:39:13 UTC 2024
Andreas Klebinger pushed to branch wip/andreask/bound_cmm_folding at Glasgow Haskell Compiler / GHC
Commits:
831aab22 by sheaf at 2024-11-18T21:22:36-05:00
Include diagnostic reason in -fdiagnostics-as-json
This commit ensures that the -fdiagnostics-as-json output includes the
diagnostic reason. This allows the full error message produced by GHC
to be re-constructed from the JSON output.
Fixes #25403
- - - - -
3e5bfdd3 by Ben Gamari at 2024-11-18T21:23:12-05:00
rts: Introduce printIPE
This is a convenience utility for use in GDB.
- - - - -
81468057 by Andreas Klebinger at 2024-11-19T13:18:46+01:00
Cmm constant folding: Narrow results to operations bitwidth.
When constant folding ensure the result is still within bounds
for the given type by explicitly narrowing the results.
Not doing so results in a lot of spurious assembler warnings
especially when testing primops.
- - - - -
13 changed files:
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Unit/Module/Warnings.hs
- + docs/users_guide/diagnostics-as-json-schema-1_1.json
- docs/users_guide/using.rst
- rts/IPE.c
- rts/include/rts/IPE.h
- + testsuite/tests/cmm/opt/T24556.cmm
- testsuite/tests/cmm/opt/all.T
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.hs
- testsuite/tests/driver/json_warn.stderr
Changes:
=====================================
compiler/GHC/Cmm/Opt.hs
=====================================
@@ -49,6 +49,7 @@ constantFoldExprOpt e = wrapRecExpOpt f e
CmmMachOp op' args' -> fromMaybe (CmmMachOp op' args') <$> cmmMachOpFoldOptM cfg op' args'
e -> pure e
f (CmmRegOff r 0) = pure (CmmReg r)
+ f (CmmLit (CmmInt x rep)) = pure (CmmLit $ CmmInt (narrowU rep x) rep)
f e = pure e
constantFoldExpr :: Platform -> CmmExpr -> CmmExpr
@@ -88,7 +89,7 @@ cmmMachOpFoldM _ (MO_VF_Broadcast lg _w) exprs =
_ -> Nothing
cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
= Just $! case op of
- MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)
+ MO_S_Neg _ -> CmmLit (CmmInt (narrowS rep (-x)) rep)
MO_Not _ -> CmmLit (CmmInt (complement x) rep)
-- these are interesting: we must first narrow to the
@@ -164,9 +165,9 @@ cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
MO_S_Lt _ -> Just $! CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth platform))
MO_S_Le _ -> Just $! CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform))
- MO_Add r -> Just $! CmmLit (CmmInt (x + y) r)
- MO_Sub r -> Just $! CmmLit (CmmInt (x - y) r)
- MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r)
+ MO_Add r -> Just $! CmmLit (CmmInt (narrowU r $ x + y) r)
+ MO_Sub r -> Just $! CmmLit (CmmInt (narrowS r $ x - y) r)
+ MO_Mul r -> Just $! CmmLit (CmmInt (narrowU r $ x * y) r)
MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r)
MO_U_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem` y_u) r)
MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `quot` y_s) r)
@@ -176,7 +177,7 @@ cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
MO_Or r -> Just $! CmmLit (CmmInt (x .|. y) r)
MO_Xor r -> Just $! CmmLit (CmmInt (x `xor` y) r)
- MO_Shl r -> Just $! CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
+ MO_Shl r -> Just $! CmmLit (CmmInt (narrowU r $ x `shiftL` fromIntegral y) r)
MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
MO_S_Shr r -> Just $! CmmLit (CmmInt (x_s `shiftR` fromIntegral y) r)
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -100,19 +100,23 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Hint
import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
+
+import GHC.Types.Hint.Ppr () -- Outputable instance
+import GHC.Unit.Module.Warnings (WarningCategory(..))
+
import GHC.Utils.Json
import GHC.Utils.Panic
-import GHC.Unit.Module.Warnings (WarningCategory)
+
+import GHC.Version (cProjectVersion)
import Data.Bifunctor
import Data.Foldable ( fold, toList )
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
+import Data.Maybe ( maybeToList )
import Data.Typeable ( Typeable )
import Numeric.Natural ( Natural )
import Text.Printf ( printf )
-import GHC.Version (cProjectVersion)
-import GHC.Types.Hint.Ppr () -- Outputtable instance
{- Note [Messages]
~~~~~~~~~~~~~~~~~~
@@ -393,10 +397,8 @@ newtype ResolvedDiagnosticReason
pattern WarningWithFlag :: WarningFlag -> DiagnosticReason
pattern WarningWithFlag w = WarningWithFlags (w :| [])
-{-
-Note [Warnings controlled by multiple flags]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
+{- Note [Warnings controlled by multiple flags]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Diagnostics that started life as flag-controlled warnings have a
'diagnosticReason' of 'WarningWithFlags', giving the flags that control the
warning. Usually there is only one flag, but in a few cases multiple flags
@@ -563,11 +565,11 @@ instance ToJson DiagnosticCode where
{- Note [Diagnostic Message JSON Schema]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The below instance of ToJson must conform to the JSON schema
-specified in docs/users_guide/diagnostics-as-json-schema-1_0.json.
+specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
When the schema is altered, please bump the version.
If the content is altered in a backwards compatible way,
update the minor version (e.g. 1.3 ~> 1.4).
-If the content is breaking, update the major version (e.g. 1.3 ~> 2.3).
+If the content is breaking, update the major version (e.g. 1.3 ~> 2.0).
When updating the schema, replace the above file and name it appropriately with
the version appended, and change the documentation of the -fdiagnostics-as-json
flag to reflect the new schema.
@@ -576,25 +578,41 @@ https://json-schema.org
-}
schemaVersion :: String
-schemaVersion = "1.0"
+schemaVersion = "1.1"
-- See Note [Diagnostic Message JSON Schema] before editing!
instance Diagnostic e => ToJson (MsgEnvelope e) where
- json m = JSObject [
+ json m = JSObject $ [
("version", JSString schemaVersion),
("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
("span", json $ errMsgSpan m),
("severity", json $ errMsgSeverity m),
("code", maybe JSNull json (diagnosticCode diag)),
("message", JSArray $ map renderToJSString diagMsg),
- ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) )
- ]
- where diag = errMsgDiagnostic m
- opts = defaultDiagnosticOpts @e
- style = mkErrStyle (errMsgContext m)
- ctx = defaultSDocContext {sdocStyle = style }
- diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag))
- renderToJSString :: SDoc -> JsonDoc
- renderToJSString = JSString . (renderWithContext ctx)
+ ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ]
+ ++ [ ("reason", reasonJson)
+ | reasonJson <- maybeToList $ usefulReasonJson_maybe (errMsgReason m) ]
+ where
+ diag = errMsgDiagnostic m
+ opts = defaultDiagnosticOpts @e
+ style = mkErrStyle (errMsgContext m)
+ ctx = defaultSDocContext {sdocStyle = style }
+ diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag))
+ renderToJSString :: SDoc -> JsonDoc
+ renderToJSString = JSString . (renderWithContext ctx)
+
+ usefulReasonJson_maybe :: ResolvedDiagnosticReason -> Maybe JsonDoc
+ usefulReasonJson_maybe (ResolvedDiagnosticReason rea) =
+ case rea of
+ WarningWithoutFlag -> Nothing
+ ErrorWithoutFlag -> Nothing
+ WarningWithFlags flags ->
+ Just $ JSObject
+ [ ("flags", JSArray $ map (JSString . NE.head . warnFlagNames) (NE.toList flags))
+ ]
+ WarningWithCategory (WarningCategory cat) ->
+ Just $ JSObject
+ [ ("category", JSString $ unpackFS cat)
+ ]
instance Show (MsgEnvelope DiagnosticMessage) where
show = showMsgEnvelope
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -130,7 +131,8 @@ fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc)
-- See Note [Warning categories]
newtype WarningCategory = WarningCategory FastString
- deriving (Binary, Data, Eq, Outputable, Show, Uniquable, NFData)
+ deriving stock Data
+ deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData)
mkWarningCategory :: FastString -> WarningCategory
mkWarningCategory = WarningCategory
=====================================
docs/users_guide/diagnostics-as-json-schema-1_1.json
=====================================
@@ -0,0 +1,134 @@
+{
+ "$schema": "https://json-schema.org/draft/2020-12/schema",
+ "title": "JSON Diagnostic Schema",
+ "description": "A Schema for specifying GHC diagnostics output as JSON",
+ "type": "object",
+ "properties": {
+ "version": {
+ "description": "The current JSON schema version this object conforms to",
+ "type": "string"
+ },
+ "ghcVersion": {
+ "description": "The GHC version",
+ "type": "string"
+ },
+ "span": {
+ "$ref": "#/$defs/span"
+ },
+ "severity": {
+ "description": "The diagnostic severity",
+ "type": "string",
+ "enum": [
+ "Warning",
+ "Error"
+ ]
+ },
+ "code": {
+ "description": "The diagnostic code (if it exists)",
+ "type": [
+ "integer",
+ "null"
+ ]
+ },
+ "message": {
+ "description": "The string output of the diagnostic message by GHC",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "hints": {
+ "description": "The suggested fixes",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "reason" : {
+ "description": "The GHC flag that was responsible for the emission of the diagnostic message",
+ "oneOf": [
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by one or more GHC flags",
+ "properties": {
+ "flags": {
+ "type": "array",
+ "items": {
+ "description": "The name of a GHC flag controlling the diagnostic message",
+ "type": "string"
+ },
+ "minItems": 1
+ }
+ },
+ "required": ["flags"]
+ },
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by a GHC diagnostic message category",
+ "properties": {
+ "category": {
+ "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
+ "type": "string"
+ }
+ },
+ "required": ["category"]
+ }
+ ]
+ }
+ },
+ "required": [
+ "version",
+ "ghcVersion",
+ "span",
+ "severity",
+ "code",
+ "message",
+ "hints"
+ ],
+ "additionalProperties": false,
+ "$defs": {
+ "span": {
+ "description": "The span of the diagnostic",
+ "type": "object",
+ "properties": {
+ "file": {
+ "description": "The file in which the diagnostic occurs",
+ "type": "string"
+ },
+ "start": {
+ "description": "The start location of the diagnostic",
+ "$ref": "#/$defs/location"
+ },
+ "end": {
+ "description": "The end location of the diagnostic",
+ "$ref": "#/$defs/location"
+ }
+ },
+ "required": [
+ "file",
+ "start",
+ "end"
+ ],
+ "additionalProperties": false
+ },
+ "location": {
+ "description": "A location in a text file",
+ "type": "object",
+ "properties": {
+ "line": {
+ "description": "The line number",
+ "type": "integer"
+ },
+ "column": {
+ "description": "The column number",
+ "type": "integer"
+ }
+ },
+ "required": [
+ "line",
+ "column"
+ ],
+ "additionalProperties": false
+ }
+ }
+}
=====================================
docs/users_guide/using.rst
=====================================
@@ -1424,7 +1424,7 @@ messages and in GHCi:
a new line.
The structure of the output is described by a `JSON Schema <https://json-schema.org/>`_.
- The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_0.json>`.
+ The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_1.json>`.
.. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
:shortdesc: Use colors in error messages
=====================================
rts/IPE.c
=====================================
@@ -277,3 +277,20 @@ void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode *node) {
}
}
+
+#if defined(DEBUG)
+void printIPE(const StgInfoTable *info) {
+ InfoProvEnt ipe;
+ if (lookupIPE(info, &ipe)) {
+ debugBelch("%p:\n", info);
+ debugBelch(" name: %s\n", ipe.prov.table_name);
+ debugBelch(" desc: %" PRIu32 "\n", ipe.prov.closure_desc);
+ debugBelch(" type: %s\n", ipe.prov.ty_desc);
+ debugBelch(" label: %s\n", ipe.prov.label);
+ debugBelch(" module: %s:%s\n", ipe.prov.unit_id, ipe.prov.module);
+ debugBelch(" src loc: %s:%s\n", ipe.prov.src_file, ipe.prov.src_span);
+ } else {
+ debugBelch("%p: no IPE entry\n", info);
+ }
+}
+#endif
=====================================
rts/include/rts/IPE.h
=====================================
@@ -97,3 +97,7 @@ void formatClosureDescIpe(const InfoProvEnt *ipe_buf, char *str_buf);
// Returns true on success, initializes `out`.
bool lookupIPE(const StgInfoTable *info, InfoProvEnt *out);
+
+#if defined(DEBUG)
+void printIPE(const StgInfoTable *info);
+#endif
=====================================
testsuite/tests/cmm/opt/T24556.cmm
=====================================
@@ -0,0 +1,12 @@
+#include "Cmm.h"
+
+func(W_ buffer) {
+ I8[buffer] = %lobits8(255 + 45);
+ I8[buffer+(1)] = %lobits8(310 - 10);
+ I8[buffer+(2)] = %lobits8(30 * 10);
+ I8[buffer+(3)] = %lobits8(150 << 1);
+ // This one comes from test-primops
+ I64[buffer+(4)] = %zx64(((1 :: bits16) & ((1 :: bits16) & (((516 :: bits16) * (154 :: bits16)) + bits16[buffer + (0 :: bits64)]))));
+ return(1);
+}
+
=====================================
testsuite/tests/cmm/opt/all.T
=====================================
@@ -3,3 +3,8 @@
test('T15188', cmm_src, makefile_test, [])
test('T18141', normal, compile, [''])
test('T20142', normal, compile, [''])
+
+# Cmm opt should not produce oversized literals in the assembly output.
+# We check this by telling the assembler to exit on warnings.
+test('T24556', [only_ways('optasm'), cmm_src], compile, ['-O -opta -Xassembler -opta --fatal-warnings'])
+
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -276,7 +276,7 @@ test('T12955', normal, makefile_test, [])
test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, [])
test('json_dump', normal, compile_fail, ['-ddump-json'])
test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json'])
-test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches'])
+test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial'])
test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version'])
test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command,
['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs'])
=====================================
testsuite/tests/driver/json.stderr
=====================================
@@ -1 +1 @@
-{"version":"1.0","ghcVersion":"ghc-9.11.20240329","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the `EmptyCase' extension"]}
+{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the `EmptyCase' extension"]}
=====================================
testsuite/tests/driver/json_warn.hs
=====================================
@@ -2,3 +2,6 @@ module Foo where
f :: Int -> Int
f x = 5
+
+g :: [a] -> a
+g = head
=====================================
testsuite/tests/driver/json_warn.stderr
=====================================
@@ -1 +1,2 @@
-{"version":"1.0","ghcVersion":"ghc-9.9.20230817","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: `x'"],"hints":[]}
+{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: `x'"],"hints":[],"reason":{"flags":["unused-matches"]}}
+{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of `head'\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0650956237454b4f3beea67145d71cdea977ff1c...81468057c2cc66d1159669ad7da0b371799d641e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0650956237454b4f3beea67145d71cdea977ff1c...81468057c2cc66d1159669ad7da0b371799d641e
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/20241119/04a84edb/attachment-0001.html>
More information about the ghc-commits
mailing list