[Git][ghc/ghc][wip/t25571] 4 commits: Cmm: Add surface syntax for Word/Float bitcast ops
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Mar 7 13:48:52 UTC 2025
Matthew Pickering pushed to branch wip/t25571 at Glasgow Haskell Compiler / GHC
Commits:
1d4c9824 by Matthew Craven at 2025-03-06T18:11:59-05:00
Cmm: Add surface syntax for Word/Float bitcast ops
- - - - -
25c4a2a2 by Matthew Craven at 2025-03-06T18:11:59-05:00
Cmm: Add constant-folding for Word->Float bitcasts
- - - - -
30bdea67 by Matthew Craven at 2025-03-06T18:11:59-05:00
Add tests for #25771
- - - - -
44bf5fa1 by Matthew Pickering at 2025-03-07T13:48:18+00:00
iface: Store flags in interface files
When reporting the reason why a module is recompiled (using
`-dump-hi-diffs`), it is much more informative to inform the user about
which flag exactly has changed, rather than just an opaque reference to
a hash.
Now, when the user enables `-fwrite-if-self-recomp-flags`
there is a difference the precise part of the flags is
reported:
```
codegen flags changed:
before: [Opt_NoTypeableBinds, Opt_OmitYields]
after: [Opt_NoTypeableBinds, Opt_OmitYields, Opt_DictsStrict]
```
Fixes #25571
- - - - -
24 changed files:
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Core/Opt/CallerCC/Types.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- + compiler/GHC/Driver/IncludeSpecs.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Env.hs
- + compiler/GHC/Iface/Flags.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Types/ProfAuto.hs
- compiler/GHC/Types/SafeHaskell.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/ghc.cabal.in
- docs/users_guide/phases.rst
- + testsuite/tests/cmm/opt/T25771.cmm
- + testsuite/tests/cmm/opt/T25771.stderr
- testsuite/tests/cmm/opt/all.T
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/Cmm/Opt.hs
=====================================
@@ -19,9 +19,11 @@ import GHC.Cmm
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Utils.Outputable
import GHC.Platform
import Data.Maybe
+import GHC.Float
constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x
@@ -63,24 +65,51 @@ cmmMachOpFoldM _ (MO_VF_Broadcast lg _w) exprs =
[CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l)
_ -> Nothing
cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
- = case op of
- MO_S_Neg _ -> Just $! CmmLit (CmmInt (narrowS rep (-x)) rep)
- MO_Not _ -> Just $! CmmLit (CmmInt (complement x) rep)
+ | MO_WF_Bitcast width <- op = case width of
+ W32 | res <- castWord32ToFloat (fromInteger x)
+ -- Since we store float literals as Rationals
+ -- we must check for the usual tricky cases first
+ , not (isNegativeZero res || isNaN res || isInfinite res)
+ -- (round-tripping subnormals is not a problem)
+ , !res_rat <- toRational res
+ -> Just (CmmLit (CmmFloat res_rat W32))
+
+ W64 | res <- castWord64ToDouble (fromInteger x)
+ -- Since we store float literals as Rationals
+ -- we must check for the usual tricky cases first
+ , not (isNegativeZero res || isNaN res || isInfinite res)
+ -- (round-tripping subnormals is not a problem)
+ , !res_rat <- toRational res
+ -> Just (CmmLit (CmmFloat res_rat W64))
+
+ _ -> Nothing
+ | otherwise
+ = Just $! case op of
+ 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
-- "from" type, in order to truncate to the correct size.
-- The final narrow/widen to the destination type
-- is implicit in the CmmLit.
- MO_SF_Round _frm to -> Just $! CmmLit (CmmFloat (fromInteger x) to)
- MO_SS_Conv from to -> Just $! CmmLit (CmmInt (narrowS from x) to)
- MO_UU_Conv from to -> Just $! CmmLit (CmmInt (narrowU from x) to)
- MO_XX_Conv from to -> Just $! CmmLit (CmmInt (narrowS from x) to)
-
- -- Not as simply as it seems, since CmmFloat uses Rational, so skipping those
- -- for now ...
- MO_WF_Bitcast _w -> Nothing
- MO_FW_Bitcast _w -> Nothing
+ MO_SF_Round _frm to -> CmmLit (CmmFloat (fromInteger x) to)
+ MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
+ MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
+ MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
+
+ MO_F_Neg{} -> invalidArgPanic
+ MO_FS_Truncate{} -> invalidArgPanic
+ MO_FF_Conv{} -> invalidArgPanic
+ MO_FW_Bitcast{} -> invalidArgPanic
+ MO_VS_Neg{} -> invalidArgPanic
+ MO_VF_Neg{} -> invalidArgPanic
+ MO_RelaxedRead{} -> invalidArgPanic
+ MO_AlignmentCheck{} -> invalidArgPanic
+
_ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op
+ where invalidArgPanic = pprPanic "cmmMachOpFoldM" $
+ text "Found" <+> pprMachOp op
+ <+> text "illegally applied to an int literal"
-- Eliminate shifts that are wider than the shiftee
cmmMachOpFoldM _ op [_shiftee, CmmLit (CmmInt shift _)]
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1109,7 +1109,10 @@ machOps = listToUFM $
( "f2i32", flip MO_FS_Truncate W32 ),
( "f2i64", flip MO_FS_Truncate W64 ),
( "i2f32", flip MO_SF_Round W32 ),
- ( "i2f64", flip MO_SF_Round W64 )
+ ( "i2f64", flip MO_SF_Round W64 ),
+
+ ( "w2f_bitcast", MO_WF_Bitcast ),
+ ( "f2w_bitcast", MO_FW_Bitcast )
]
callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
=====================================
compiler/GHC/Core/Opt/CallerCC/Types.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Types.Name hiding (varName)
import GHC.Utils.Panic
import qualified GHC.Utils.Binary as B
import Data.Char
+import Control.DeepSeq
import Language.Haskell.Syntax.Module.Name
@@ -33,6 +34,11 @@ instance Outputable NamePattern where
ppr (PWildcard rest) = char '*' <> ppr rest
ppr PEnd = Outputable.empty
+instance NFData NamePattern where
+ rnf (PChar c n) = rnf c `seq` rnf n
+ rnf (PWildcard np) = rnf np
+ rnf PEnd = ()
+
instance B.Binary NamePattern where
get bh = do
tag <- B.get bh
@@ -76,6 +82,9 @@ data CallerCcFilter
, ccfFuncName :: NamePattern
}
+instance NFData CallerCcFilter where
+ rnf (CallerCcFilter mn n) = rnf mn `seq` rnf n
+
instance Outputable CallerCcFilter where
ppr ccf =
maybe (char '*') ppr (ccfModuleName ccf)
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -102,6 +102,7 @@ import GHC.Data.Maybe
import GHC.Builtin.Names ( mAIN_NAME )
import GHC.Driver.Backend
import GHC.Driver.Flags
+import GHC.Driver.IncludeSpecs
import GHC.Driver.Phases ( Phase(..), phaseInputExt )
import GHC.Driver.Plugins.External
import GHC.Settings
@@ -922,44 +923,6 @@ data PkgDbRef
| PkgDbPath FilePath
deriving Eq
--- | Used to differentiate the scope an include needs to apply to.
--- We have to split the include paths to avoid accidentally forcing recursive
--- includes since -I overrides the system search paths. See #14312.
-data IncludeSpecs
- = IncludeSpecs { includePathsQuote :: [String]
- , includePathsGlobal :: [String]
- -- | See Note [Implicit include paths]
- , includePathsQuoteImplicit :: [String]
- }
- deriving Show
-
--- | Append to the list of includes a path that shall be included using `-I`
--- when the C compiler is called. These paths override system search paths.
-addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs
-addGlobalInclude spec paths = let f = includePathsGlobal spec
- in spec { includePathsGlobal = f ++ paths }
-
--- | Append to the list of includes a path that shall be included using
--- `-iquote` when the C compiler is called. These paths only apply when quoted
--- includes are used. e.g. #include "foo.h"
-addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs
-addQuoteInclude spec paths = let f = includePathsQuote spec
- in spec { includePathsQuote = f ++ paths }
-
--- | These includes are not considered while fingerprinting the flags for iface
--- | See Note [Implicit include paths]
-addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs
-addImplicitQuoteInclude spec paths = let f = includePathsQuoteImplicit spec
- in spec { includePathsQuoteImplicit = f ++ paths }
-
-
--- | Concatenate and flatten the list of global and quoted includes returning
--- just a flat list of paths.
-flattenIncludes :: IncludeSpecs -> [String]
-flattenIncludes specs =
- includePathsQuote specs ++
- includePathsQuoteImplicit specs ++
- includePathsGlobal specs
-- An argument to --reexported-module which can optionally specify a module renaming.
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -693,6 +693,7 @@ data GeneralFlag
| Opt_KeepAutoRules -- ^Keep auto-generated rules even if they seem to have become useless
| Opt_WriteInterface -- forces .hi files to be written even with -fno-code
| Opt_WriteSelfRecompInfo
+ | Opt_WriteSelfRecompFlags -- ^ Include detailed flag information for self-recompilation debugging
| Opt_WriteHie -- generate .hie files
-- JavaScript opts
=====================================
compiler/GHC/Driver/IncludeSpecs.hs
=====================================
@@ -0,0 +1,48 @@
+module GHC.Driver.IncludeSpecs
+ ( IncludeSpecs(..)
+ , addGlobalInclude
+ , addQuoteInclude
+ , addImplicitQuoteInclude
+ , flattenIncludes
+ ) where
+
+import GHC.Prelude
+
+-- | Used to differentiate the scope an include needs to apply to.
+-- We have to split the include paths to avoid accidentally forcing recursive
+-- includes since -I overrides the system search paths. See #14312.
+data IncludeSpecs
+ = IncludeSpecs { includePathsQuote :: [String]
+ , includePathsGlobal :: [String]
+ -- | See Note [Implicit include paths]
+ , includePathsQuoteImplicit :: [String]
+ }
+ deriving Show
+
+-- | Append to the list of includes a path that shall be included using `-I`
+-- when the C compiler is called. These paths override system search paths.
+addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs
+addGlobalInclude spec paths = let f = includePathsGlobal spec
+ in spec { includePathsGlobal = f ++ paths }
+
+-- | Append to the list of includes a path that shall be included using
+-- `-iquote` when the C compiler is called. These paths only apply when quoted
+-- includes are used. e.g. #include "foo.h"
+addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs
+addQuoteInclude spec paths = let f = includePathsQuote spec
+ in spec { includePathsQuote = f ++ paths }
+
+-- | These includes are not considered while fingerprinting the flags for iface
+-- | See Note [Implicit include paths]
+addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs
+addImplicitQuoteInclude spec paths = let f = includePathsQuoteImplicit spec
+ in spec { includePathsQuoteImplicit = f ++ paths }
+
+
+-- | Concatenate and flatten the list of global and quoted includes returning
+-- just a flat list of paths.
+flattenIncludes :: IncludeSpecs -> [String]
+flattenIncludes specs =
+ includePathsQuote specs ++
+ includePathsQuoteImplicit specs ++
+ includePathsGlobal specs
\ No newline at end of file
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2528,7 +2528,8 @@ fFlagsDeps = [
flagSpec "use-rpaths" Opt_RPath,
flagSpec "write-interface" Opt_WriteInterface,
flagSpec "write-if-simplified-core" Opt_WriteIfSimplifiedCore,
- flagSpec "write-if-self-recomp" Opt_WriteSelfRecompInfo,
+ flagSpec "write-if-self-recomp" Opt_WriteSelfRecompInfo,
+ flagSpec "write-if-self-recomp-flags" Opt_WriteSelfRecompFlags,
flagSpec "write-ide-info" Opt_WriteHie,
flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields,
flagSpec "unbox-strict-fields" Opt_UnboxStrictFields,
=====================================
compiler/GHC/Iface/Env.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.Iface.Env (
ifaceExportNames,
- trace_if, trace_hi_diffs,
+ trace_if, trace_hi_diffs, trace_hi_diffs_io,
-- Name-cache stuff
allocateGlobalBinder,
@@ -270,6 +270,12 @@ trace_if :: Logger -> SDoc -> IO ()
{-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities]
trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc
+trace_hi_diffs_io :: Logger -> IO SDoc -> IO ()
+{-# INLINE trace_hi_diffs_io #-} -- see Note [INLINE conditional tracing utilities]
+trace_hi_diffs_io logger doc =
+ when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $
+ doc >>= putMsg logger
+
trace_hi_diffs :: Logger -> SDoc -> IO ()
{-# INLINE trace_hi_diffs #-} -- see Note [INLINE conditional tracing utilities]
-trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc
+trace_hi_diffs logger doc = trace_hi_diffs_io logger (pure doc)
=====================================
compiler/GHC/Iface/Flags.hs
=====================================
@@ -0,0 +1,200 @@
+-- | Datatype definitions for the flag representation stored in interface files
+module GHC.Iface.Flags (
+ IfaceDynFlags(..)
+ , IfaceGeneralFlag(..)
+ , IfaceProfAuto(..)
+ , IfaceExtension(..)
+ , IfaceLanguage(..)
+ , IfaceCppOptions(..)
+ , pprIfaceDynFlags
+ , missingExtraFlagInfo
+ ) where
+
+import GHC.Prelude
+
+import GHC.Utils.Outputable
+import Control.DeepSeq
+import GHC.Utils.Fingerprint
+import GHC.Utils.Binary
+
+import GHC.Driver.DynFlags
+import GHC.Types.SafeHaskell
+import GHC.Core.Opt.CallerCC.Types
+
+import qualified GHC.LanguageExtensions as LangExt
+
+-- The part of DynFlags which recompilation information needs
+data IfaceDynFlags = IfaceDynFlags
+ { ifaceMainIs :: Maybe (Maybe String)
+ , ifaceSafeMode :: IfaceTrustInfo
+ , ifaceLang :: Maybe IfaceLanguage
+ , ifaceExts :: [IfaceExtension]
+ , ifaceCppOptions :: IfaceCppOptions
+ , ifaceJsOptions :: IfaceCppOptions
+ , ifaceCmmOptions :: IfaceCppOptions
+ , ifacePaths :: [String]
+ , ifaceProf :: Maybe IfaceProfAuto
+ , ifaceTicky :: [IfaceGeneralFlag]
+ , ifaceCodeGen :: [IfaceGeneralFlag]
+ , ifaceFatIface :: Bool
+ , ifaceDebugLevel :: Int
+ , ifaceCallerCCFilters :: [CallerCcFilter]
+ }
+
+pprIfaceDynFlags :: (Fingerprint, Maybe IfaceDynFlags) -> SDoc
+pprIfaceDynFlags (f, mflags) =
+ vcat $
+ [ text "fingerprint:" <+> (ppr f)
+ ]
+ ++ case mflags of
+ Nothing -> [missingExtraFlagInfo]
+ Just (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) ->
+ [ text "main-is:" <+> (ppr $ fmap (fmap (text @SDoc)) a1)
+ , text "safe-mode:" <+> ppr a2
+ , text "lang:" <+> ppr a3
+ , text "exts:" <+> ppr a4
+ , text "cpp-options:"
+ , nest 2 $ ppr a5
+ , text "js-options:"
+ , nest 2 $ ppr a6
+ , text "cmm-options:"
+ , nest 2 $ ppr a7
+ , text "paths:" <+> hcat (map text a8)
+ , text "prof:" <+> ppr a9
+ , text "ticky:"
+ , nest 2 $ vcat (map ppr a10)
+ , text "codegen:"
+ , nest 2 $ vcat (map ppr a11)
+ , text "fat-iface:" <+> ppr a12
+ , text "debug-level:" <+> ppr a13
+ , text "caller-cc-filters:" <+> ppr a14
+ ]
+
+missingExtraFlagInfo :: SDoc
+missingExtraFlagInfo = text "flags: no detailed info, recompile with -fwrite-if-self-recomp-flags"
+ where
+ -- If you modify the name of this flag, you have to modify this string.
+ _placeholder = Opt_WriteSelfRecompFlags
+
+instance Binary IfaceDynFlags where
+ put_ bh (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ put_ bh a8
+ put_ bh a9
+ put_ bh a10
+ put_ bh a11
+ put_ bh a12
+ put_ bh a13
+ put_ bh a14
+ get bh = IfaceDynFlags <$> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+ <*> get bh
+
+instance NFData IfaceDynFlags where
+ rnf (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) =
+ rnf a1
+ `seq` rnf a2
+ `seq` rnf a3
+ `seq` rnf a4
+ `seq` rnf a5
+ `seq` rnf a6
+ `seq` rnf a7
+ `seq` rnf a8
+ `seq` rnf a9
+ `seq` rnf a10
+ `seq` rnf a11
+ `seq` rnf a12
+ `seq` rnf a13
+ `seq` rnf a14
+
+newtype IfaceGeneralFlag = IfaceGeneralFlag GeneralFlag
+
+instance NFData IfaceGeneralFlag where
+ rnf (IfaceGeneralFlag !_) = ()
+
+instance Binary IfaceGeneralFlag where
+ put_ bh (IfaceGeneralFlag f) = put_ bh (fromEnum f)
+ get bh = IfaceGeneralFlag . toEnum <$> get bh
+
+instance Outputable IfaceGeneralFlag where
+ ppr (IfaceGeneralFlag f) = text (show f)
+
+newtype IfaceProfAuto = IfaceProfAuto ProfAuto
+
+instance NFData IfaceProfAuto where
+ rnf (IfaceProfAuto !_) = ()
+
+instance Binary IfaceProfAuto where
+ put_ bh (IfaceProfAuto f) = put_ bh (fromEnum f)
+ get bh = IfaceProfAuto . toEnum <$> get bh
+
+instance Outputable IfaceProfAuto where
+ ppr (IfaceProfAuto f) = text (show f)
+
+
+newtype IfaceExtension = IfaceExtension LangExt.Extension
+
+instance NFData IfaceExtension where
+ rnf (IfaceExtension !_) = ()
+
+instance Binary IfaceExtension where
+ put_ bh (IfaceExtension f) = put_ bh (fromEnum f)
+ get bh = IfaceExtension . toEnum <$> get bh
+
+instance Outputable IfaceExtension where
+ ppr (IfaceExtension f) = text (show f)
+
+newtype IfaceLanguage = IfaceLanguage Language
+
+instance NFData IfaceLanguage where
+ rnf (IfaceLanguage !_) = ()
+
+instance Binary IfaceLanguage where
+ put_ bh (IfaceLanguage f) = put_ bh (fromEnum f)
+ get bh = IfaceLanguage . toEnum <$> get bh
+
+instance Outputable IfaceLanguage where
+ ppr (IfaceLanguage f) = text (show f)
+
+data IfaceCppOptions = IfaceCppOptions { ifaceCppIncludes :: [FilePath]
+ , ifaceCppOpts :: [String]
+ , ifaceCppSig :: ([String], Fingerprint)
+ }
+
+instance NFData IfaceCppOptions where
+ rnf (IfaceCppOptions is os s) = rnf is `seq` rnf os `seq` rnf s
+
+instance Binary IfaceCppOptions where
+ put_ bh (IfaceCppOptions is os s) = do
+ put_ bh is
+ put_ bh os
+ put_ bh s
+ get bh = IfaceCppOptions <$> get bh <*> get bh <*> get bh
+
+instance Outputable IfaceCppOptions where
+ ppr (IfaceCppOptions is os (wos, fp)) =
+ vcat [text "includes:"
+ , nest 2 $ hcat (map text is)
+ , text "opts:"
+ , nest 2 $ hcat (map text os)
+ , text "signature:"
+ , nest 2 $ parens (ppr fp) <+> ppr (map (text @SDoc) wos)
+
+ ]
\ No newline at end of file
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -59,6 +59,7 @@ import GHC.Driver.Plugins
import GHC.Iface.Warnings
import GHC.Iface.Syntax
import GHC.Iface.Ext.Fields
+import GHC.Iface.Flags
import GHC.Iface.Binary
import GHC.Iface.Rename
import GHC.Iface.Env
@@ -1271,7 +1272,7 @@ pprModIface unit_state iface
, nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts))
, withSelfRecomp iface empty $ \(ModIfaceSelfRecomp src usages flag_hash opt_hash hpc_hash plugin_hash) -> vcat
[ nest 2 (text "src_hash:" <+> ppr src)
- , nest 2 (text "flag hash:" <+> ppr flag_hash)
+ , nest 2 (text "flags:" <+> pprIfaceDynFlags flag_hash)
, nest 2 (text "opt_hash:" <+> ppr opt_hash)
, nest 2 (text "hpc_hash:" <+> ppr hpc_hash)
, nest 2 (text "plugin_hash:" <+> ppr plugin_hash)
@@ -1310,6 +1311,7 @@ pprModIface unit_state iface
pp_hsc_src HsigFile = text "[hsig]"
pp_hsc_src HsSrcFile = Outputable.empty
+
{-
When printing export lists, we print like this:
Avail f f
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -29,8 +29,10 @@ import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Driver.Plugins
+
import GHC.Iface.Syntax
import GHC.Iface.Recomp.Binary
+import GHC.Iface.Recomp.Types
import GHC.Iface.Load
import GHC.Iface.Recomp.Flags
import GHC.Iface.Env
@@ -70,6 +72,8 @@ import GHC.Unit.Module.Warnings
import GHC.Unit.Module.Deps
import Control.Monad
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
import Data.List (sortBy, sort, sortOn)
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -189,6 +193,7 @@ data RecompReason
| FileChanged FilePath
| CustomReason String
| FlagsChanged
+ | LinkFlagsChanged
| OptimFlagsChanged
| HpcFlagsChanged
| MissingBytecode
@@ -201,6 +206,7 @@ data RecompReason
| THWithJS
deriving (Eq)
+
instance Outputable RecompReason where
ppr = \case
UnitDepRemoved uid -> ppr uid <+> text "removed"
@@ -223,6 +229,7 @@ instance Outputable RecompReason where
FileChanged fp -> text fp <+> text "changed"
CustomReason s -> text s
FlagsChanged -> text "Flags changed"
+ LinkFlagsChanged -> text "Flags changed"
OptimFlagsChanged -> text "Optimisation flags changed"
HpcFlagsChanged -> text "HPC flags changed"
MissingBytecode -> text "Missing bytecode"
@@ -524,13 +531,46 @@ checkHie dflags mod_summary =
checkFlagHash :: HscEnv -> Module -> ModIfaceSelfRecomp -> IO RecompileRequired
checkFlagHash hsc_env iface_mod self_recomp = do
let logger = hsc_logger hsc_env
- let old_hash = mi_sr_flag_hash self_recomp
- new_hash <- fingerprintDynFlags hsc_env iface_mod putNameLiterally
- case old_hash == new_hash of
- True -> up_to_date logger (text "Module flags unchanged")
- False -> out_of_date_hash logger FlagsChanged
- (text " Module flags have changed")
- old_hash new_hash
+ let (old_fp, old_flags) = mi_sr_flag_hash self_recomp
+ (new_fp, new_flags) <- fingerprintDynFlags hsc_env iface_mod putNameLiterally
+ if old_fp == new_fp
+ then up_to_date logger (text "Module flags unchanged")
+ else do
+ -- Do not perform this computation unless -ddump-hi-diffs is on
+ let diffs = case old_flags of
+ Nothing -> pure [missingExtraFlagInfo]
+ Just old_flags -> checkIfaceFlags old_flags new_flags
+ out_of_date logger FlagsChanged (fmap vcat diffs)
+
+
+checkIfaceFlags :: IfaceDynFlags -> IfaceDynFlags -> IO [SDoc]
+checkIfaceFlags (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14)
+ (IfaceDynFlags b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14) =
+ flip execStateT [] $ do
+ check_one "main is" (ppr . fmap (fmap (text @SDoc))) a1 b1
+ check_one_simple "safemode" a2 b2
+ check_one_simple "lang" a3 b3
+ check_one_simple "exts" a4 b4
+ check_one_simple "cpp option" a5 b5
+ check_one_simple "js option" a6 b6
+ check_one_simple "cmm option" a7 b7
+ check_one "paths" (ppr . map (text @SDoc)) a8 b8
+ check_one_simple "prof" a9 b9
+ check_one_simple "ticky" a10 b10
+ check_one_simple "codegen" a11 b11
+ check_one_simple "fat iface" a12 b12
+ check_one_simple "debug level" a13 b13
+ check_one_simple "caller cc filter" a14 b14
+ where
+ diffSimple p a b = vcat [text "before:" <+> p a
+ , text "after:" <+> p b ]
+
+ check_one_simple s a b = check_one s ppr a b
+
+ check_one s p a b = do
+ a' <- lift $ computeFingerprint putNameLiterally a
+ b' <- lift $ computeFingerprint putNameLiterally b
+ if a' == b' then pure () else modify (([ text s <+> text "flags changed"] ++ [diffSimple p a b]) ++)
-- | Check the optimisation flags haven't changed
checkOptimHash :: HscEnv -> ModIfaceSelfRecomp -> IO RecompileRequired
@@ -828,7 +868,7 @@ checkEntityUsage :: Logger
checkEntityUsage logger reason new_hash (name,old_hash) = do
case new_hash name of
-- We used it before, but it ain't there now
- Nothing -> out_of_date logger reason (sep [text "No longer exported:", ppr name])
+ Nothing -> out_of_date logger reason (pure $ sep [text "No longer exported:", ppr name])
-- It's there, but is it up to date?
Just (_, new_hash)
| new_hash == old_hash
@@ -840,12 +880,12 @@ checkEntityUsage logger reason new_hash (name,old_hash) = do
up_to_date :: Logger -> SDoc -> IO RecompileRequired
up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate
-out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired
-out_of_date logger reason msg = trace_hi_diffs logger msg >> return (needsRecompileBecause reason)
+out_of_date :: Logger -> RecompReason -> IO SDoc -> IO RecompileRequired
+out_of_date logger reason msg = trace_hi_diffs_io logger msg >> return (needsRecompileBecause reason)
out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
out_of_date_hash logger reason msg old_hash new_hash
- = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
+ = out_of_date logger reason (pure $ hsep [msg, ppr old_hash, text "->", ppr new_hash])
-- ---------------------------------------------------------------------------
-- Compute fingerprints for the interface
@@ -950,7 +990,7 @@ mkSelfRecomp :: HscEnv -> Module -> Fingerprint -> [Usage] -> IO ModIfaceSelfRec
mkSelfRecomp hsc_env this_mod src_hash usages = do
let dflags = hsc_dflags hsc_env
- flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally
+ dyn_flags_info <- fingerprintDynFlags hsc_env this_mod putNameLiterally
opt_hash <- fingerprintOptFlags dflags putNameLiterally
@@ -958,8 +998,13 @@ mkSelfRecomp hsc_env this_mod src_hash usages = do
plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)
+ let include_detailed_flags (flag_hash, flags) =
+ if gopt Opt_WriteSelfRecompFlags dflags
+ then (flag_hash, Just flags)
+ else (flag_hash, Nothing)
+
return (ModIfaceSelfRecomp
- { mi_sr_flag_hash = flag_hash
+ { mi_sr_flag_hash = include_detailed_flags dyn_flags_info
, mi_sr_hpc_hash = hpc_hash
, mi_sr_opt_hash = opt_hash
, mi_sr_plugin_hash = plugin_hash
=====================================
compiler/GHC/Iface/Recomp/Flags.hs
=====================================
@@ -19,10 +19,13 @@ import GHC.Types.Name
import GHC.Types.SafeHaskell
import GHC.Utils.Fingerprint
import GHC.Iface.Recomp.Binary
-import GHC.Core.Opt.CallerCC () -- for Binary instances
+import GHC.Iface.Flags
import GHC.Data.EnumSet as EnumSet
import System.FilePath (normalise)
+import Data.Maybe
+
+-- The subset of DynFlags which is used by the recompilation checker.
-- | Produce a fingerprint of a @DynFlags@ value. We only base
-- the finger print on important fields in @DynFlags@ so that
@@ -32,7 +35,7 @@ import System.FilePath (normalise)
-- file, not the actual 'Module' according to our 'DynFlags'.
fingerprintDynFlags :: HscEnv -> Module
-> (WriteBinHandle -> Name -> IO ())
- -> IO Fingerprint
+ -> IO (Fingerprint, IfaceDynFlags)
fingerprintDynFlags hsc_env this_mod nameio =
let dflags at DynFlags{..} = hsc_dflags hsc_env
@@ -43,53 +46,61 @@ fingerprintDynFlags hsc_env this_mod nameio =
-- oflags = sort $ filter filterOFlags $ flags dflags
-- all the extension flags and the language
- lang = (fmap fromEnum language,
- map fromEnum $ EnumSet.toList extensionFlags)
+ lang = fmap IfaceLanguage language
+ exts = map IfaceExtension $ EnumSet.toList extensionFlags
-- avoid fingerprinting the absolute path to the directory of the source file
-- see Note [Implicit include paths]
includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] }
-- -I, -D and -U flags affect Haskell C/CPP Preprocessor
- cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit
- -- normalise: eliminate spurious differences due to "./foo" vs "foo"
- , picPOpts dflags
- , opt_P_signature dflags)
+ cpp = IfaceCppOptions
+ { ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit
+ -- normalise: eliminate spurious differences due to "./foo" vs "foo"
+ , ifaceCppOpts = picPOpts dflags
+ , ifaceCppSig = opt_P_signature dflags
+ }
-- See Note [Repeated -optP hashing]
+
-- -I, -D and -U flags affect JavaScript C/CPP Preprocessor
- js = ( map normalise $ flattenIncludes includePathsMinusImplicit
+ js = IfaceCppOptions
+ { ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit
-- normalise: eliminate spurious differences due to "./foo" vs "foo"
- , picPOpts dflags
- , opt_JSP_signature dflags)
+ , ifaceCppOpts = picPOpts dflags
+ , ifaceCppSig = opt_JSP_signature dflags
+ }
-- See Note [Repeated -optP hashing]
-- -I, -D and -U flags affect C-- CPP Preprocessor
- cmm = ( map normalise $ flattenIncludes includePathsMinusImplicit
+ cmm = IfaceCppOptions {
+ ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit
-- normalise: eliminate spurious differences due to "./foo" vs "foo"
- , picPOpts dflags
- , opt_CmmP_signature dflags)
+ , ifaceCppOpts = picPOpts dflags
+ , ifaceCppSig = ([], opt_CmmP_signature dflags)
+ }
-- Note [path flags and recompilation]
paths = [ hcSuf ]
-- -fprof-auto etc.
- prof = if sccProfilingEnabled dflags then fromEnum profAuto else 0
+ prof = if sccProfilingEnabled dflags then Just (IfaceProfAuto profAuto) else Nothing
-- Ticky
ticky =
- map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]
+ mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]
-- Other flags which affect code generation
- codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags)
+ codegen = mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) (EnumSet.toList codeGenFlags)
-- Did we include core for all bindings?
fat_iface = gopt Opt_WriteIfSimplifiedCore dflags
- flags = ((mainis, safeHs, lang, cpp, js, cmm), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface))
+ f = IfaceDynFlags mainis safeHs lang exts cpp js cmm paths prof ticky codegen fat_iface debugLevel callerCcFilters
- in -- pprTrace "flags" (ppr flags) $
- computeFingerprint nameio flags
+ in do
+ fp <- computeFingerprint nameio f
+ return (fp, f)
-- Fingerprint the optimisation info. We keep this separate from the rest of
-- the flags because GHCi users (especially) may wish to ignore changes in
=====================================
compiler/GHC/Iface/Recomp/Types.hs
=====================================
@@ -1,9 +1,14 @@
-module GHC.Iface.Recomp.Types ( ModIfaceSelfRecomp(..)
- ) where
+module GHC.Iface.Recomp.Types (
+ ModIfaceSelfRecomp(..),
+ IfaceDynFlags(..),
+ pprIfaceDynFlags,
+ missingExtraFlagInfo,
+) where
import GHC.Prelude
import GHC.Fingerprint
import GHC.Utils.Outputable
+import GHC.Iface.Flags
import GHC.Unit.Module.Deps
import GHC.Utils.Binary
@@ -64,7 +69,7 @@ data ModIfaceSelfRecomp =
-- NOT STRICT! we read this field lazily from the interface file
-- It is *only* consulted by the recompilation checker
- , mi_sr_flag_hash :: !Fingerprint
+ , mi_sr_flag_hash :: !(Fingerprint, Maybe IfaceDynFlags)
-- ^ Hash of the important flags used when compiling the module, excluding
-- optimisation flags
, mi_sr_opt_hash :: !Fingerprint
@@ -99,7 +104,7 @@ instance Outputable ModIfaceSelfRecomp where
= vcat [text "Self-Recomp"
, nest 2 (vcat [ text "src hash:" <+> ppr mi_sr_src_hash
, text "usages:" <+> ppr (length mi_sr_usages)
- , text "flag hash:" <+> ppr mi_sr_flag_hash
+ , text "flags:" <+> pprIfaceDynFlags mi_sr_flag_hash
, text "opt hash:" <+> ppr mi_sr_opt_hash
, text "hpc hash:" <+> ppr mi_sr_hpc_hash
, text "plugin hash:" <+> ppr mi_sr_plugin_hash
=====================================
compiler/GHC/Types/ProfAuto.hs
=====================================
@@ -12,4 +12,4 @@ data ProfAuto
| ProfAutoTop -- ^ top-level functions annotated only
| ProfAutoExports -- ^ exported functions annotated only
| ProfAutoCalls -- ^ annotate call-sites
- deriving (Eq,Enum)
+ deriving (Eq,Enum, Show)
=====================================
compiler/GHC/Types/SafeHaskell.hs
=====================================
@@ -14,6 +14,7 @@ import GHC.Prelude
import GHC.Utils.Binary
import GHC.Utils.Outputable
+import Control.DeepSeq
import Data.Word
@@ -31,6 +32,15 @@ data SafeHaskellMode
| Sf_Ignore -- ^ @-fno-safe-haskell@ state
deriving (Eq)
+instance NFData SafeHaskellMode where
+ rnf x = case x of
+ Sf_None -> ()
+ Sf_Unsafe -> ()
+ Sf_Trustworthy -> ()
+ Sf_Safe -> ()
+ Sf_SafeInferred -> ()
+ Sf_Ignore -> ()
+
instance Show SafeHaskellMode where
show Sf_None = "None"
show Sf_Unsafe = "Unsafe"
@@ -46,6 +56,10 @@ instance Outputable SafeHaskellMode where
-- Simply a wrapper around SafeHaskellMode to separate iface and flags
newtype IfaceTrustInfo = TrustInfo SafeHaskellMode
+instance NFData IfaceTrustInfo where
+ rnf (TrustInfo shm) = rnf shm
+
+
getSafeMode :: IfaceTrustInfo -> SafeHaskellMode
getSafeMode (TrustInfo x) = x
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -103,6 +103,7 @@ import GHC.Prelude
import GHC.Hs
import GHC.Iface.Syntax
+import GHC.Iface.Flags
import GHC.Iface.Ext.Fields
import GHC.Iface.Recomp.Types
@@ -395,7 +396,7 @@ That's why in GHC.Driver.Main.hscMaybeWriteIface there is the call to
forceModIface.
-}
-mi_flag_hash :: ModIface_ phase -> Maybe Fingerprint
+mi_flag_hash :: ModIface_ phase -> Maybe (Fingerprint, Maybe IfaceDynFlags)
mi_flag_hash = fmap mi_sr_flag_hash . mi_self_recomp_info_
mi_opt_hash :: ModIface_ phase -> Maybe Fingerprint
@@ -613,7 +614,6 @@ instance Binary ModIface where
}})
-
emptyPartialModIface :: Module -> PartialModIface
emptyPartialModIface mod
= PrivateModIface
=====================================
compiler/ghc.cabal.in
=====================================
@@ -511,6 +511,7 @@ Library
GHC.Driver.Config.Tidy
GHC.Driver.Config.StgToJS
GHC.Driver.DynFlags
+ GHC.Driver.IncludeSpecs
GHC.Driver.Env
GHC.Driver.Env.KnotVars
GHC.Driver.Env.Types
@@ -609,6 +610,7 @@ Library
GHC.Iface.Recomp.Types
GHC.Iface.Rename
GHC.Iface.Syntax
+ GHC.Iface.Flags
GHC.Iface.Tidy
GHC.Iface.Tidy.StaticPtrTable
GHC.Iface.Warnings
=====================================
docs/users_guide/phases.rst
=====================================
@@ -705,7 +705,6 @@ Options affecting code generation
.. ghc-flag:: -fwrite-if-self-recomp
:shortdesc: Write information for self-recompilation checking in an interface file
:type: dynamic
- :category: codegen
:default: on
@@ -718,6 +717,14 @@ Options affecting code generation
there is less chance of build paths leaking into the interface file and affecting
determinism.
+.. ghc-flag:: -fwrite-if-self-recomp-flags
+ :shortdesc: Include detailed flag information for self-recompilation checking
+ :type: dynamic
+
+ Include detailed information about which flags were used during compilation
+ in an interface file. This makes it easier to debug issues with recompilation
+ by providing more context about the compilation environment. This flag is
+ primarily intended for debugging recompilation problems with ``-ddump-hi-diffs``
=====================================
testsuite/tests/cmm/opt/T25771.cmm
=====================================
@@ -0,0 +1,8 @@
+// The point of this test is that the bitcast operations
+// should be successfully constant-folded, without panicking.
+
+func (float64 x) {
+ x = %fadd(x, %w2f_bitcast(0x4028b0a3d70a3d71 :: bits64));
+ x = %fadd(x, %f2f64(%w2f_bitcast(0x3f2a0000 :: bits32)));
+ return (x);
+}
=====================================
testsuite/tests/cmm/opt/T25771.stderr
=====================================
@@ -0,0 +1,20 @@
+
+==================== Output Cmm ====================
+[func() { // [D1]
+ { info_tbls: []
+ stack_info: arg_space: 8
+ }
+ {offset
+ c2: // global
+ //tick src<T25771.cmm:(4,18)-(8,1)>
+ //tick src<T25771.cmm:5:5-59>
+ //tick src<T25771.cmm:6:5-59>
+ _c1::F64 = D1; // CmmAssign
+ _c1::F64 = %MO_F_Add_W64(D1, 12.345 :: W64); // CmmAssign
+ D1 = %MO_F_Add_W64(_c1::F64,
+ %MO_FF_Conv_W32_W64(0.6640625 :: W32)); // CmmAssign
+ call (P64[Sp])(D1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ }]
+
+
=====================================
testsuite/tests/cmm/opt/all.T
=====================================
@@ -8,3 +8,7 @@ test('T20142', normal, compile, [''])
# 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'])
+test('T25771', [cmm_src, only_ways(['optasm']),
+ grep_errmsg(r'(12\.345|0\.6640625)',[1]),
+ ],
+ compile, ['-ddump-cmm'])
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -210,7 +210,9 @@ test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, [''])
test('T17920', [cmm_src], compile_and_run, [''])
test('T18527', req_c, compile_and_run, ['T18527FFI.c'])
test('T19149', [req_c,only_ways('sanity')], compile_and_run, ['T19149_c.c'])
-test('T20275', normal, compile_and_run, [''])
+test('T20275', [unless(js_arch(),extra_ways(['optasm']))], compile_and_run, [''])
+ # Also tested with optimizations because
+ # that's the original reproducer for #25771
test('CallConv', [when(unregisterised(), skip),
unless(arch('x86_64') or arch('aarch64'), skip),
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -91,6 +91,7 @@ GHC.Driver.Backend
GHC.Driver.Backend.Internal
GHC.Driver.DynFlags
GHC.Driver.Flags
+GHC.Driver.IncludeSpecs
GHC.Driver.Phases
GHC.Driver.Pipeline.Monad
GHC.Driver.Plugins.External
@@ -111,6 +112,7 @@ GHC.Hs.Type
GHC.Hs.Utils
GHC.Iface.Errors.Types
GHC.Iface.Ext.Fields
+GHC.Iface.Flags
GHC.Iface.Recomp.Binary
GHC.Iface.Recomp.Types
GHC.Iface.Syntax
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -95,6 +95,7 @@ GHC.Driver.Backpack.Syntax
GHC.Driver.DynFlags
GHC.Driver.Errors.Types
GHC.Driver.Flags
+GHC.Driver.IncludeSpecs
GHC.Driver.Phases
GHC.Driver.Pipeline.Monad
GHC.Driver.Plugins.External
@@ -117,6 +118,7 @@ GHC.HsToCore.Errors.Types
GHC.HsToCore.Pmc.Solver.Types
GHC.Iface.Errors.Types
GHC.Iface.Ext.Fields
+GHC.Iface.Flags
GHC.Iface.Recomp.Binary
GHC.Iface.Recomp.Types
GHC.Iface.Syntax
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21c971e03ab175dd416b74931d245ed92d4f9634...44bf5fa13ddccacd9d91650fca6eb1dcf3f4cfb6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21c971e03ab175dd416b74931d245ed92d4f9634...44bf5fa13ddccacd9d91650fca6eb1dcf3f4cfb6
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/20250307/ea6db685/attachment-0001.html>
More information about the ghc-commits
mailing list