[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
1362d5a8 by Cheng Shao at 2025-08-10T13:39:51+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
fdebadb5 by Cheng Shao at 2025-08-10T13:39:56+00:00
driver: test bytecode roundtrip serialization
- - - - -
10 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -929,3 +930,8 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOps !!) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -44,6 +44,7 @@ import GHC.HsToCore.Breakpoints
import GHC.Iface.Syntax
import GHC.Unit.Module (Module)
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Array
@@ -297,3 +298,11 @@ instance Outputable CgBreakInfo where
parens (ppr (cgb_vars info) <+>
ppr (cgb_resty info) <+>
ppr (cgb_tick_id info))
+
+deriving newtype instance Binary InternalBreakLoc
+
+instance Binary InternalBreakpointId where
+ get bh = InternalBreakpointId <$> get bh <*> get bh
+
+ put_ bh InternalBreakpointId {..} =
+ put_ bh ibi_info_mod *> put_ bh ibi_info_index
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -0,0 +1,224 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Serialize
+ ( testBinByteCode,
+ )
+where
+
+import Control.Monad
+import Data.Binary qualified as Binary
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import GHC.ByteCode.Breakpoints
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Driver.Env
+import GHC.Iface.Binary
+import GHC.Prelude
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.SrcLoc
+import GHC.Utils.Binary
+import GHC.Utils.Exception
+import GHC.Utils.TmpFs
+import GHCi.Message
+import System.FilePath
+
+testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode
+testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do
+ let f = tmpdir </> "ghc-bbc"
+ roundtripBinByteCode hsc_env f cbc
+
+roundtripBinByteCode ::
+ HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode
+roundtripBinByteCode hsc_env f cbc = do
+ writeBinByteCode f cbc
+ readBinByteCode hsc_env f
+
+readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode
+readBinByteCode hsc_env f = do
+ bh' <- readBinMem f
+ bh <- addSerializableNameReader hsc_env bh'
+ getWithUserData (hsc_NC hsc_env) bh
+
+writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
+writeBinByteCode f cbc = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addSerializableNameWriter bh'
+ putWithUserData QuietBinIFace NormalCompression bh cbc
+ writeBinMem bh f
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaSerializableName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ evaluate
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaSerializableName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary InternalModBreaks where
+ get bh = InternalModBreaks <$> get bh <*> get bh
+
+ put_ bh InternalModBreaks {..} =
+ put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks
+
+instance Binary ModBreaks where
+ get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+
+ put_ bh ModBreaks {..} =
+ put_ bh modBreaks_locs
+ *> put_ bh modBreaks_vars
+ *> put_ bh modBreaks_decls
+ *> put_ bh modBreaks_ccs
+ *> put_ bh modBreaks_module
+
+instance Binary SrcSpan where
+ get bh = unBinSrcSpan <$> get bh
+
+ put_ bh = put_ bh . BinSrcSpan
+
+instance Binary CgBreakInfo where
+ put_ bh CgBreakInfo {..} =
+ put_ bh cgb_tyvars
+ *> put_ bh cgb_vars
+ *> put_ bh cgb_resty
+ *> put_ bh cgb_tick_id
+
+ get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh
+
+instance Binary ConInfoTable where
+ get bh = Binary.decode . LBS.fromStrict <$> get bh
+
+ put_ bh = put_ bh . LBS.toStrict . Binary.encode
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaSerializableName bh
+ <*> get bh
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaSerializableName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ _ -> BCOPtrBreakArray <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaSerializableName bh
+ 3 -> BCONPtrAddr <$> getViaSerializableName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ _ -> BCONPtrCostCentre <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+newtype SerializableName = SerializableName {unSerializableName :: Name}
+
+getViaSerializableName :: ReadBinHandle -> IO Name
+getViaSerializableName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unSerializableName <$> f bh
+
+putViaSerializableName :: WriteBinHandle -> Name -> IO ()
+putViaSerializableName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ SerializableName nm
+
+addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addSerializableNameWriter bh' =
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (SerializableName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ put_ bh
+ $ occNameFS (occName nm)
+ `appendFS` mkFastString
+ (show $ nameUnique nm)
+
+addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
+addSerializableNameReader HscEnv {..} bh' = do
+ nc <- evaluate hsc_NC
+ env_ref <- newIORef emptyOccEnv
+ evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ evaluate $ SerializableName nm
+ _ -> do
+ occ <- mkVarOccFS <$> get bh
+ u <- takeUniqFromNameCache nc
+ nm' <- evaluate $ mkInternalName u occ noSrcSpan
+ fmap SerializableName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> (extendOccEnv env occ nm', nm')
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
@@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where
ppr (sizeFlatBag lits), text "lits",
ppr (sizeFlatBag ptrs), text "ptrs" ]
+instance Binary FFIInfo where
+ get bh = FFIInfo <$> get bh <*> get bh
+
+ put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet
+
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Prelude
import Control.DeepSeq
import GHC.Data.SmallArray
+import GHC.Utils.Binary
+import GHC.Utils.Exception
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where
rnf (TupleFlatBag a b) = rnf a `seq` rnf b
rnf (FlatBag arr) = rnfSmallArray arr
+instance (Binary a) => Binary (FlatBag a) where
+ get bh = do
+ xs <- get bh
+ evaluate $ fromList (fromIntegral $ length xs) xs
+
+ put_ bh = put_ bh . elemsFlatBag
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -305,6 +305,8 @@ import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
+import GHC.ByteCode.Serialize
+
{- **********************************************************************
%* *
Initialisation
@@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv
-> ModLocation
-> IO (CompiledByteCode, [FilePath])
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location
+ comp_bc <- testBinByteCode hsc_env comp_bc'
compile_for_interpreter hsc_env $ \ i_env -> do
stub_o <- traverse (compileForeign i_env LangC) hasStub
foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
=====================================
compiler/GHC/Types/SptEntry.hs
=====================================
@@ -3,8 +3,12 @@ module GHC.Types.SptEntry
)
where
-import GHC.Types.Var ( Id )
+import GHC.Builtin.Types
+import GHC.Types.Id
+import GHC.Types.Name
import GHC.Fingerprint.Type ( Fingerprint )
+import GHC.Prelude
+import GHC.Utils.Binary
import GHC.Utils.Outputable
-- | An entry to be inserted into a module's static pointer table.
@@ -14,3 +18,11 @@ data SptEntry = SptEntry Id Fingerprint
instance Outputable SptEntry where
ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+instance Binary SptEntry where
+ get bh = do
+ nm <- get bh
+ fp <- get bh
+ pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
+
+ put_ bh (SptEntry nm fp) =
+ put_ bh (getName nm) *> put_ bh fp
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.Types.Tickish (
GenTickish(..),
@@ -44,6 +45,7 @@ import GHC.Utils.Panic
import Language.Haskell.Syntax.Extension ( NoExtField )
import Data.Data
+import GHC.Utils.Binary
import GHC.Utils.Outputable (Outputable (ppr), text, (<+>))
{- *********************************************************************
@@ -202,6 +204,11 @@ instance NFData BreakpointId where
rnf BreakpointId{bi_tick_mod, bi_tick_index} =
rnf bi_tick_mod `seq` rnf bi_tick_index
+instance Binary BreakpointId where
+ get bh = BreakpointId <$> get bh <*> get bh
+
+ put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index
+
--------------------------------------------------------------------------------
-- | A "counting tick" (where tickishCounts is True) is one that
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Data.TrieMap
+import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
@@ -133,6 +134,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHCi.FFI
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -929,6 +931,12 @@ instance Binary Char where
put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance Binary Word where
+ put_ bh i = put_ bh (fromIntegral i :: Word64)
+ get bh = do
+ x <- get bh
+ return $! (fromIntegral (x :: Word64))
+
instance Binary Int where
put_ bh i = put_ bh (fromIntegral i :: Int64)
get bh = do
@@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where
instance NFData a => NFData (FingerprintWithValue a) where
rnf (FingerprintWithValue fp mflags)
= rnf fp `seq` rnf mflags `seq` ()
+
+instance Binary FFIType where
+ get bh = do
+ t <- getByte bh
+ evaluate $ case t of
+ 0 -> FFIVoid
+ 1 -> FFIPointer
+ 2 -> FFIFloat
+ 3 -> FFIDouble
+ 4 -> FFISInt8
+ 5 -> FFISInt16
+ 6 -> FFISInt32
+ 7 -> FFISInt64
+ 8 -> FFIUInt8
+ 9 -> FFIUInt16
+ 10 -> FFIUInt32
+ 11 -> FFIUInt64
+ _ -> panic "Binary FFIType: invalid byte"
+
+ put_ bh t = putByte bh $ case t of
+ FFIVoid -> 0
+ FFIPointer -> 1
+ FFIFloat -> 2
+ FFIDouble -> 3
+ FFISInt8 -> 4
+ FFISInt16 -> 5
+ FFISInt32 -> 6
+ FFISInt64 -> 7
+ FFIUInt8 -> 8
+ FFIUInt16 -> 9
+ FFIUInt32 -> 10
+ FFIUInt64 -> 11
=====================================
compiler/ghc.cabal.in
=====================================
@@ -228,6 +228,7 @@ Library
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
+ GHC.ByteCode.Serialize
GHC.ByteCode.Types
GHC.Cmm
GHC.Cmm.BlockId
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1707f1ced6e0912607993af4cb8fb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1707f1ced6e0912607993af4cb8fb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
d9a91519 by Cheng Shao at 2025-08-10T13:18:32+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
e1707f1c by Cheng Shao at 2025-08-10T13:18:37+00:00
driver: test bytecode roundtrip serialization
- - - - -
8 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -929,3 +930,8 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOps !!) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -0,0 +1,240 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Serialize
+ ( testBinByteCode,
+ )
+where
+
+import Control.Monad
+import Data.Binary qualified as Binary
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import GHC.ByteCode.Breakpoints
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Driver.Env
+import GHC.Iface.Binary
+import GHC.Prelude
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.SrcLoc
+import GHC.Utils.Binary
+import GHC.Utils.Exception
+import GHC.Utils.TmpFs
+import GHCi.Message
+import System.FilePath
+
+testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode
+testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do
+ let f = tmpdir </> "ghc-bbc"
+ roundtripBinByteCode hsc_env f cbc
+
+roundtripBinByteCode ::
+ HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode
+roundtripBinByteCode hsc_env f cbc = do
+ writeBinByteCode f cbc
+ readBinByteCode hsc_env f
+
+readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode
+readBinByteCode hsc_env f = do
+ bh' <- readBinMem f
+ bh <- addSerializableNameReader hsc_env bh'
+ getWithUserData (hsc_NC hsc_env) bh
+
+writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
+writeBinByteCode f cbc = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addSerializableNameWriter bh'
+ putWithUserData QuietBinIFace NormalCompression bh cbc
+ writeBinMem bh f
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaSerializableName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ evaluate
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaSerializableName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary InternalModBreaks where
+ get bh = InternalModBreaks <$> get bh <*> get bh
+
+ put_ bh InternalModBreaks {..} =
+ put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks
+
+instance Binary ModBreaks where
+ get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+
+ put_ bh ModBreaks {..} =
+ put_ bh modBreaks_locs
+ *> put_ bh modBreaks_vars
+ *> put_ bh modBreaks_decls
+ *> put_ bh modBreaks_ccs
+ *> put_ bh modBreaks_module
+
+instance Binary SrcSpan where
+ get bh = unBinSrcSpan <$> get bh
+
+ put_ bh = put_ bh . BinSrcSpan
+
+instance Binary CgBreakInfo where
+ put_ bh CgBreakInfo {..} =
+ put_ bh cgb_tyvars
+ *> put_ bh cgb_vars
+ *> put_ bh cgb_resty
+ *> put_ bh cgb_tick_id
+
+ get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh
+
+instance Binary ConInfoTable where
+ get bh = Binary.decode . LBS.fromStrict <$> get bh
+
+ put_ bh = put_ bh . LBS.toStrict . Binary.encode
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaSerializableName bh
+ <*> get bh
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaSerializableName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ _ -> BCOPtrBreakArray <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaSerializableName bh
+ 3 -> BCONPtrAddr <$> getViaSerializableName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ _ -> BCONPtrCostCentre <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+instance Binary InternalBreakLoc where
+ get bh = InternalBreakLoc <$> get bh
+
+ put_ bh InternalBreakLoc {..} = put_ bh internalBreakLoc
+
+instance Binary BreakpointId where
+ get bh = BreakpointId <$> get bh <*> get bh
+
+ put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index
+
+instance Binary InternalBreakpointId where
+ get bh = InternalBreakpointId <$> get bh <*> get bh
+
+ put_ bh InternalBreakpointId {..} =
+ put_ bh ibi_info_mod *> put_ bh ibi_info_index
+
+newtype SerializableName = SerializableName {unSerializableName :: Name}
+
+getViaSerializableName :: ReadBinHandle -> IO Name
+getViaSerializableName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unSerializableName <$> f bh
+
+putViaSerializableName :: WriteBinHandle -> Name -> IO ()
+putViaSerializableName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ SerializableName nm
+
+addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addSerializableNameWriter bh' =
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (SerializableName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ put_ bh
+ $ occNameFS (occName nm)
+ `appendFS` mkFastString
+ (show $ nameUnique nm)
+
+addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
+addSerializableNameReader HscEnv {..} bh' = do
+ nc <- evaluate hsc_NC
+ env_ref <- newIORef emptyOccEnv
+ evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ evaluate $ SerializableName nm
+ _ -> do
+ occ <- mkVarOccFS <$> get bh
+ u <- takeUniqFromNameCache nc
+ nm' <- evaluate $ mkInternalName u occ noSrcSpan
+ fmap SerializableName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> (extendOccEnv env occ nm', nm')
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
@@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where
ppr (sizeFlatBag lits), text "lits",
ppr (sizeFlatBag ptrs), text "ptrs" ]
+instance Binary FFIInfo where
+ get bh = FFIInfo <$> get bh <*> get bh
+
+ put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet
+
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Prelude
import Control.DeepSeq
import GHC.Data.SmallArray
+import GHC.Utils.Binary
+import GHC.Utils.Exception
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where
rnf (TupleFlatBag a b) = rnf a `seq` rnf b
rnf (FlatBag arr) = rnfSmallArray arr
+instance (Binary a) => Binary (FlatBag a) where
+ get bh = do
+ xs <- get bh
+ evaluate $ fromList (fromIntegral $ length xs) xs
+
+ put_ bh = put_ bh . elemsFlatBag
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -305,6 +305,8 @@ import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
+import GHC.ByteCode.Serialize
+
{- **********************************************************************
%* *
Initialisation
@@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv
-> ModLocation
-> IO (CompiledByteCode, [FilePath])
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location
+ comp_bc <- testBinByteCode hsc_env comp_bc'
compile_for_interpreter hsc_env $ \ i_env -> do
stub_o <- traverse (compileForeign i_env LangC) hasStub
foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
=====================================
compiler/GHC/Types/SptEntry.hs
=====================================
@@ -3,8 +3,12 @@ module GHC.Types.SptEntry
)
where
-import GHC.Types.Var ( Id )
+import GHC.Builtin.Types
+import GHC.Types.Id
+import GHC.Types.Name
import GHC.Fingerprint.Type ( Fingerprint )
+import GHC.Prelude
+import GHC.Utils.Binary
import GHC.Utils.Outputable
-- | An entry to be inserted into a module's static pointer table.
@@ -14,3 +18,11 @@ data SptEntry = SptEntry Id Fingerprint
instance Outputable SptEntry where
ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+instance Binary SptEntry where
+ get bh = do
+ nm <- get bh
+ fp <- get bh
+ pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
+
+ put_ bh (SptEntry nm fp) =
+ put_ bh (getName nm) *> put_ bh fp
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Data.TrieMap
+import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
@@ -133,6 +134,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHCi.FFI
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -929,6 +931,12 @@ instance Binary Char where
put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance Binary Word where
+ put_ bh i = put_ bh (fromIntegral i :: Word64)
+ get bh = do
+ x <- get bh
+ return $! (fromIntegral (x :: Word64))
+
instance Binary Int where
put_ bh i = put_ bh (fromIntegral i :: Int64)
get bh = do
@@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where
instance NFData a => NFData (FingerprintWithValue a) where
rnf (FingerprintWithValue fp mflags)
= rnf fp `seq` rnf mflags `seq` ()
+
+instance Binary FFIType where
+ get bh = do
+ t <- getByte bh
+ evaluate $ case t of
+ 0 -> FFIVoid
+ 1 -> FFIPointer
+ 2 -> FFIFloat
+ 3 -> FFIDouble
+ 4 -> FFISInt8
+ 5 -> FFISInt16
+ 6 -> FFISInt32
+ 7 -> FFISInt64
+ 8 -> FFIUInt8
+ 9 -> FFIUInt16
+ 10 -> FFIUInt32
+ 11 -> FFIUInt64
+ _ -> panic "Binary FFIType: invalid byte"
+
+ put_ bh t = putByte bh $ case t of
+ FFIVoid -> 0
+ FFIPointer -> 1
+ FFIFloat -> 2
+ FFIDouble -> 3
+ FFISInt8 -> 4
+ FFISInt16 -> 5
+ FFISInt32 -> 6
+ FFISInt64 -> 7
+ FFIUInt8 -> 8
+ FFIUInt16 -> 9
+ FFIUInt32 -> 10
+ FFIUInt64 -> 11
=====================================
compiler/ghc.cabal.in
=====================================
@@ -228,6 +228,7 @@ Library
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
+ GHC.ByteCode.Serialize
GHC.ByteCode.Types
GHC.Cmm
GHC.Cmm.BlockId
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9eb488348b3ddd916da89898f5a04…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9eb488348b3ddd916da89898f5a04…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
bca57385 by Cheng Shao at 2025-08-10T13:06:05+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
c9eb4883 by Cheng Shao at 2025-08-10T13:06:11+00:00
driver: test bytecode roundtrip serialization
- - - - -
7 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -929,3 +930,8 @@ primOpIsReallyInline = \case
DataToTagSmallOp -> False
DataToTagLargeOp -> False
p -> not (primOpOutOfLine p)
+
+instance Binary PrimOp where
+ get bh = (allThePrimOps !!) <$> get bh
+
+ put_ bh = put_ bh . primOpTag
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -0,0 +1,252 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.ByteCode.Serialize
+ ( testBinByteCode,
+ )
+where
+
+import Control.Monad
+import Data.Binary qualified as Binary
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable
+import Data.IORef
+import Data.Proxy
+import Data.Word
+import GHC.Builtin.Types
+import GHC.ByteCode.Breakpoints
+import GHC.ByteCode.Types
+import GHC.Data.FastString
+import GHC.Driver.Env
+import GHC.Iface.Binary
+import GHC.Prelude
+import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.Name.Cache
+import GHC.Types.SptEntry
+import GHC.Types.SrcLoc
+import GHC.Utils.Binary
+import GHC.Utils.Exception
+import GHC.Utils.TmpFs
+import GHCi.Message
+import System.FilePath
+
+testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode
+testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do
+ let f = tmpdir </> "ghc-bbc"
+ roundtripBinByteCode hsc_env f cbc
+
+roundtripBinByteCode ::
+ HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode
+roundtripBinByteCode hsc_env f cbc = do
+ writeBinByteCode f cbc
+ readBinByteCode hsc_env f
+
+readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode
+readBinByteCode hsc_env f = do
+ bh' <- readBinMem f
+ bh <- addSerializableNameReader hsc_env bh'
+ getWithUserData (hsc_NC hsc_env) bh
+
+writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
+writeBinByteCode f cbc = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addSerializableNameWriter bh'
+ putWithUserData QuietBinIFace NormalCompression bh cbc
+ writeBinMem bh f
+
+instance Binary CompiledByteCode where
+ get bh = do
+ bc_bcos <- get bh
+ bc_itbls_len <- get bh
+ bc_itbls <- replicateM bc_itbls_len $ do
+ nm <- getViaSerializableName bh
+ itbl <- get bh
+ pure (nm, itbl)
+ bc_strs_len <- get bh
+ bc_strs <-
+ replicateM bc_strs_len $ (,) <$> getViaSerializableName bh <*> get bh
+ bc_breaks <- get bh
+ bc_spt_entries <- get bh
+ evaluate
+ CompiledByteCode
+ { bc_bcos,
+ bc_itbls,
+ bc_strs,
+ bc_breaks,
+ bc_spt_entries
+ }
+
+ put_ bh CompiledByteCode {..} = do
+ put_ bh bc_bcos
+ put_ bh $ length bc_itbls
+ for_ bc_itbls $ \(nm, itbl) -> do
+ putViaSerializableName bh nm
+ put_ bh itbl
+ put_ bh $ length bc_strs
+ for_ bc_strs $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str
+ put_ bh bc_breaks
+ put_ bh bc_spt_entries
+
+instance Binary InternalModBreaks where
+ get bh = InternalModBreaks <$> get bh <*> get bh
+
+ put_ bh InternalModBreaks {..} =
+ put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks
+
+instance Binary ModBreaks where
+ get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+
+ put_ bh ModBreaks {..} =
+ put_ bh modBreaks_locs
+ *> put_ bh modBreaks_vars
+ *> put_ bh modBreaks_decls
+ *> put_ bh modBreaks_ccs
+ *> put_ bh modBreaks_module
+
+instance Binary SrcSpan where
+ get bh = unBinSrcSpan <$> get bh
+
+ put_ bh = put_ bh . BinSrcSpan
+
+instance Binary CgBreakInfo where
+ put_ bh CgBreakInfo {..} =
+ put_ bh cgb_tyvars
+ *> put_ bh cgb_vars
+ *> put_ bh cgb_resty
+ *> put_ bh cgb_tick_id
+
+ get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh
+
+instance Binary ConInfoTable where
+ get bh = Binary.decode . LBS.fromStrict <$> get bh
+
+ put_ bh = put_ bh . LBS.toStrict . Binary.encode
+
+instance Binary UnlinkedBCO where
+ get bh =
+ UnlinkedBCO
+ <$> getViaSerializableName bh
+ <*> get bh
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> (Binary.decode . LBS.fromStrict <$> get bh)
+ <*> get bh
+ <*> get bh
+
+ put_ bh UnlinkedBCO {..} = do
+ putViaSerializableName bh unlinkedBCOName
+ put_ bh unlinkedBCOArity
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs
+ put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap
+ put_ bh unlinkedBCOLits
+ put_ bh unlinkedBCOPtrs
+
+instance Binary BCOPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCOPtrName <$> getViaSerializableName bh
+ 1 -> BCOPtrPrimOp <$> get bh
+ 2 -> BCOPtrBCO <$> get bh
+ _ -> BCOPtrBreakArray <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm
+ BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
+ BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
+ BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
+
+instance Binary BCONPtr where
+ get bh = do
+ t <- getByte bh
+ case t of
+ 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
+ 1 -> BCONPtrLbl <$> get bh
+ 2 -> BCONPtrItbl <$> getViaSerializableName bh
+ 3 -> BCONPtrAddr <$> getViaSerializableName bh
+ 4 -> BCONPtrStr <$> get bh
+ 5 -> BCONPtrFS <$> get bh
+ 6 -> BCONPtrFFIInfo <$> get bh
+ _ -> BCONPtrCostCentre <$> get bh
+
+ put_ bh ptr = case ptr of
+ BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
+ BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
+ BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm
+ BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm
+ BCONPtrStr str -> putByte bh 4 *> put_ bh str
+ BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
+ BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
+ BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
+
+instance Binary InternalBreakLoc where
+ get bh = InternalBreakLoc <$> get bh
+
+ put_ bh InternalBreakLoc {..} = put_ bh internalBreakLoc
+
+instance Binary BreakpointId where
+ get bh = BreakpointId <$> get bh <*> get bh
+
+ put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index
+
+instance Binary InternalBreakpointId where
+ get bh = InternalBreakpointId <$> get bh <*> get bh
+
+ put_ bh InternalBreakpointId {..} =
+ put_ bh ibi_info_mod *> put_ bh ibi_info_index
+
+instance Binary SptEntry where
+ get bh = do
+ nm <- getViaSerializableName bh
+ fp <- get bh
+ pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
+
+ put_ bh (SptEntry nm fp) =
+ putViaSerializableName bh (getName nm) *> put_ bh fp
+
+newtype SerializableName = SerializableName {unSerializableName :: Name}
+
+getViaSerializableName :: ReadBinHandle -> IO Name
+getViaSerializableName bh = case findUserDataReader Proxy bh of
+ BinaryReader f -> unSerializableName <$> f bh
+
+putViaSerializableName :: WriteBinHandle -> Name -> IO ()
+putViaSerializableName bh nm = case findUserDataWriter Proxy bh of
+ BinaryWriter f -> f bh $ SerializableName nm
+
+addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle
+addSerializableNameWriter bh' =
+ evaluate
+ $ flip addWriterToUserData bh'
+ $ BinaryWriter
+ $ \bh (SerializableName nm) ->
+ if
+ | isExternalName nm -> do
+ putByte bh 0
+ put_ bh nm
+ | otherwise -> do
+ putByte bh 1
+ put_ bh
+ $ occNameFS (occName nm)
+ `appendFS` mkFastString
+ (show $ nameUnique nm)
+
+addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
+addSerializableNameReader HscEnv {..} bh' = do
+ nc <- evaluate hsc_NC
+ env_ref <- newIORef emptyOccEnv
+ evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
+ t <- getByte bh
+ case t of
+ 0 -> do
+ nm <- get bh
+ evaluate $ SerializableName nm
+ _ -> do
+ occ <- mkVarOccFS <$> get bh
+ u <- takeUniqFromNameCache nc
+ nm' <- evaluate $ mkInternalName u occ noSrcSpan
+ fmap SerializableName $ atomicModifyIORef' env_ref $ \env ->
+ case lookupOccEnv env occ of
+ Just nm -> (env, nm)
+ _ -> (extendOccEnv env occ nm', nm')
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Data.FastString
import GHC.Data.FlatBag
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
import GHC.Types.SptEntry
@@ -296,3 +297,8 @@ instance Outputable UnlinkedBCO where
ppr (sizeFlatBag lits), text "lits",
ppr (sizeFlatBag ptrs), text "ptrs" ]
+instance Binary FFIInfo where
+ get bh = FFIInfo <$> get bh <*> get bh
+
+ put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet
+
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Prelude
import Control.DeepSeq
import GHC.Data.SmallArray
+import GHC.Utils.Binary
+import GHC.Utils.Exception
-- | Store elements in a flattened representation.
--
@@ -66,6 +68,13 @@ instance NFData a => NFData (FlatBag a) where
rnf (TupleFlatBag a b) = rnf a `seq` rnf b
rnf (FlatBag arr) = rnfSmallArray arr
+instance (Binary a) => Binary (FlatBag a) where
+ get bh = do
+ xs <- get bh
+ evaluate $ fromList (fromIntegral $ length xs) xs
+
+ put_ bh = put_ bh . elemsFlatBag
+
-- | Create an empty 'FlatBag'.
--
-- The empty 'FlatBag' is shared over all instances.
@@ -129,4 +138,3 @@ fromSmallArray s = case sizeofSmallArray s of
1 -> UnitFlatBag (indexSmallArray s 0)
2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)
_ -> FlatBag s
-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -305,6 +305,8 @@ import Data.Bifunctor
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable
+import GHC.ByteCode.Serialize
+
{- **********************************************************************
%* *
Initialisation
@@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv
-> ModLocation
-> IO (CompiledByteCode, [FilePath])
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location
+ comp_bc <- testBinByteCode hsc_env comp_bc'
compile_for_interpreter hsc_env $ \ i_env -> do
stub_o <- traverse (compileForeign i_env LangC) hasStub
foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -125,6 +125,7 @@ import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Data.TrieMap
+import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
@@ -133,6 +134,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHCi.FFI
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -929,6 +931,12 @@ instance Binary Char where
put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+instance Binary Word where
+ put_ bh i = put_ bh (fromIntegral i :: Word64)
+ get bh = do
+ x <- get bh
+ return $! (fromIntegral (x :: Word64))
+
instance Binary Int where
put_ bh i = put_ bh (fromIntegral i :: Int64)
get bh = do
@@ -2163,3 +2171,35 @@ instance Binary a => Binary (FingerprintWithValue a) where
instance NFData a => NFData (FingerprintWithValue a) where
rnf (FingerprintWithValue fp mflags)
= rnf fp `seq` rnf mflags `seq` ()
+
+instance Binary FFIType where
+ get bh = do
+ t <- getByte bh
+ evaluate $ case t of
+ 0 -> FFIVoid
+ 1 -> FFIPointer
+ 2 -> FFIFloat
+ 3 -> FFIDouble
+ 4 -> FFISInt8
+ 5 -> FFISInt16
+ 6 -> FFISInt32
+ 7 -> FFISInt64
+ 8 -> FFIUInt8
+ 9 -> FFIUInt16
+ 10 -> FFIUInt32
+ 11 -> FFIUInt64
+ _ -> panic "Binary FFIType: invalid byte"
+
+ put_ bh t = putByte bh $ case t of
+ FFIVoid -> 0
+ FFIPointer -> 1
+ FFIFloat -> 2
+ FFIDouble -> 3
+ FFISInt8 -> 4
+ FFISInt16 -> 5
+ FFISInt32 -> 6
+ FFISInt64 -> 7
+ FFIUInt8 -> 8
+ FFIUInt16 -> 9
+ FFIUInt32 -> 10
+ FFIUInt64 -> 11
=====================================
compiler/ghc.cabal.in
=====================================
@@ -228,6 +228,7 @@ Library
GHC.ByteCode.InfoTable
GHC.ByteCode.Instr
GHC.ByteCode.Linker
+ GHC.ByteCode.Serialize
GHC.ByteCode.Types
GHC.Cmm
GHC.Cmm.BlockId
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/759209aef7b1c66d26e65178e3403e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/759209aef7b1c66d26e65178e3403e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bytecode-serialize-3] 16 commits: level imports: Check the level of exported identifiers
by Cheng Shao (＠TerrorJack) 10 Aug '25
by Cheng Shao (＠TerrorJack) 10 Aug '25
10 Aug '25
Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC
Commits:
246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00
level imports: Check the level of exported identifiers
The level imports specification states that exported identifiers have to
be at level 0. This patch adds the requird level checks that all
explicitly mentioned identifiers occur at level 0.
For implicit export specifications (T(..) and module B), only level 0
identifiers are selected for re-export.
ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705
Fixes #26090
- - - - -
358bc4fc by fendor at 2025-08-07T06:59:12-04:00
Bump GHC on darwin CI to 9.10.1
- - - - -
1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00
ipe: Place strings and metadata into specific .ipe section
By placing the .ipe metadata into a specific section it can be stripped
from the final binary if desired.
```
objcopy --remove-section .ipe <binary>
upx <binary>
```
Towards #21766
- - - - -
c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Place magic word at the start of entries in the .ipe section
The magic word "IPE\nIPE\n" is placed at the start of .ipe sections,
then if the section is stripped, we can check whether the section starts
with the magic word or not to determine whether there is metadata
present or not.
Towards #21766
- - - - -
cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Use stable IDs for IPE entries
IPEs have historically been indexed and reported by their address.
This makes it impossible to compare profiles between runs, since the
addresses may change (due to ASLR) and also makes it tricky to separate
out the IPE map from the binary.
This small patch adds a stable identifier for each IPE entry.
The stable identifier is a single 64 bit word. The high-bits are a
per-module identifier and the low bits identify which entry in each
module.
1. When a node is added into the IPE buffer it is assigned a unique
identifier from an incrementing global counter.
2. Each entry already has an index by it's position in the
`IpeBufferListNode`.
The two are combined together by the `IPE_ENTRY_KEY` macro.
Info table profiling uses the stable identifier rather than the address
of the info table.
The benefits of this change are:
* Profiles from different runs can be easily compared
* The metadata can be extracted from the binary (via the eventlog for
example) and then stripped from the executable.
Fixes #21766
- - - - -
2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00
In TcSShortCut, typechecker plugins should get empty Givens
Solving in TcShortCut mode means /ignoring the Givens/. So we
should not pass them to typechecker plugins!
Fixes #26258.
This is a fixup to the earlier MR:
commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Jul 21 10:04:49 2025 +0100
Improve treatment of SPECIALISE pragmas -- again!
- - - - -
2157db2d by sterni at 2025-08-08T15:32:39-04:00
hadrian: enable terminfo if --with-curses-* flags are given
The GHC make build system used to support WITH_TERMINFO in ghc.mk which
allowed controlling whether to build GHC with terminfo or not. hadrian
has replaced this with a system where this is effectively controlled by
the cross-compiling setting (the default WITH_TERMINFO value was bassed
on CrossCompiling, iirc).
This behavior is undesireable in some cases and there is not really a
good way to work around it. Especially for downstream packagers,
modifying this via UserSettings is not really feasible since such a
source file has to be kept in sync with Settings/Default.hs manually
since it can't import Settings.Default or any predefined Flavour
definitions.
To avoid having to add a new setting to cfg/system.config and/or a new
configure flag (though I'm happy to implement both if required), I've
chosen to take --with-curses-* being set explicitly as an indication
that the user wants to have terminfo enabled. This would work for
Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which
goes to some extreme measures [3] [4] to force terminfo in all scenarios).
In general, I'm an advocate for making the GHC build be the same for
native and cross insofar it is possible since it makes packaging GHC and
Haskell related things while still supporting cross much less
compilicated. A more minimal GHC with reduced dependencies should
probably be a specific flavor, not the default.
Partially addresses #26288 by forcing terminfo to be built if the user
explicitly passes configure flags related to it. However, it isn't built
by default when cross-compiling yet nor is there an explicit way to
control the package being built.
[1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376…
[2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
- - - - -
b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00
Add default QuasiQuoters
Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier
to write `QuasiQuoters` that give helpful error messages when they're
used in inappropriate contexts.
Closes #24434.
- - - - -
9bf81834 by Rodrigo Mesquita at 2025-08-10T11:18:26+00:00
cleanup: Move dehydrateCgBreakInfo to Stg2Bc
This no longer has anything to do with Core.
- - - - -
d6335551 by Rodrigo Mesquita at 2025-08-10T11:18:26+00:00
rts/Disassembler: Fix spacing of BRK_FUN
- - - - -
4dd9b18b by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00
debugger: Fix bciPtr in Step-out
We need to use `BCO_NEXT` to move bciPtr to ix=1, because ix=0 points to
the instruction itself!
I do not understand how this didn't crash before.
- - - - -
a75fafd4 by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00
debugger: Allow BRK_FUNs to head case continuation BCOs
When we start executing a BCO, we may want to yield to the scheduler:
this may be triggered by a heap/stack check, context switch, or a
breakpoint. To yield, we need to put the stack in a state such that
when execution is resumed we are back to where we yielded from.
Previously, a BKR_FUN could only head a function BCO because we only
knew how to construct a valid stack for yielding from one -- simply add
`apply_interp_info` + the BCO to resume executing. This is valid because
the stack at the start of run_BCO is headed by that BCO's arguments.
However, in case continuation BCOs (as per Note [Case continuation BCOs]),
we couldn't easily reconstruct a valid stack that could be resumed
because we dropped too soon the stack frames regarding the value
returned (stg_ret) and received (stg_ctoi) by that continuation.
This is especially tricky because of the variable type and size return
frames (e.g. pointer ret_p/ctoi_R1p vs a tuple ret_t/ctoi_t2).
The trick to being able to yield from a BRK_FUN at the start of a case
cont BCO is to stop removing the ret frame headers eagerly and instead
keep them until the BCO starts executing. The new layout at the start of
a case cont. BCO is described by the new Note [Stack layout when entering run_BCO].
Now, we keep the ret_* and ctoi_* frames when entering run_BCO.
A BRK_FUN is then executed if found, and the stack is yielded as-is with
the preserved ret and ctoi frames.
Then, a case cont BCO's instructions always SLIDE off the headers of the
ret and ctoi frames, in StgToByteCode.doCase, turning a stack like
| .... |
+---------------+
| fv2 |
+---------------+
| fv1 |
+---------------+
| BCO |
+---------------+
| stg_ctoi_ret_ |
+---------------+
| retval |
+---------------+
| stg_ret_..... |
+---------------+
into
| .... |
+---------------+
| fv2 |
+---------------+
| fv1 |
+---------------+
| retval |
+---------------+
for the remainder of the BCO.
Moreover, this more uniform approach of keeping the ret and ctoi frames
means we need less ad-hoc logic concerning the variable size of
ret_tuple vs ret_p/np frames in the code generator and interpreter:
Always keep the return to cont. stack intact at the start of run_BCO,
and the statically generated instructions will take care of adjusting
it.
Unlocks BRK_FUNs at the start of case cont. BCOs which will enable a
better user-facing step-out (#26042) which is free of the bugs the
current BRK_ALTS implementation suffers from (namely, using BRK_FUN
rather than BRK_ALTS in a case cont. means we'll never accidentally end
up in a breakpoint "deeper" than the continuation, because we stop at
the case cont itself rather than on the first breakpoint we evaluate
after it).
- - - - -
f03ef9d3 by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00
BRK_FUN with InternalBreakLocs for code-generation time breakpoints
At the start of a case continuation BCO, place a BRK_FUN.
This BRK_FUN uses the new "internal breakpoint location" -- allowing us
to come up with a valid source location for this breakpoint that is not associated with a source-level tick.
For case continuation BCOs, we use the last tick seen before it as the
source location. The reasoning is described in Note [Debugger: Stepout internal break locs].
Note how T26042c, which was broken because it displayed the incorrect
behavior of the previous step out when we'd end up at a deeper level
than the one from which we initiated step-out, is now fixed.
As of this commit, BRK_ALTS is now dead code and is thus dropped.
Note [Debugger: Stepout internal break locs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Step-out tells the interpreter to run until the current function
returns to where it was called from, and stop there.
This is achieved by enabling the BRK_FUN found on the first RET_BCO
frame on the stack (See [Note Debugger: Step-out]).
Case continuation BCOs (which select an alternative branch) must
therefore be headed by a BRK_FUN. An example:
f x = case g x of <--- end up here
1 -> ...
2 -> ...
g y = ... <--- step out from here
- `g` will return a value to the case continuation BCO in `f`
- The case continuation BCO will receive the value returned from g
- Match on it and push the alternative continuation for that branch
- And then enter that alternative.
If we step-out of `g`, the first RET_BCO on the stack is the case
continuation of `f` -- execution should stop at its start, before
selecting an alternative. (One might ask, "why not enable the breakpoint
in the alternative instead?", because the alternative continuation is
only pushed to the stack *after* it is selected by the case cont. BCO)
However, the case cont. BCO is not associated with any source-level
tick, it is merely the glue code which selects alternatives which do
have source level ticks. Therefore, we have to come up at code
generation time with a breakpoint location ('InternalBreakLoc') to
display to the user when it is stopped there.
Our solution is to use the last tick seen just before reaching the case
continuation. This is robust because a case continuation will thus
always have a relevant breakpoint location:
- The source location will be the last source-relevant expression
executed before the continuation is pushed
- So the source location will point to the thing you've just stepped
out of
- Doing :step-local from there will put you on the selected
alternative (which at the source level may also be the e.g. next
line in a do-block)
Examples, using angle brackets (<<...>>) to denote the breakpoint span:
f x = case <<g x>> {- step in here -} of
1 -> ...
2 -> ...>
g y = <<...>> <--- step out from here
...
f x = <<case g x of <--- end up here, whole case highlighted
1 -> ...
2 -> ...>>
doing :step-local ...
f x = case g x of
1 -> <<...>> <--- stop in the alternative
2 -> ...
A second example based on T26042d2, where the source is a do-block IO
action, optimised to a chain of `case expressions`.
main = do
putStrLn "hello1"
<<f>> <--- step-in here
putStrLn "hello3"
putStrLn "hello4"
f = do
<<putStrLn "hello2.1">> <--- step-out from here
putStrLn "hello2.2"
...
main = do
putStrLn "hello1"
<<f>> <--- end up here again, the previously executed expression
putStrLn "hello3"
putStrLn "hello4"
doing step/step-local ...
main = do
putStrLn "hello1"
f
<<putStrLn "hello3">> <--- straight to the next line
putStrLn "hello4"
Finishes #26042
- - - - -
52ba24df by Rodrigo Mesquita at 2025-08-10T11:18:27+00:00
debugger: Re-use the last BreakpointId whole in step-out
Previously, to come up with a location to stop at for `:stepout`, we
would store the location of the last BreakpointId surrounding the
continuation, as described by Note [Debugger: Stepout internal break locs].
However, re-using just the location from the last source breakpoint
isn't sufficient to provide the necessary information in the break
location. Specifically, it wouldn't bind any variables at that location.
Really, there is no reason not to re-use the last breakpoint wholesale,
and re-use all the information we had there. Step-out should behave just
as if we had stopped at the call, but s.t. continuing will not
re-execute the call.
This commit updates the CgBreakInfo to always store a BreakpointId, be
it the original one or the one we're emulating (for step-out).
It makes variable bindings on :stepout work
- - - - -
0fe77f20 by Cheng Shao at 2025-08-10T11:18:27+00:00
compiler: WIP GHC.ByteCode.Serialize
- - - - -
759209ae by Cheng Shao at 2025-08-10T11:18:27+00:00
driver: test bytecode roundtrip serialization
- - - - -
72 changed files:
- .gitlab/darwin/toolchain.nix
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Instr.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Cmm.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
- docs/users_guide/debug-info.rst
- ghc/GHCi/UI.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghci/GHCi/Run.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/changelog.md
- rts/Disassembler.c
- rts/IPE.c
- rts/Interpreter.c
- rts/ProfHeap.c
- rts/Profiling.c
- rts/eventlog/EventLog.c
- rts/include/rts/Bytecodes.h
- rts/include/rts/IPE.h
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/ghci.debugger/scripts/T26042b.script
- testsuite/tests/ghci.debugger/scripts/T26042b.stdout
- testsuite/tests/ghci.debugger/scripts/T26042c.script
- testsuite/tests/ghci.debugger/scripts/T26042c.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042d2.hs
- + testsuite/tests/ghci.debugger/scripts/T26042d2.script
- + testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042e.stdout
- testsuite/tests/ghci.debugger/scripts/T26042f.script
- testsuite/tests/ghci.debugger/scripts/T26042f1.stdout
- testsuite/tests/ghci.debugger/scripts/T26042f2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042g.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/rts/ipe/ipeMap.c
- testsuite/tests/rts/ipe/ipe_lib.c
- + testsuite/tests/splice-imports/DodgyLevelExport.hs
- + testsuite/tests/splice-imports/DodgyLevelExport.stderr
- + testsuite/tests/splice-imports/DodgyLevelExportA.hs
- + testsuite/tests/splice-imports/LevelImportExports.hs
- + testsuite/tests/splice-imports/LevelImportExports.stdout
- + testsuite/tests/splice-imports/LevelImportExportsA.hs
- testsuite/tests/splice-imports/Makefile
- + testsuite/tests/splice-imports/ModuleExport.hs
- + testsuite/tests/splice-imports/ModuleExport.stderr
- + testsuite/tests/splice-imports/ModuleExportA.hs
- + testsuite/tests/splice-imports/ModuleExportB.hs
- + testsuite/tests/splice-imports/T26090.hs
- + testsuite/tests/splice-imports/T26090.stderr
- + testsuite/tests/splice-imports/T26090A.hs
- testsuite/tests/splice-imports/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0b466a55f49aecfdd59bf9d29fbe9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0b466a55f49aecfdd59bf9d29fbe9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
09 Aug '25
Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC
Commits:
611f3f3b by Simon Hengel at 2025-08-10T10:12:54+07:00
Remove JSON logging
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -368,7 +368,7 @@ msg msg = do
name_ppr_ctx <- getNamePprCtx
let m = case msg of
MCDump doc -> MCDump (dump_sty doc)
- MCDiagnostic span severity reason code doc -> UnsafeMCDiagnostic span severity reason code (err_sty doc)
+ UnsafeMCDiagnostic span severity reason code doc diagnostic -> UnsafeMCDiagnostic span severity reason code (err_sty doc) diagnostic
MCOutput doc -> MCOutput (user_sty doc)
MCFatal doc -> MCFatal (user_sty doc)
MCInteractive doc -> MCInteractive (user_sty doc)
=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -47,18 +47,15 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) .
printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
printMessage logger msg_opts opts message = do
- decorated <- decorateDiagnostic logflags (messageClass doc) location
- if log_diags_as_json then do
- let
- rendered :: String
- rendered = renderWithContext (log_default_user_context logflags) decorated
-
- jsonMessage :: JsonDoc
- jsonMessage = jsonDiagnostic rendered message
-
- logJsonMsg logger (messageClass decorated) jsonMessage
- else do
- logMsg logger (messageClass decorated)
+ decorated <- decorateDiagnostic logflags location severity reason code doc
+ let
+ rendered :: String
+ rendered = renderWithContext (log_default_user_context logflags) decorated
+
+ jsonMessage :: JsonDoc
+ jsonMessage = jsonDiagnostic rendered message
+
+ logMsg logger $ UnsafeMCDiagnostic location severity reason code decorated jsonMessage
where
logflags :: LogFlags
logflags = logFlags logger
@@ -66,9 +63,6 @@ printMessage logger msg_opts opts message = do
doc :: SDoc
doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
- messageClass :: SDoc -> Message
- messageClass = UnsafeMCDiagnostic location severity (errMsgReason message) (diagnosticCode diagnostic)
-
style :: PprStyle
style = mkErrStyle (errMsgContext message)
@@ -84,6 +78,12 @@ printMessage logger msg_opts opts message = do
severity :: Severity
severity = errMsgSeverity message
+ reason :: ResolvedDiagnosticReason
+ reason = errMsgReason message
+
+ code :: Maybe DiagnosticCode
+ code = diagnosticCode diagnostic
+
messageWithHints :: a -> SDoc
messageWithHints e =
let main_msg = formatBulleted $ diagnosticMessage msg_opts e
@@ -93,21 +93,18 @@ printMessage logger msg_opts opts message = do
hs -> main_msg $$ hang (text "Suggested fixes:") 2
(formatBulleted $ mkDecorated . map ppr $ hs)
- log_diags_as_json :: Bool
- log_diags_as_json = log_diagnostics_as_json (logFlags logger)
-
-decorateDiagnostic :: LogFlags -> Message -> SrcSpan -> IO SDoc
-decorateDiagnostic logflags msg srcSpan = addCaret
+decorateDiagnostic :: LogFlags -> SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> IO SDoc
+decorateDiagnostic logflags span severity reason code doc = addCaret
where
-- Pretty print the warning flag, if any (#10752)
message :: SDoc
- message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg srcSpan
+ message = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc
addCaret :: IO SDoc
addCaret = do
caretDiagnostic <-
if log_show_caret logflags
- then getCaretDiagnostic msg srcSpan
+ then getCaretDiagnostic severity span
else pure empty
return $ getPprStyle $ \style ->
withPprStyle (setStyleColoured True style)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1445,9 +1445,9 @@ withDeferredDiagnostics f = do
let deferDiagnostics _dflags !msg = do
let action = logMsg logger msg
case msg of
- MCDiagnostic _ SevWarning _reason _code _
+ MCDiagnostic _ SevWarning _reason _code
-> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())
- MCDiagnostic _ SevError _reason _code _
+ MCDiagnostic _ SevError _reason _code
-> atomicModifyIORef' errors $ \(!i) -> (action: i, ())
MCFatal _
-> atomicModifyIORef' fatals $ \(!i) -> (action: i, ())
=====================================
compiler/GHC/Driver/Monad.hs
=====================================
@@ -23,8 +23,6 @@ module GHC.Driver.Monad (
modifyLogger,
pushLogHookM,
popLogHookM,
- pushJsonLogHookM,
- popJsonLogHookM,
putLogMsgM,
putMsgM,
withTimingM,
@@ -122,12 +120,6 @@ pushLogHookM = modifyLogger . pushLogHook
popLogHookM :: GhcMonad m => m ()
popLogHookM = modifyLogger popLogHook
-pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m ()
-pushJsonLogHookM = modifyLogger . pushJsonLogHook
-
-popJsonLogHookM :: GhcMonad m => m ()
-popJsonLogHookM = modifyLogger popJsonLogHook
-
-- | Put a log message
putMsgM :: GhcMonad m => SDoc -> m ()
putMsgM doc = do
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -70,7 +70,6 @@ module GHC.Types.Error
, mapDecoratedSDoc
, pprMessageBag
- , mkLocMessageWarningGroups
, formatLocMessage
, formatFatalLocMessage
, formatDiagnostic
@@ -493,7 +492,7 @@ data Message
-- ^ Log messages intended for end users.
-- No file\/line\/column stuff.
- | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc
+ | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc
-- ^ Diagnostics from the compiler. This constructor is very powerful as
-- it allows the construction of a 'Message' with a completely
-- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
@@ -509,8 +508,8 @@ data Message
-- should always have a 'DiagnosticCode'. See Note [Diagnostic codes].
{-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-}
-pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> Message
-pattern MCDiagnostic span severity reason code doc <- UnsafeMCDiagnostic span severity reason code doc
+pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message
+pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json
{-
Note [Suppressing Messages]
@@ -635,25 +634,9 @@ showMsgEnvelope err =
pprMessageBag :: Bag SDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
--- | Make an error message with location info, specifying whether to show
--- warning groups (if applicable).
-mkLocMessageWarningGroups
- :: Bool -- ^ Print warning groups (if applicable)?
- -> Message -- ^ message
- -> SrcSpan -- ^ location
- -> SDoc
-mkLocMessageWarningGroups show_warn_groups msg locn
- = case msg of
- MCDiagnostic span severity reason code doc -> formatDiagnostic show_warn_groups span severity reason code doc
- MCFatal doc -> formatFatalLocMessage locn doc
- MCOutput doc -> formatLocMessage locn doc
- MCInteractive doc -> formatLocMessage locn doc
- MCDump doc -> formatLocMessage locn doc
- MCInfo doc -> formatLocMessage locn doc
-
formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc
formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme ->
- let msg_title = coloured (fatalColour col_scheme) $ text "fatal"
+ let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal"
in formatLocMessageWarningGroups locn msg_title empty empty msg
formatLocMessage :: SrcSpan -> SDoc -> SDoc
@@ -770,23 +753,15 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
in coloured (Col.sMessage col_scheme)
$ hang (coloured (Col.sHeader col_scheme) header) 4 msg
-getMessageClassColour :: Message -> Col.Scheme -> Col.PprColour
-getMessageClassColour (MCDiagnostic _span severity _reason _code _) = getSeverityColour severity
-getMessageClassColour (MCFatal _) = fatalColour
-getMessageClassColour _ = const mempty
-
-fatalColour :: Col.Scheme -> Col.PprColour
-fatalColour = Col.sFatal
-
getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour severity = case severity of
SevError -> Col.sError
SevWarning -> Col.sWarning
SevIgnore -> const mempty
-getCaretDiagnostic :: Message -> SrcSpan -> IO SDoc
+getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
-getCaretDiagnostic msg (RealSrcSpan span _) =
+getCaretDiagnostic severity (RealSrcSpan span _) =
caretDiagnostic <$> getSrcLine (srcSpanFile span) row
where
getSrcLine fn i =
@@ -819,7 +794,7 @@ getCaretDiagnostic msg (RealSrcSpan span _) =
caretDiagnostic Nothing = empty
caretDiagnostic (Just srcLineWithNewline) =
sdocOption sdocColScheme$ \col_scheme ->
- let sevColour = getMessageClassColour msg col_scheme
+ let sevColour = getSeverityColour severity col_scheme
marginColour = Col.sMargin col_scheme
in
coloured marginColour (text marginSpace) <>
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -24,7 +24,6 @@ module GHC.Utils.Logger
-- * Logger setup
, initLogger
, LogAction
- , LogJsonAction
, DumpAction
, TraceAction
, DumpFormat (..)
@@ -32,8 +31,6 @@ module GHC.Utils.Logger
-- ** Hooks
, popLogHook
, pushLogHook
- , popJsonLogHook
- , pushJsonLogHook
, popDumpHook
, pushDumpHook
, popTraceHook
@@ -55,11 +52,9 @@ module GHC.Utils.Logger
, putLogMsg
, defaultLogAction
, defaultLogActionWithHandles
- , defaultLogJsonAction
, defaultLogActionHPrintDoc
, defaultLogActionHPutStrDoc
, logMsg
- , logJsonMsg
, logDumpMsg
-- * Dumping
@@ -86,8 +81,8 @@ import GHC.Types.Error
import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.Outputable
-import GHC.Utils.Json
import GHC.Utils.Panic
+import GHC.Utils.Json (renderJSON)
import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
@@ -181,11 +176,6 @@ type LogAction = LogFlags
-> Message
-> IO ()
-type LogJsonAction = LogFlags
- -> Message
- -> JsonDoc
- -> IO ()
-
type DumpAction = LogFlags
-> PprStyle
-> DumpFlag
@@ -223,9 +213,6 @@ data Logger = Logger
{ log_hook :: [LogAction -> LogAction]
-- ^ Log hooks stack
- , json_log_hook :: [LogJsonAction -> LogJsonAction]
- -- ^ Json log hooks stack
-
, dump_hook :: [DumpAction -> DumpAction]
-- ^ Dump hooks stack
@@ -261,7 +248,6 @@ initLogger = do
dumps <- newMVar Map.empty
return $ Logger
{ log_hook = []
- , json_log_hook = []
, dump_hook = []
, trace_hook = []
, generated_dumps = dumps
@@ -273,10 +259,6 @@ initLogger = do
putLogMsg :: Logger -> LogAction
putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)
--- | Log a JsonDoc
-putJsonLogMsg :: Logger -> LogJsonAction
-putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger)
-
-- | Dump something
putDumpFile :: Logger -> DumpAction
putDumpFile logger =
@@ -301,15 +283,6 @@ popLogHook logger = case log_hook logger of
[] -> panic "popLogHook: empty hook stack"
_:hs -> logger { log_hook = hs }
--- | Push a json log hook
-pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger
-pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger }
-
-popJsonLogHook :: Logger -> Logger
-popJsonLogHook logger = case json_log_hook logger of
- [] -> panic "popJsonLogHook: empty hook stack"
- _:hs -> logger { json_log_hook = hs}
-
-- | Push a dump hook
pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }
@@ -353,22 +326,6 @@ makeThreadSafe logger = do
$ pushTraceHook trc
$ logger
-defaultLogJsonAction :: LogJsonAction
-defaultLogJsonAction logflags msg_class jsdoc =
- case msg_class of
- MCOutput _ -> printOut msg
- MCDump _ -> printOut (msg $$ blankLine)
- MCInteractive _ -> putStrSDoc msg
- MCInfo _ -> printErrs msg
- MCFatal _ -> printErrs msg
- MCDiagnostic _ SevIgnore _ _ _ -> pure () -- suppress the message
- MCDiagnostic _span _sev _rea _code _ -> printErrs msg
- where
- printOut = defaultLogActionHPrintDoc logflags False stdout
- printErrs = defaultLogActionHPrintDoc logflags False stderr
- putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
- msg = renderJSON jsdoc
-
-- | The default 'LogAction' prints to 'stdout' and 'stderr'.
--
-- To replicate the default log action behaviour with different @out@ and @err@
@@ -386,8 +343,12 @@ defaultLogActionWithHandles out err logflags message
MCInteractive msg -> putStrSDoc msg
MCInfo msg -> printErrs msg
MCFatal msg -> printErrs msg
- MCDiagnostic _ SevIgnore _ _ _ -> pure () -- suppress the message
- MCDiagnostic _span _sev _rea _code msg -> printErrs msg
+ MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message
+ UnsafeMCDiagnostic _span _severity _reason _code doc json -> do
+ if log_diagnostics_as_json logflags then do
+ printErrs (renderJSON json)
+ else do
+ printErrs doc
where
printOut = defaultLogActionHPrintDoc logflags False out
printErrs = defaultLogActionHPrintDoc logflags False err
@@ -534,9 +495,6 @@ defaultTraceAction logflags title doc x =
logMsg :: Logger -> Message -> IO ()
logMsg logger = putLogMsg logger (logFlags logger)
-logJsonMsg :: Logger -> Message -> JsonDoc -> IO ()
-logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
-
-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile logger = putDumpFile logger (logFlags logger)
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -836,7 +836,7 @@ ghciLogAction lastErrLocations old_log_action
dflags msg = do
old_log_action dflags msg
case msg of
- MCDiagnostic srcSpan SevError _reason _code _ -> case srcSpan of
+ MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of
RealSrcSpan rsp _ -> modifyIORef lastErrLocations
(++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
_ -> return ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/611f3f3b4e9bf7eeabc814f5668e1b2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/611f3f3b4e9bf7eeabc814f5668e1b2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/remove-ddump-json] 20 commits: README: Add note on ghc.nix
by Simon Hengel (＠sol) 09 Aug '25
by Simon Hengel (＠sol) 09 Aug '25
09 Aug '25
Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC
Commits:
69cc16ca by Marc Scholten at 2025-08-06T15:51:28-04:00
README: Add note on ghc.nix
- - - - -
93a2f450 by Daniel Díaz at 2025-08-06T15:52:14-04:00
Link to the "Strict Bindings" docs from the linear types docs
Strict Bidings are relevant for the kinds of multiplicity annotations
linear lets support.
- - - - -
246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00
level imports: Check the level of exported identifiers
The level imports specification states that exported identifiers have to
be at level 0. This patch adds the requird level checks that all
explicitly mentioned identifiers occur at level 0.
For implicit export specifications (T(..) and module B), only level 0
identifiers are selected for re-export.
ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705
Fixes #26090
- - - - -
358bc4fc by fendor at 2025-08-07T06:59:12-04:00
Bump GHC on darwin CI to 9.10.1
- - - - -
1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00
ipe: Place strings and metadata into specific .ipe section
By placing the .ipe metadata into a specific section it can be stripped
from the final binary if desired.
```
objcopy --remove-section .ipe <binary>
upx <binary>
```
Towards #21766
- - - - -
c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Place magic word at the start of entries in the .ipe section
The magic word "IPE\nIPE\n" is placed at the start of .ipe sections,
then if the section is stripped, we can check whether the section starts
with the magic word or not to determine whether there is metadata
present or not.
Towards #21766
- - - - -
cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00
ipe: Use stable IDs for IPE entries
IPEs have historically been indexed and reported by their address.
This makes it impossible to compare profiles between runs, since the
addresses may change (due to ASLR) and also makes it tricky to separate
out the IPE map from the binary.
This small patch adds a stable identifier for each IPE entry.
The stable identifier is a single 64 bit word. The high-bits are a
per-module identifier and the low bits identify which entry in each
module.
1. When a node is added into the IPE buffer it is assigned a unique
identifier from an incrementing global counter.
2. Each entry already has an index by it's position in the
`IpeBufferListNode`.
The two are combined together by the `IPE_ENTRY_KEY` macro.
Info table profiling uses the stable identifier rather than the address
of the info table.
The benefits of this change are:
* Profiles from different runs can be easily compared
* The metadata can be extracted from the binary (via the eventlog for
example) and then stripped from the executable.
Fixes #21766
- - - - -
2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-04:00
In TcSShortCut, typechecker plugins should get empty Givens
Solving in TcShortCut mode means /ignoring the Givens/. So we
should not pass them to typechecker plugins!
Fixes #26258.
This is a fixup to the earlier MR:
commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Jul 21 10:04:49 2025 +0100
Improve treatment of SPECIALISE pragmas -- again!
- - - - -
2157db2d by sterni at 2025-08-08T15:32:39-04:00
hadrian: enable terminfo if --with-curses-* flags are given
The GHC make build system used to support WITH_TERMINFO in ghc.mk which
allowed controlling whether to build GHC with terminfo or not. hadrian
has replaced this with a system where this is effectively controlled by
the cross-compiling setting (the default WITH_TERMINFO value was bassed
on CrossCompiling, iirc).
This behavior is undesireable in some cases and there is not really a
good way to work around it. Especially for downstream packagers,
modifying this via UserSettings is not really feasible since such a
source file has to be kept in sync with Settings/Default.hs manually
since it can't import Settings.Default or any predefined Flavour
definitions.
To avoid having to add a new setting to cfg/system.config and/or a new
configure flag (though I'm happy to implement both if required), I've
chosen to take --with-curses-* being set explicitly as an indication
that the user wants to have terminfo enabled. This would work for
Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which
goes to some extreme measures [3] [4] to force terminfo in all scenarios).
In general, I'm an advocate for making the GHC build be the same for
native and cross insofar it is possible since it makes packaging GHC and
Haskell related things while still supporting cross much less
compilicated. A more minimal GHC with reduced dependencies should
probably be a specific flavor, not the default.
Partially addresses #26288 by forcing terminfo to be built if the user
explicitly passes configure flags related to it. However, it isn't built
by default when cross-compiling yet nor is there an explicit way to
control the package being built.
[1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376…
[2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
[4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa…
- - - - -
b3c31488 by David Feuer at 2025-08-08T15:33:21-04:00
Add default QuasiQuoters
Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier
to write `QuasiQuoters` that give helpful error messages when they're
used in inappropriate contexts.
Closes #24434.
- - - - -
397763da by Simon Hengel at 2025-08-10T06:12:02+07:00
Refactoring: Don't misuse `MCDiagnostic` for lint messages
`MCDiagnostic` is meant to be used for compiler diagnostics.
Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json`
(see e.g. !14475, !14492 !14548).
To avoid this in the future I want to control more narrowly who creates
`MCDiagnostic` (see #24113).
Some parts of the compiler use `MCDiagnostic` purely for formatting
purposes, without creating any real compiler diagnostics. This change
introduces a helper function, `formatDiagnostic`, that can be used in
such cases instead of constructing `MCDiagnostic`.
- - - - -
c6392ebb by Simon Hengel at 2025-08-10T06:12:02+07:00
Rename MCDiagnostic to UnsafeMCDiagnostic
- - - - -
1fee223a by Simon Hengel at 2025-08-10T06:12:02+07:00
Remove -ddump-json (fixes #24113)
- - - - -
8873732c by Simon Hengel at 2025-08-10T06:12:02+07:00
Add SrcSpan to MCDiagnostic
- - - - -
f60aac7a by Simon Hengel at 2025-08-10T06:12:02+07:00
Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg
- - - - -
c6b49448 by Simon Hengel at 2025-08-10T06:12:02+07:00
Get rid of mkLocMessage
- - - - -
34d6baea by Simon Hengel at 2025-08-10T06:12:02+07:00
Add Message data type
- - - - -
1f5a353e by Simon Hengel at 2025-08-10T06:12:02+07:00
Get rid of MessageClass
- - - - -
4c776200 by Simon Hengel at 2025-08-10T06:12:02+07:00
Rename DiagnosticMessage to GenericDiagnosticMessage
- - - - -
b6f47d1e by Simon Hengel at 2025-08-10T09:34:48+07:00
Remove JSON logging
- - - - -
78 changed files:
- .gitlab/darwin/toolchain.nix
- README.md
- compiler/GHC/Cmm.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/LogQueue.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/SourceError.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debug-info.rst
- docs/users_guide/debugging.rst
- docs/users_guide/exts/linear_types.rst
- docs/users_guide/exts/strict.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/changelog.md
- rts/IPE.c
- rts/ProfHeap.c
- rts/eventlog/EventLog.c
- rts/include/rts/IPE.h
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/rts/ipe/ipeMap.c
- testsuite/tests/rts/ipe/ipe_lib.c
- + testsuite/tests/splice-imports/DodgyLevelExport.hs
- + testsuite/tests/splice-imports/DodgyLevelExport.stderr
- + testsuite/tests/splice-imports/DodgyLevelExportA.hs
- + testsuite/tests/splice-imports/LevelImportExports.hs
- + testsuite/tests/splice-imports/LevelImportExports.stdout
- + testsuite/tests/splice-imports/LevelImportExportsA.hs
- testsuite/tests/splice-imports/Makefile
- + testsuite/tests/splice-imports/ModuleExport.hs
- + testsuite/tests/splice-imports/ModuleExport.stderr
- + testsuite/tests/splice-imports/ModuleExportA.hs
- + testsuite/tests/splice-imports/ModuleExportB.hs
- + testsuite/tests/splice-imports/T26090.hs
- + testsuite/tests/splice-imports/T26090.stderr
- + testsuite/tests/splice-imports/T26090A.hs
- testsuite/tests/splice-imports/all.T
- utils/check-exact/Main.hs
- utils/check-exact/Preprocess.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42b5dedbd311deb03c020557d389c1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42b5dedbd311deb03c020557d389c1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23162-spj] Start to extend to equalities
by Simon Peyton Jones (＠simonpj) 09 Aug '25
by Simon Peyton Jones (＠simonpj) 09 Aug '25
09 Aug '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
02401833 by Simon Peyton Jones at 2025-08-10T00:14:42+01:00
Start to extend to equalities
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Solver/Monad.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -21,7 +21,7 @@ import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc
import GHC.Tc.Types.Origin
import GHC.Tc.Types.EvTerm( evCallStack )
-import GHC.Tc.Solver.FunDeps( doDictFunDepImprovement )
+import GHC.Tc.Solver.FunDeps( tryDictFunDeps )
import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Monad
import GHC.Tc.Solver.Types
@@ -95,7 +95,7 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
-- Try fundeps /after/ tryInstances:
-- see (DFL2) in Note [Do fundeps last]
- ; doDictFunDepImprovement dict_ct
+ ; tryDictFunDeps dict_ct
; simpleStage (updInertDicts dict_ct)
; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" }
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -16,9 +16,8 @@ import GHC.Tc.Solver.Irred( solveIrred )
import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance )
import GHC.Tc.Solver.Rewrite
import GHC.Tc.Solver.Monad
-import GHC.Tc.Solver.FunDeps( unifyAndEmitFunDepWanteds )
+import GHC.Tc.Solver.FunDeps( tryEqFunDeps )
import GHC.Tc.Solver.InertSet
-import GHC.Tc.Solver.Types( findFunEqsByTyCon )
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc
@@ -26,7 +25,6 @@ import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.TcType
import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
-import GHC.Tc.Instance.FunDeps( FunDepEqn(..) )
import qualified GHC.Tc.Utils.Monad as TcM
import GHC.Core.Type
@@ -36,21 +34,15 @@ import GHC.Core.DataCon ( dataConName )
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking
import GHC.Core.Coercion
-import GHC.Core.Coercion.Axiom
import GHC.Core.Reduction
-import GHC.Core.Unify( tcUnifyTyForInjectivity )
-import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck
- , lookupFamInstEnvByTyCon )
+import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core
-
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set( anyVarSet )
import GHC.Types.Name.Reader
import GHC.Types.Basic
-import GHC.Builtin.Types.Literals ( tryInteractTopFam, tryInteractInertFam )
-
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
@@ -120,9 +112,9 @@ solveEquality ev eq_rel ty1 ty2
Left irred_ct -> do { tryQCsIrredEqCt irred_ct
; solveIrred irred_ct } ;
- Right eq_ct -> do { tryInertEqs eq_ct
- ; tryFunDeps eq_ct
- ; tryQCsEqCt eq_ct
+ Right eq_ct -> do { tryInertEqs eq_ct
+ ; tryEqFunDeps eq_ct
+ ; tryQCsEqCt eq_ct
; simpleStage (updInertEqs eq_ct)
; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } }
@@ -2025,7 +2017,7 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
evCoercion (mkNomReflCo final_rhs)
-- Kick out any constraints that can now be rewritten
- ; kickOutAfterUnification [tv]
+ ; recordUnification tv
; return (Stop new_ev (text "Solved by unification")) }
@@ -2996,456 +2988,3 @@ lovely quantified constraint. Alas!
This test arranges to ignore the instance-based solution under these
(rare) circumstances. It's sad, but I really don't see what else we can do.
-}
-
-
-{-
-**********************************************************************
-* *
- Functional dependencies for type families
-* *
-**********************************************************************
-
-Note [Reverse order of fundep equations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this scenario (from dependent/should_fail/T13135_simple):
-
- type Sig :: Type -> Type
- data Sig a = SigFun a (Sig a)
-
- type SmartFun :: forall (t :: Type). Sig t -> Type
- type family SmartFun sig = r | r -> sig where
- SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig
-
- [W] SmartFun @kappa sigma ~ (Int -> Bool)
-
-The injectivity of SmartFun allows us to produce two new equalities:
-
- [W] w1 :: Type ~ kappa
- [W] w2 :: SigFun @Type Int beta ~ sigma
-
-for some fresh (beta :: SigType). The second Wanted here is actually
-heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.
-Of course, if we solve the first wanted first, the second becomes homogeneous.
-
-When looking for injectivity-inspired equalities, we work left-to-right,
-producing the two equalities in the order written above. However, these
-equalities are then passed into wrapUnifierTcS, which will fail, adding these
-to the work list. However, crucially, the work list operates like a *stack*.
-So, because we add w1 and then w2, we process w2 first. This is silly: solving
-w1 would unlock w2. So we make sure to add equalities to the work
-list in left-to-right order, which requires a few key calls to 'reverse'.
-
-This treatment is also used for class-based functional dependencies, although
-we do not have a program yet known to exhibit a loop there. It just seems
-like the right thing to do.
-
-When this was originally conceived, it was necessary to avoid a loop in T13135.
-That loop is now avoided by continuing with the kind equality (not the type
-equality) in canEqCanLHSHetero (see Note [Equalities with heterogeneous kinds]).
-However, the idea of working left-to-right still seems worthwhile, and so the calls
-to 'reverse' remain.
-
-Note [Improvement orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Fundeps with instances, and equality orientation], which describes
-the Exact Same Problem, with the same solution, but for functional dependencies.
-
-A very delicate point is the orientation of equalities
-arising from injectivity improvement (#12522). Suppose we have
- type family F x = t | t -> x
- type instance F (a, Int) = (Int, G a)
-where G is injective; and wanted constraints
-
- [W] F (alpha, beta) ~ (Int, <some type>)
-
-The injectivity will give rise to constraints
-
- [W] gamma1 ~ alpha
- [W] Int ~ beta
-
-The fresh unification variable gamma1 comes from the fact that we
-can only do "partial improvement" here; see Section 5.2 of
-"Injective type families for Haskell" (HS'15).
-
-Now, it's very important to orient the equations this way round,
-so that the fresh unification variable will be eliminated in
-favour of alpha. If we instead had
- [W] alpha ~ gamma1
-then we would unify alpha := gamma1; and kick out the wanted
-constraint. But when we substitute it back in, it'd look like
- [W] F (gamma1, beta) ~ fuv
-and exactly the same thing would happen again! Infinite loop.
-
-This all seems fragile, and it might seem more robust to avoid
-introducing gamma1 in the first place, in the case where the
-actual argument (alpha, beta) partly matches the improvement
-template. But that's a bit tricky, esp when we remember that the
-kinds much match too; so it's easier to let the normal machinery
-handle it. Instead we are careful to orient the new
-equality with the template on the left. Delicate, but it works.
-
--}
-
---------------------
-
-tryFunDeps :: EqCt -> SolverStage ()
-tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel })
- | NomEq <- eq_rel
- , TyFamLHS tc args <- lhs
- = Stage $
- do { inerts <- getInertCans
- ; imp1 <- improveLocalFunEqs inerts tc args work_item
- ; imp2 <- improveTopFunEqs tc args work_item
- ; if (imp1 || imp2)
- then startAgainWith (mkNonCanonical ev)
- else continueWith () }
- | otherwise
- = nopStage ()
-
---------------------
-improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool
--- TyCon is definitely a type family
--- See Note [FunDep and implicit parameter reactions]
-improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs_ty })
- | isGiven ev = improveGivenTopFunEqs fam_tc args ev rhs_ty
- | otherwise = improveWantedTopFunEqs fam_tc args ev rhs_ty
-
-improveGivenTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool
--- TyCon is definitely a type family
--- Work-item is a Given
-improveGivenTopFunEqs fam_tc args ev rhs_ty
- | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
- = do { traceTcS "improveGivenTopFunEqs" (ppr fam_tc <+> ppr args $$ ppr ev $$ ppr rhs_ty)
- ; emitNewGivens (ctEvLoc ev) $
- [ (Nominal, new_co)
- | (ax, _) <- tryInteractTopFam ops fam_tc args rhs_ty
- , let new_co = mkAxiomCo ax [given_co] ]
- ; return False } -- False: no unifications
- | otherwise
- = return False
- where
- given_co :: Coercion = ctEvCoercion ev
-
-improveWantedTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool
--- TyCon is definitely a type family
--- Work-item is a Wanted
-improveWantedTopFunEqs fam_tc args ev rhs_ty
- = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty
- ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args
- , text "rhs:" <+> ppr rhs_ty
- , text "eqns:" <+> ppr eqns ])
- ; unifyFunDeps ev Nominal $ \uenv ->
- uPairsTcM (bump_depth uenv) (reverse eqns) }
- -- Missing that `reverse` causes T13135 and T13135_simple to loop.
- -- See Note [Reverse order of fundep equations]
-
- where
- bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) }
- -- ToDo: this location is wrong; it should be FunDepOrigin2
- -- See #14778
-
-improve_wanted_top_fun_eqs :: TyCon -> [TcType] -> Xi
- -> TcS [TypeEqn]
--- TyCon is definitely a type family
-improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty
- | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
- = return (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty)
-
- -- ToDo: use ideas in #23162 for closed type families; injectivity only for open
-
- -- See Note [Type inference for type families with injectivity]
- -- Open, so look for inj
- | Injective inj_args <- tyConInjectivityInfo fam_tc
- = do { fam_envs <- getFamInstEnvs
- ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
- ; let local_eqns = improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty
- ; traceTcS "improve_wanted_top_fun_eqs" $
- vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ]
- -- xxx ToDo: this does both local and top => bug?
- ; return (local_eqns ++ top_eqns) }
-
- | otherwise -- No injectivity
- = return []
-
-improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn]
--- Interact with top-level instance declarations
--- See Section 5.2 in the Injective Type Families paper
-improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
- = concatMapM do_one branches
- where
- branches :: [CoAxBranch]
- branches | isOpenTypeFamilyTyCon fam_tc
- , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
- = concatMap (fromBranches . coAxiomBranches . fi_axiom) fam_insts
-
- | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
- = fromBranches (coAxiomBranches ax)
-
- | otherwise
- = []
-
- do_one :: CoAxBranch -> TcS [TypeEqn]
- do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs })
- | let in_scope1 = in_scope `extendInScopeSetList` branch_tvs
- , Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty
- -- False: matching, not unifying
- = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst
- unsubstTvs = filterOut inSubst branch_tvs
- -- The order of unsubstTvs is important; it must be
- -- in telescope order e.g. (k:*) (a:k)
-
- ; (_subst_tvs, subst1) <- instFlexiX subst unsubstTvs
- -- If the current substitution bind [k -> *], and
- -- one of the un-substituted tyvars is (a::k), we'd better
- -- be sure to apply the current substitution to a's kind.
- -- Hence instFlexiX. #13135 was an example.
-
- ; traceTcS "improve_inj_top" $
- vcat [ text "branch_rhs" <+> ppr branch_rhs
- , text "rhs_ty" <+> ppr rhs_ty
- , text "subst" <+> ppr subst
- , text "subst1" <+> ppr subst1 ]
- ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch
- then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys)
- ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) }
- -- NB: The fresh unification variables (from unsubstTvs) are on the left
- -- See Note [Improvement orientation]
- else do { traceTcS "improve_inj_top2" empty; return [] } }
- | otherwise
- = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs)
- ; return [] }
-
- in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)
-
-
-improve_injective_wanted_famfam :: [Bool] -> TyCon -> [TcType] -> Xi -> [TypeEqn]
--- Interact with itself, specifically F s1 s2 ~ F t1 t2
-improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty
- | Just (tc, rhs_tys) <- tcSplitTyConApp_maybe rhs_ty
- , tc == fam_tc
- = mkInjectivityEqns inj_args lhs_tys rhs_tys
- | otherwise
- = []
-
-mkInjectivityEqns :: [Bool] -> [TcType] -> [TcType] -> [TypeEqn]
--- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True]
--- return the equations [Pair s1 t1, Pair s3 t3]
-mkInjectivityEqns inj_args lhs_args rhs_args
- = [ Pair lhs_arg rhs_arg | (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ]
-
----------------------------------------------
-improveLocalFunEqs :: InertCans
- -> TyCon -> [TcType] -> EqCt -- F args ~ rhs
- -> TcS Bool
--- Emit equalities from interaction between two equalities
-improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs })
- | isGiven work_ev = improveGivenLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
- | otherwise = improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
- where
- funeqs = inert_funeqs inerts
- funeqs_for_tc :: [EqCt] -- Mixture of Given and Wanted
- funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc
- , funeq_ct <- equal_ct_list
- , NomEq == eq_eq_rel funeq_ct ]
- -- Representational equalities don't interact
- -- with type family dependencies
-
-
-improveGivenLocalFunEqs :: [EqCt] -- Inert items, mixture of Given and Wanted
- -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Given)
- -> TcS Bool -- Always False (no unifications)
--- Emit equalities from interaction between two Given type-family equalities
--- e.g. (x+y1~z, x+y2~z) => (y1 ~ y2)
-improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs
- | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
- = do { mapM_ (do_one ops) funeqs_for_tc
- ; return False } -- False: no unifications
- | otherwise
- = return False
- where
- given_co :: Coercion = ctEvCoercion work_ev
-
- do_one :: BuiltInSynFamily -> EqCt -> TcS ()
- -- Used only work-item is Given
- do_one ops EqCt { eq_ev = inert_ev, eq_lhs = inert_lhs, eq_rhs = inert_rhs }
- | isGiven inert_ev -- Given/Given interaction
- , TyFamLHS _ inert_args <- inert_lhs -- Inert item is F inert_args ~ inert_rhs
- , work_rhs `tcEqType` inert_rhs -- Both RHSs are the same
- , -- So we have work_ev : F work_args ~ rhs
- -- inert_ev : F inert_args ~ rhs
- let pairs :: [(CoAxiomRule, TypeEqn)]
- pairs = tryInteractInertFam ops fam_tc work_args inert_args
- , not (null pairs)
- = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args
- , text "work_ev" <+> ppr work_ev
- , text "inert_ev" <+> ppr inert_ev
- , ppr work_rhs
- , ppr pairs ])
- ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) }
- -- This CtLoc for the new Givens doesn't reflect the
- -- fact that it's a combination of Givens, but I don't
- -- this that matters.
- where
- inert_co = ctEvCoercion inert_ev
- mk_ax_co (ax,_) = (Nominal, mkAxiomCo ax [combined_co])
- where
- combined_co = given_co `mkTransCo` mkSymCo inert_co
- -- given_co :: F work_args ~ rhs
- -- inert_co :: F inert_args ~ rhs
- -- the_co :: F work_args ~ F inert_args
-
- do_one _ _ = return ()
-
-improveWantedLocalFunEqs
- :: [EqCt] -- Inert items (Given and Wanted)
- -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Wanted)
- -> TcS Bool -- True <=> some unifications
--- Emit improvement equalities for a Wanted constraint, by comparing
--- the current work item with inert CFunEqs (both Given and Wanted)
--- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y'
---
--- See Note [FunDep and implicit parameter reactions]
-improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
- | null improvement_eqns
- = return False
- | otherwise
- = do { traceTcS "interactFunEq improvements: " $
- vcat [ text "Eqns:" <+> ppr improvement_eqns
- , text "Candidates:" <+> ppr funeqs_for_tc ]
- ; unifyAndEmitFunDepWanteds work_ev improvement_eqns }
- where
- work_loc = ctEvLoc work_ev
- work_pred = ctEvPred work_ev
- fam_inj_info = tyConInjectivityInfo fam_tc
-
- --------------------
- improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]
- improvement_eqns
- | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
- = -- Try built-in families, notably for arithmethic
- concatMap (do_one_built_in ops rhs) funeqs_for_tc
-
- | Injective injective_args <- fam_inj_info
- = -- Try improvement from type families with injectivity annotations
- concatMap (do_one_injective injective_args rhs) funeqs_for_tc
-
- | otherwise
- = []
-
- --------------------
- do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev })
- | irhs `tcEqType` rhs
- = mk_fd_eqns inert_ev (map snd $ tryInteractInertFam ops fam_tc args iargs)
- | otherwise
- = []
- do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS
-
- --------------------
- -- See Note [Type inference for type families with injectivity]
- do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args
- , eq_rhs = irhs, eq_ev = inert_ev })
- | rhs `tcEqType` irhs
- = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args
- | otherwise
- = []
-
- do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS
-
- --------------------
- mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]
- mk_fd_eqns inert_ev eqns
- | null eqns = []
- | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
- , fd_loc = (loc, inert_rewriters) } ]
- where
- initial_loc -- start with the location of the Wanted involved
- | isGiven work_ev = inert_loc
- | otherwise = work_loc
- eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)
- inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)
- eqn_loc = setCtLocOrigin initial_loc eqn_orig
- inert_pred = ctEvPred inert_ev
- inert_loc = ctEvLoc inert_ev
- inert_rewriters = ctEvRewriters inert_ev
- loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
- ctl_depth work_loc }
-
-{- Note [Type inference for type families with injectivity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have a type family with an injectivity annotation:
- type family F a b = r | r -> b
-
-Then if we have an equality like F s1 t1 ~ F s2 t2,
-we can use the injectivity to get a new Wanted constraint on
-the injective argument
- [W] t1 ~ t2
-
-That in turn can help GHC solve constraints that would otherwise require
-guessing. For example, consider the ambiguity check for
- f :: F Int b -> Int
-We get the constraint
- [W] F Int b ~ F Int beta
-where beta is a unification variable. Injectivity lets us pick beta ~ b.
-
-Injectivity information is also used at the call sites. For example:
- g = f True
-gives rise to
- [W] F Int b ~ Bool
-from which we can derive b. This requires looking at the defining equations of
-a type family, ie. finding equation with a matching RHS (Bool in this example)
-and inferring values of type variables (b in this example) from the LHS patterns
-of the matching equation. For closed type families we have to perform
-additional apartness check for the selected equation to check that the selected
-is guaranteed to fire for given LHS arguments.
-
-These new constraints are Wanted constraints, but we will not use the evidence.
-We could go further and offer evidence from decomposing injective type-function
-applications, but that would require new evidence forms, and an extension to
-FC, so we don't do that right now (Dec 14).
-
-We generate these Wanteds in three places, depending on how we notice the
-injectivity.
-
-1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
-described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality
-
-2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
-constraints rewrites the other, as they have different LHSs. This is done
-in improveLocalFunEqs, called during the interactWithInertsStage.
-
-3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
-This is done in improve_top_fun_eqs, called from the top-level reactions stage.
-
-See also Note [Injective type families] in GHC.Core.TyCon
-
-Note [Cache-caused loops]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
-solved cache (which is the default behaviour or xCtEvidence), because the interaction
-may not be contributing towards a solution. Here is an example:
-
-Initial inert set:
- [W] g1 : F a ~ beta1
-Work item:
- [W] g2 : F a ~ beta2
-The work item will react with the inert yielding the _same_ inert set plus:
- (i) Will set g2 := g1 `cast` g3
- (ii) Will add to our solved cache that [S] g2 : F a ~ beta2
- (iii) Will emit [W] g3 : beta1 ~ beta2
-Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
-and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
-will set
- g1 := g ; sym g3
-and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
-remember that we have this in our solved cache, and it is ... g2! In short we
-created the evidence loop:
-
- g2 := g1 ; g3
- g3 := refl
- g1 := g2 ; sym g3
-
-To avoid this situation we do not cache as solved any workitems (or inert)
-which did not really made a 'step' towards proving some goal. Solved's are
-just an optimization so we don't lose anything in terms of completeness of
-solving.
--}
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -4,7 +4,8 @@
-- | Solving Class constraints CDictCan
module GHC.Tc.Solver.FunDeps (
unifyAndEmitFunDepWanteds,
- doDictFunDepImprovement,
+ tryDictFunDeps,
+ tryEqFunDeps
) where
import GHC.Prelude
@@ -12,25 +13,34 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds )
import GHC.Tc.Instance.FunDeps
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.CtLoc
-import GHC.Tc.Types.Origin
import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Monad
import GHC.Tc.Solver.Types
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Unify( UnifyEnv(..) )
import GHC.Tc.Utils.Monad as TcM
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.CtLoc
+import GHC.Tc.Types.Origin
import GHC.Core.Type
-import GHC.Core.InstEnv ( ClsInst(..) )
-import GHC.Core.Coercion.Axiom( TypeEqn )
-
+import GHC.Core.FamInstEnv
+import GHC.Core.Coercion
+import GHC.Core.Predicate( EqRel(..) )
+import GHC.Core.TyCon
+import GHC.Core.Unify( tcUnifyTyForInjectivity )
+import GHC.Core.InstEnv( ClsInst(..) )
+import GHC.Core.Coercion.Axiom
+
+import GHC.Builtin.Types.Literals( tryInteractTopFam, tryInteractInertFam )
import GHC.Types.Name
import GHC.Types.Var.Set
+import GHC.Types.Var.Env
import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Misc( filterOut )
import GHC.Data.Bag
import GHC.Data.Pair
@@ -41,7 +51,7 @@ import Control.Monad
{- *********************************************************************
* *
-* Functional dependencies, instantiation of equations
+* Functional dependencies for dictionaries
* *
************************************************************************
@@ -296,24 +306,24 @@ as the fundeps.
#7875 is a case in point.
-}
-doDictFunDepImprovement :: DictCt -> SolverStage ()
--- (doDictFunDepImprovement inst_envs cts)
+tryDictFunDeps :: DictCt -> SolverStage ()
+-- (tryDictFunDeps inst_envs cts)
-- * Generate the fundeps from interacting the
-- top-level `inst_envs` with the constraints `cts`
-- * Do the unifications and return any unsolved constraints
-- See Note [Fundeps with instances, and equality orientation]
--- doLocalFunDepImprovement does StartAgain if there
+-- doLocalFunDeps does StartAgain if there
-- are any fundeps: see (DFL1) in Note [Do fundeps last]
-doDictFunDepImprovement dict_ct
- = do { doDictFunDepImprovementLocal dict_ct
- ; doDictFunDepImprovementTop dict_ct }
+tryDictFunDeps dict_ct
+ = do { tryDictFunDepsLocal dict_ct
+ ; tryDictFunDepsTop dict_ct }
-doDictFunDepImprovementLocal :: DictCt -> SolverStage ()
+tryDictFunDepsLocal :: DictCt -> SolverStage ()
-- Using functional dependencies, interact the DictCt with the
-- inert Givens and Wanteds, to produce new equalities
-doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
+tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
| isGiven work_ev
= -- If work_ev is Given, there could in principle be some inert Wanteds
-- but in practice there never are because we solve Givens first
@@ -323,11 +333,11 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
= Stage $
do { inerts <- getInertCans
- ; traceTcS "doDictFunDepImprovementLocal {" (ppr dict_ct)
+ ; traceTcS "tryDictFunDepsLocal {" (ppr dict_ct)
; imp <- solveFunDeps $
foldM do_interaction emptyCts $
findDictsByClass (inert_dicts inerts) cls
- ; traceTcS "doDictFunDepImprovementLocal }" (text "imp =" <+> ppr imp)
+ ; traceTcS "tryDictFunDepsLocal }" (text "imp =" <+> ppr imp)
; if imp then startAgainWith (CDictCan dict_ct)
else continueWith () }
@@ -350,7 +360,7 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
improveFromAnother (deriv_loc, inert_rewriters)
inert_pred work_pred
- ; traceTcS "doDictFunDepImprovementLocal item" $
+ ; traceTcS "tryDictFunDepsLocal item" $
vcat [ ppr work_ev, ppr new_eqs2 ]
; return (new_eqs1 `unionBags` new_eqs2) }
@@ -369,17 +379,17 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
(ctLocOrigin inert_loc)
(ctLocSpan inert_loc)
-doDictFunDepImprovementTop :: DictCt -> SolverStage ()
-doDictFunDepImprovementTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
+tryDictFunDepsTop :: DictCt -> SolverStage ()
+tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
= Stage $
do { inst_envs <- getInstEnvs
- ; traceTcS "doDictFunDepImprovementTop {" (ppr dict_ct)
+ ; traceTcS "tryDictFunDepsTop {" (ppr dict_ct)
; let eqns :: [FunDepEqn (CtLoc, RewriterSet)]
eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis
; imp <- solveFunDeps $
unifyFunDepWanteds_new ev eqns
- ; traceTcS "doDictFunDepImprovementTop }" (text "imp =" <+> ppr imp)
+ ; traceTcS "tryDictFunDepsTop }" (text "imp =" <+> ppr imp)
; if imp then startAgainWith (CDictCan dict_ct)
else continueWith () }
@@ -469,6 +479,464 @@ The bottom line: since we have no evidence for them, we should ignore Given/Give
and Given/instance fundeps entirely.
-}
+
+
+{-
+**********************************************************************
+* *
+ Functional dependencies for type families
+* *
+**********************************************************************
+
+Note [Reverse order of fundep equations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this scenario (from dependent/should_fail/T13135_simple):
+
+ type Sig :: Type -> Type
+ data Sig a = SigFun a (Sig a)
+
+ type SmartFun :: forall (t :: Type). Sig t -> Type
+ type family SmartFun sig = r | r -> sig where
+ SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig
+
+ [W] SmartFun @kappa sigma ~ (Int -> Bool)
+
+The injectivity of SmartFun allows us to produce two new equalities:
+
+ [W] w1 :: Type ~ kappa
+ [W] w2 :: SigFun @Type Int beta ~ sigma
+
+for some fresh (beta :: SigType). The second Wanted here is actually
+heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.
+Of course, if we solve the first wanted first, the second becomes homogeneous.
+
+When looking for injectivity-inspired equalities, we work left-to-right,
+producing the two equalities in the order written above. However, these
+equalities are then passed into wrapUnifierTcS, which will fail, adding these
+to the work list. However, crucially, the work list operates like a *stack*.
+So, because we add w1 and then w2, we process w2 first. This is silly: solving
+w1 would unlock w2. So we make sure to add equalities to the work
+list in left-to-right order, which requires a few key calls to 'reverse'.
+
+This treatment is also used for class-based functional dependencies, although
+we do not have a program yet known to exhibit a loop there. It just seems
+like the right thing to do.
+
+When this was originally conceived, it was necessary to avoid a loop in T13135.
+That loop is now avoided by continuing with the kind equality (not the type
+equality) in canEqCanLHSHetero (see Note [Equalities with heterogeneous kinds]).
+However, the idea of working left-to-right still seems worthwhile, and so the calls
+to 'reverse' remain.
+
+Note [Improvement orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Fundeps with instances, and equality orientation], which describes
+the Exact Same Problem, with the same solution, but for functional dependencies.
+
+A very delicate point is the orientation of equalities
+arising from injectivity improvement (#12522). Suppose we have
+ type family F x = t | t -> x
+ type instance F (a, Int) = (Int, G a)
+where G is injective; and wanted constraints
+
+ [W] F (alpha, beta) ~ (Int, <some type>)
+
+The injectivity will give rise to constraints
+
+ [W] gamma1 ~ alpha
+ [W] Int ~ beta
+
+The fresh unification variable gamma1 comes from the fact that we
+can only do "partial improvement" here; see Section 5.2 of
+"Injective type families for Haskell" (HS'15).
+
+Now, it's very important to orient the equations this way round,
+so that the fresh unification variable will be eliminated in
+favour of alpha. If we instead had
+ [W] alpha ~ gamma1
+then we would unify alpha := gamma1; and kick out the wanted
+constraint. But when we substitute it back in, it'd look like
+ [W] F (gamma1, beta) ~ fuv
+and exactly the same thing would happen again! Infinite loop.
+
+---> ToDo: all this fragility has gone away! Fix the Note! <---
+
+This all seems fragile, and it might seem more robust to avoid
+introducing gamma1 in the first place, in the case where the
+actual argument (alpha, beta) partly matches the improvement
+template. But that's a bit tricky, esp when we remember that the
+kinds much match too; so it's easier to let the normal machinery
+handle it. Instead we are careful to orient the new
+equality with the template on the left. Delicate, but it works.
+
+-}
+
+--------------------
+tryEqFunDeps :: EqCt -> SolverStage ()
+tryEqFunDeps work_item@(EqCt { eq_lhs = lhs, eq_eq_rel = eq_rel })
+ | NomEq <- eq_rel
+ , TyFamLHS tc args <- lhs
+ = do { improveLocalFunEqs tc args work_item
+ ; improveTopFunEqs tc args work_item }
+ | otherwise
+ = nopStage ()
+
+--------------------
+improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> SolverStage ()
+-- TyCon is definitely a type family
+-- See Note [FunDep and implicit parameter reactions]
+improveTopFunEqs fam_tc args eq_ct@(EqCt { eq_ev = ev, eq_rhs = rhs_ty })
+ = Stage $
+ do { imp <- if isGiven ev
+ then improveGivenTopFunEqs fam_tc args ev rhs_ty
+ else improveWantedTopFunEqs fam_tc args ev rhs_ty
+ ; if imp then startAgainWith (CEqCan eq_ct)
+ else continueWith () }
+
+improveGivenTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool
+-- TyCon is definitely a type family
+-- Work-item is a Given
+improveGivenTopFunEqs fam_tc args ev rhs_ty
+ | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+ = do { traceTcS "improveGivenTopFunEqs" (ppr fam_tc <+> ppr args $$ ppr ev $$ ppr rhs_ty)
+ ; emitNewGivens (ctEvLoc ev) $
+ [ (Nominal, new_co)
+ | (ax, _) <- tryInteractTopFam ops fam_tc args rhs_ty
+ , let new_co = mkAxiomCo ax [given_co] ]
+ ; return False } -- False: no unifications
+ | otherwise
+ = return False
+ where
+ given_co :: Coercion = ctEvCoercion ev
+
+improveWantedTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool
+-- TyCon is definitely a type family
+-- Work-item is a Wanted
+improveWantedTopFunEqs fam_tc args ev rhs_ty
+ = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty
+ ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args
+ , text "rhs:" <+> ppr rhs_ty
+ , text "eqns:" <+> ppr eqns ])
+ ; unifyFunDeps ev Nominal $ \uenv ->
+ uPairsTcM (bump_depth uenv) (reverse eqns) }
+ -- Missing that `reverse` causes T13135 and T13135_simple to loop.
+ -- See Note [Reverse order of fundep equations]
+
+ where
+ bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) }
+ -- ToDo: this location is wrong; it should be FunDepOrigin2
+ -- See #14778
+
+improve_wanted_top_fun_eqs :: TyCon -> [TcType] -> Xi
+ -> TcS [TypeEqn]
+-- TyCon is definitely a type family
+improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty
+ | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+ = return (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty)
+
+ -- ToDo: use ideas in #23162 for closed type families; injectivity only for open
+
+ -- See Note [Type inference for type families with injectivity]
+ -- Open, so look for inj
+ | Injective inj_args <- tyConInjectivityInfo fam_tc
+ = do { fam_envs <- getFamInstEnvs
+ ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
+ ; let local_eqns = improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty
+ ; traceTcS "improve_wanted_top_fun_eqs" $
+ vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ]
+ -- xxx ToDo: this does both local and top => bug?
+ ; return (local_eqns ++ top_eqns) }
+
+ | otherwise -- No injectivity
+ = return []
+
+improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn]
+-- Interact with top-level instance declarations
+-- See Section 5.2 in the Injective Type Families paper
+improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
+ = concatMapM do_one branches
+ where
+ branches :: [CoAxBranch]
+ branches | isOpenTypeFamilyTyCon fam_tc
+ , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
+ = concatMap (fromBranches . coAxiomBranches . fi_axiom) fam_insts
+
+ | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
+ = fromBranches (coAxiomBranches ax)
+
+ | otherwise
+ = []
+
+ do_one :: CoAxBranch -> TcS [TypeEqn]
+ do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs })
+ | let in_scope1 = in_scope `extendInScopeSetList` branch_tvs
+ , Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty
+ -- False: matching, not unifying
+ = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst
+ unsubstTvs = filterOut inSubst branch_tvs
+ -- The order of unsubstTvs is important; it must be
+ -- in telescope order e.g. (k:*) (a:k)
+
+ ; (_subst_tvs, subst1) <- instFlexiX subst unsubstTvs
+ -- If the current substitution bind [k -> *], and
+ -- one of the un-substituted tyvars is (a::k), we'd better
+ -- be sure to apply the current substitution to a's kind.
+ -- Hence instFlexiX. #13135 was an example.
+
+ ; traceTcS "improve_inj_top" $
+ vcat [ text "branch_rhs" <+> ppr branch_rhs
+ , text "rhs_ty" <+> ppr rhs_ty
+ , text "subst" <+> ppr subst
+ , text "subst1" <+> ppr subst1 ]
+ ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch
+ then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys)
+ ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) }
+ -- NB: The fresh unification variables (from unsubstTvs) are on the left
+ -- See Note [Improvement orientation]
+ else do { traceTcS "improve_inj_top2" empty; return [] } }
+ | otherwise
+ = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs)
+ ; return [] }
+
+ in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)
+
+
+improve_injective_wanted_famfam :: [Bool] -> TyCon -> [TcType] -> Xi -> [TypeEqn]
+-- Interact with itself, specifically F s1 s2 ~ F t1 t2
+improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty
+ | Just (tc, rhs_tys) <- tcSplitTyConApp_maybe rhs_ty
+ , tc == fam_tc
+ = mkInjectivityEqns inj_args lhs_tys rhs_tys
+ | otherwise
+ = []
+
+mkInjectivityEqns :: [Bool] -> [TcType] -> [TcType] -> [TypeEqn]
+-- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True]
+-- return the equations [Pair s1 t1, Pair s3 t3]
+mkInjectivityEqns inj_args lhs_args rhs_args
+ = [ Pair lhs_arg rhs_arg | (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ]
+
+---------------------------------------------
+improveLocalFunEqs :: TyCon -> [TcType] -> EqCt -- F args ~ rhs
+ -> SolverStage ()
+-- Emit equalities from interaction between two equalities
+improveLocalFunEqs fam_tc args eq_ct@(EqCt { eq_ev = work_ev, eq_rhs = rhs })
+ = Stage $
+ do { inerts <- getInertCans
+ ; let my_funeqs = get_my_funeqs inerts
+ ; imp <- if isGiven work_ev
+ then improveGivenLocalFunEqs my_funeqs fam_tc args work_ev rhs
+ else improveWantedLocalFunEqs my_funeqs fam_tc args work_ev rhs
+ ; if imp then startAgainWith (CEqCan eq_ct)
+ else continueWith () }
+ where
+ get_my_funeqs :: InertCans -> [EqCt] -- Mixture of Given and Wanted
+ get_my_funeqs (IC { inert_funeqs = funeqs })
+ = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc
+ , funeq_ct <- equal_ct_list
+ , NomEq == eq_eq_rel funeq_ct ]
+ -- Representational equalities don't interact
+ -- with type family dependencies
+
+improveGivenLocalFunEqs :: [EqCt] -- Inert items, mixture of Given and Wanted
+ -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Given)
+ -> TcS Bool -- Always False (no unifications)
+-- Emit equalities from interaction between two Given type-family equalities
+-- e.g. (x+y1~z, x+y2~z) => (y1 ~ y2)
+improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs
+ | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+ = do { mapM_ (do_one ops) funeqs_for_tc
+ ; return False } -- False: no unifications
+ | otherwise
+ = return False
+ where
+ given_co :: Coercion = ctEvCoercion work_ev
+
+ do_one :: BuiltInSynFamily -> EqCt -> TcS ()
+ -- Used only work-item is Given
+ do_one ops EqCt { eq_ev = inert_ev, eq_lhs = inert_lhs, eq_rhs = inert_rhs }
+ | isGiven inert_ev -- Given/Given interaction
+ , TyFamLHS _ inert_args <- inert_lhs -- Inert item is F inert_args ~ inert_rhs
+ , work_rhs `tcEqType` inert_rhs -- Both RHSs are the same
+ , -- So we have work_ev : F work_args ~ rhs
+ -- inert_ev : F inert_args ~ rhs
+ let pairs :: [(CoAxiomRule, TypeEqn)]
+ pairs = tryInteractInertFam ops fam_tc work_args inert_args
+ , not (null pairs)
+ = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args
+ , text "work_ev" <+> ppr work_ev
+ , text "inert_ev" <+> ppr inert_ev
+ , ppr work_rhs
+ , ppr pairs ])
+ ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) }
+ -- This CtLoc for the new Givens doesn't reflect the
+ -- fact that it's a combination of Givens, but I don't
+ -- this that matters.
+ where
+ inert_co = ctEvCoercion inert_ev
+ mk_ax_co (ax,_) = (Nominal, mkAxiomCo ax [combined_co])
+ where
+ combined_co = given_co `mkTransCo` mkSymCo inert_co
+ -- given_co :: F work_args ~ rhs
+ -- inert_co :: F inert_args ~ rhs
+ -- the_co :: F work_args ~ F inert_args
+
+ do_one _ _ = return ()
+
+improveWantedLocalFunEqs
+ :: [EqCt] -- Inert items (Given and Wanted)
+ -> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Wanted)
+ -> TcS Bool -- True <=> some unifications
+-- Emit improvement equalities for a Wanted constraint, by comparing
+-- the current work item with inert CFunEqs (both Given and Wanted)
+-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y'
+--
+-- See Note [FunDep and implicit parameter reactions]
+improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
+ | null improvement_eqns
+ = return False
+ | otherwise
+ = do { traceTcS "interactFunEq improvements: " $
+ vcat [ text "Eqns:" <+> ppr improvement_eqns
+ , text "Candidates:" <+> ppr funeqs_for_tc ]
+ ; unifyAndEmitFunDepWanteds work_ev improvement_eqns }
+ where
+ work_loc = ctEvLoc work_ev
+ work_pred = ctEvPred work_ev
+ fam_inj_info = tyConInjectivityInfo fam_tc
+
+ --------------------
+ improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]
+ improvement_eqns
+ | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+ = -- Try built-in families, notably for arithmethic
+ concatMap (do_one_built_in ops rhs) funeqs_for_tc
+
+ | Injective injective_args <- fam_inj_info
+ = -- Try improvement from type families with injectivity annotations
+ concatMap (do_one_injective injective_args rhs) funeqs_for_tc
+
+ | otherwise
+ = []
+
+ --------------------
+ do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev })
+ | irhs `tcEqType` rhs
+ = mk_fd_eqns inert_ev (map snd $ tryInteractInertFam ops fam_tc args iargs)
+ | otherwise
+ = []
+ do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS
+
+ --------------------
+ -- See Note [Type inference for type families with injectivity]
+ do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args
+ , eq_rhs = irhs, eq_ev = inert_ev })
+ | rhs `tcEqType` irhs
+ = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args
+ | otherwise
+ = []
+
+ do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS
+
+ --------------------
+ mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]
+ mk_fd_eqns inert_ev eqns
+ | null eqns = []
+ | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
+ , fd_loc = (loc, inert_rewriters) } ]
+ where
+ initial_loc -- start with the location of the Wanted involved
+ | isGiven work_ev = inert_loc
+ | otherwise = work_loc
+ eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)
+ inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)
+ eqn_loc = setCtLocOrigin initial_loc eqn_orig
+ inert_pred = ctEvPred inert_ev
+ inert_loc = ctEvLoc inert_ev
+ inert_rewriters = ctEvRewriters inert_ev
+ loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
+ ctl_depth work_loc }
+
+{- Note [Type inference for type families with injectivity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a type family with an injectivity annotation:
+ type family F a b = r | r -> b
+
+Then if we have an equality like F s1 t1 ~ F s2 t2,
+we can use the injectivity to get a new Wanted constraint on
+the injective argument
+ [W] t1 ~ t2
+
+That in turn can help GHC solve constraints that would otherwise require
+guessing. For example, consider the ambiguity check for
+ f :: F Int b -> Int
+We get the constraint
+ [W] F Int b ~ F Int beta
+where beta is a unification variable. Injectivity lets us pick beta ~ b.
+
+Injectivity information is also used at the call sites. For example:
+ g = f True
+gives rise to
+ [W] F Int b ~ Bool
+from which we can derive b. This requires looking at the defining equations of
+a type family, ie. finding equation with a matching RHS (Bool in this example)
+and inferring values of type variables (b in this example) from the LHS patterns
+of the matching equation. For closed type families we have to perform
+additional apartness check for the selected equation to check that the selected
+is guaranteed to fire for given LHS arguments.
+
+These new constraints are Wanted constraints, but we will not use the evidence.
+We could go further and offer evidence from decomposing injective type-function
+applications, but that would require new evidence forms, and an extension to
+FC, so we don't do that right now (Dec 14).
+
+We generate these Wanteds in three places, depending on how we notice the
+injectivity.
+
+1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
+described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality
+
+2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
+constraints rewrites the other, as they have different LHSs. This is done
+in improveLocalFunEqs, called during the interactWithInertsStage.
+
+3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
+This is done in improve_top_fun_eqs, called from the top-level reactions stage.
+
+See also Note [Injective type families] in GHC.Core.TyCon
+
+Note [Cache-caused loops]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
+solved cache (which is the default behaviour or xCtEvidence), because the interaction
+may not be contributing towards a solution. Here is an example:
+
+Initial inert set:
+ [W] g1 : F a ~ beta1
+Work item:
+ [W] g2 : F a ~ beta2
+The work item will react with the inert yielding the _same_ inert set plus:
+ (i) Will set g2 := g1 `cast` g3
+ (ii) Will add to our solved cache that [S] g2 : F a ~ beta2
+ (iii) Will emit [W] g3 : beta1 ~ beta2
+Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
+and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
+will set
+ g1 := g ; sym g3
+and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
+remember that we have this in our solved cache, and it is ... g2! In short we
+created the evidence loop:
+
+ g2 := g1 ; g3
+ g3 := refl
+ g1 := g2 ; sym g3
+
+To avoid this situation we do not cache as solved any workitems (or inert)
+which did not really made a 'step' towards proving some goal. Solved's are
+just an optimization so we don't lose anything in terms of completeness of
+solving.
+-}
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -67,9 +67,6 @@ module GHC.Tc.Solver.Monad (
getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
tcLookupClass, tcLookupId, tcLookupTyCon,
- getUnifiedRef,
-
-
-- Inerts
updInertSet, updInertCans,
getHasGivenEqs, setInertCans,
@@ -84,7 +81,7 @@ module GHC.Tc.Solver.Monad (
lookupInertDict,
-- The Model
- kickOutAfterUnification, kickOutRewritable,
+ recordUnification, recordUnifications, kickOutRewritable,
-- Inert Safe Haskell safe-overlap failures
insertSafeOverlapFailureTcS,
@@ -212,8 +209,6 @@ import Control.Monad
import Data.Foldable hiding ( foldr1 )
import Data.IORef
import Data.List ( mapAccumL )
-import Data.List.NonEmpty ( nonEmpty )
-import qualified Data.List.NonEmpty as NE
import GHC.Types.SrcLoc
import GHC.Rename.Env
import GHC.LanguageExtensions as LangExt
@@ -450,33 +445,6 @@ kickOutRewritable ko_spec new_fr
, text "kicked_out =" <+> ppr kicked_out
, text "Residual inerts =" <+> ppr ics' ]) } }
-kickOutAfterUnification :: [TcTyVar] -> TcS ()
-kickOutAfterUnification tv_list
- = case nonEmpty tv_list of
- Nothing -> return ()
- Just tvs -> do { traceTcS "kickOutAfterUnification" (ppr min_tv_lvl $$ ppr tv_list)
- ; setUnificationFlagTo min_tv_lvl }
- where
- min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs)
-
-{-
- { let tv_set = mkVarSet tv_list
-
- ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq)
- -- Given because the tv := xi is given; NomEq because
- -- only nominal equalities are solved by unification
-
- -- Set the unification flag if we have done outer unifications
- -- that might affect an earlier implication constraint
- ; let min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs)
- ; ambient_lvl <- getTcLevel
- ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $
- setUnificationFlagTo min_tv_lvl
-
- ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked)
- ; return n_kicked }
--}
-
kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()
-- See Wrinkle (URW2) in Note [Unify only if the rewriter set is empty]
-- in GHC.Tc.Solver.Equality
@@ -940,11 +908,6 @@ data TcSEnv
= TcSEnv {
tcs_ev_binds :: EvBindsVar,
- tcs_unified :: IORef Int,
- -- The number of unification variables we have filled
- -- The important thing is whether it is non-zero, so it
- -- could equally well be a Bool instead of an Int.
-
tcs_unif_lvl :: IORef (Maybe TcLevel),
-- The Unification Level Flag
-- Outermost level at which we have unified a meta tyvar
@@ -1131,8 +1094,7 @@ runTcSWithEvBinds' :: TcSMode
-> TcS a
-> TcM a
runTcSWithEvBinds' mode ev_binds_var thing_inside
- = do { unified_var <- TcM.newTcRef 0
- ; step_count <- TcM.newTcRef 0
+ = do { step_count <- TcM.newTcRef 0
-- Make a fresh, empty inert set
-- Subtle point: see (TGE6) in Note [Tracking Given equalities]
@@ -1143,7 +1105,6 @@ runTcSWithEvBinds' mode ev_binds_var thing_inside
; wl_var <- TcM.newTcRef emptyWorkList
; unif_lvl_var <- TcM.newTcRef Nothing
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
- , tcs_unified = unified_var
, tcs_unif_lvl = unif_lvl_var
, tcs_count = step_count
, tcs_inerts = inert_var
@@ -1354,9 +1315,6 @@ setTcSMode :: TcSMode -> TcS a -> TcS a
setTcSMode mode thing_inside
= TcS (\env -> unTcS thing_inside (env { tcs_mode = mode }))
-getUnifiedRef :: TcS (IORef Int)
-getUnifiedRef = TcS (return . tcs_unified)
-
-- Getter of inerts and worklist
getInertSetRef :: TcS (IORef InertSet)
getInertSetRef = TcS (return . tcs_inerts)
@@ -1817,13 +1775,11 @@ produced the same Derived constraint.)
unifyTyVar :: TcTyVar -> TcType -> TcS ()
-- Unify a meta-tyvar with a type
--- We keep track of how many unifications have happened in tcs_unified,
---
-- We should never unify the same variable twice!
unifyTyVar tv ty
= assertPpr (isMetaTyVar tv) (ppr tv) $
do { liftZonkTcS (TcM.writeMetaTyVar tv ty) -- Produces a trace message
- ; setUnificationFlagTo (tcTyVarLevel tv) }
+ ; recordUnification tv }
reportUnifications :: TcS a -> TcS (Bool, a)
-- Record whether any unifications are done by thing_inside
@@ -1887,6 +1843,18 @@ getUnificationFlag
-> do { TcM.writeTcRef ref Nothing
; return True } }
+recordUnification :: TcTyVar -> TcS ()
+recordUnification tv = setUnificationFlagTo (tcTyVarLevel tv)
+
+recordUnifications :: [TcTyVar] -> TcS ()
+recordUnifications tvs
+ = case tvs of
+ [] -> return ()
+ (tv:tvs) -> do { traceTcS "recordUnifications" (ppr min_tv_lvl $$ ppr tvs)
+ ; setUnificationFlagTo min_tv_lvl }
+ where
+ min_tv_lvl = foldr (minTcLevel . tcTyVarLevel) (tcTyVarLevel tv) tvs
+
setUnificationFlagTo :: TcLevel -> TcS ()
-- (setUnificationFlag i) sets the unification level to (Just i)
-- unless it already is (Just j) where j <= i
@@ -2251,8 +2219,8 @@ unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a)
unifyForAllBody ev role unify_body
= do { (res, cts, unified) <- wrapUnifierX ev role unify_body
- -- Kick out any inert constraint that we have unified
- ; kickOutAfterUnification unified
+ -- Record the unificaions we have done
+ ; recordUnifications unified
; return (res, cts) }
@@ -2271,6 +2239,9 @@ wrapUnifierTcS :: CtEvidence -> Role
wrapUnifierTcS ev role do_unifications
= do { (res, cts, unified) <- wrapUnifierX ev role do_unifications
+ -- Record the unificaions we have done
+ ; recordUnifications unified
+
-- Emit the deferred constraints
-- See Note [Work-list ordering] in GHC.Tc.Solved.Equality
--
@@ -2280,17 +2251,13 @@ wrapUnifierTcS ev role do_unifications
; unless (isEmptyBag cts) $
updWorkListTcS (extendWorkListChildEqs ev cts)
- -- And kick out any inert constraint that we have unified
- ; kickOutAfterUnification unified
-
; return (res, cts, unified) }
wrapUnifierX :: CtEvidence -> Role
-> (UnifyEnv -> TcM a) -- Some calls to uType
-> TcS (a, Bag Ct, [TcTyVar])
wrapUnifierX ev role do_unifications
- = do { unif_count_ref <- getUnifiedRef
- ; given_eq_lvl <- getInnermostGivenEqLevel
+ = do { given_eq_lvl <- getInnermostGivenEqLevel
; wrapTcS $
do { defer_ref <- TcM.newTcRef emptyBag
; unified_ref <- TcM.newTcRef []
@@ -2308,12 +2275,6 @@ wrapUnifierX ev role do_unifications
; cts <- TcM.readTcRef defer_ref
; unified <- TcM.readTcRef unified_ref
-
- -- Don't forget to update the count of variables
- -- unified, lest we forget to iterate (#24146)
- ; unless (null unified) $
- TcM.updTcRef unif_count_ref (+ (length unified))
-
; return (res, cts, unified) } }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0240183357637242886b779215b04ff…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0240183357637242886b779215b04ff…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/warning-for-last-and-init] 3 commits: Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
by Bodigrim (＠Bodigrim) 09 Aug '25
by Bodigrim (＠Bodigrim) 09 Aug '25
09 Aug '25
Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC
Commits:
c5ec5732 by Mike Pilgrem at 2025-08-09T00:48:51+01:00
Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`).
In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository).
Also bumps submodules.
- - - - -
31ddd232 by Andrew Lelechenko at 2025-08-09T00:48:51+01:00
Wibble
- - - - -
d108f076 by Andrew Lelechenko at 2025-08-09T11:07:28+01:00
Wobble
- - - - -
26 changed files:
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Prelude/Basic.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/src/Settings/Warnings.hs
- libraries/Cabal
- libraries/filepath
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- testsuite/tests/driver/j-space/jspace.hs
- testsuite/tests/rts/KeepCafsBase.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/ghc-pkg/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/hpc
- utils/hsc2hs
Changes:
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -112,8 +112,7 @@ import GHC.Utils.Misc
import Data.ByteString ( ByteString )
import Data.Function ( on )
-import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
-import qualified Data.List as Partial ( init, last )
+import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc )
import Data.Ord ( comparing )
import Control.Monad ( guard )
import qualified Data.Set as Set
@@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args
PrimOpId op _
| primOpIsDiv op
- , Lit divisor <- Partial.last args
+ , Just (initArgs, Lit divisor) <- unsnoc args
-- there can be 2 args (most div primops) or 3 args
-- (WordQuotRem2Op), hence the use of last/init
- -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args)
+ -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs
-- Special case for dividing operations that fail
-- In general they are NOT ok-for-speculation
-- (which primop_ok will catch), but they ARE OK
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -2,6 +2,8 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
module GHC.Driver.Session.Units (initMake, initMulti) where
-- The official GHC API
=====================================
compiler/GHC/Prelude/Basic.hs
=====================================
@@ -2,8 +2,8 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude]
--- See Note [Proxies for head and tail]
-{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}
+-- See Note [Proxies for partial list functions]
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- | Custom minimal GHC "Prelude"
--
@@ -24,7 +24,7 @@ module GHC.Prelude.Basic
, bit
, shiftL, shiftR
, setBit, clearBit
- , head, tail, unzip
+ , head, tail, init, last, unzip
, strictGenericLength
) where
@@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this:
-}
import qualified Prelude
-import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip)
+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip)
import Control.Applicative (Applicative(..))
import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum))
import Data.Foldable1 as X hiding (head, last)
@@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i
clearBit :: (Num a, Bits.Bits a) => a -> Int -> a
clearBit = \ x i -> x Bits..&. Bits.complement (bit i)
-{- Note [Proxies for head and tail]
+{- Note [Proxies for partial list functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-},
+Prelude.head, Prelude.tail, Prelude.init and Prelude.last
+have recently acquired {-# WARNING in "x-partial" #-},
but the GHC codebase uses them fairly extensively and insists on building warning-free.
Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which
employs them, we define warning-less proxies and export them from GHC.Prelude.
-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
head :: HasCallStack => [a] -> a
head = Prelude.head
{-# INLINE head #-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
tail :: HasCallStack => [a] -> [a]
tail = Prelude.tail
{-# INLINE tail #-}
+-- See Note [Proxies for partial list functions]
+init :: HasCallStack => [a] -> [a]
+init = Prelude.init
+{-# INLINE init #-}
+
+-- See Note [Proxies for partial list functions]
+last :: HasCallStack => [a] -> a
+last = Prelude.last
+{-# INLINE last #-}
+
{- |
The 'genericLength' function defined in base can't be specialised due to the
NOINLINE pragma.
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -12,6 +12,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
{-# OPTIONS -fno-warn-name-shadowing #-}
-- This module does a lot of it
=====================================
ghc/Main.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
-----------------------------------------------------------------------------
--
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -72,7 +72,10 @@ ghcWarningsArgs = do
, package terminfo ? pure [ "-Wno-unused-imports", "-Wno-deriving-typeable" ]
, package stm ? pure [ "-Wno-deriving-typeable" ]
, package osString ? pure [ "-Wno-deriving-typeable", "-Wno-unused-imports" ]
- , package parsec ? pure [ "-Wno-deriving-typeable" ]
+ , package parsec ? pure [ "-Wno-deriving-typeable"
+ , "-Wno-x-partial"
+ -- https://github.com/haskell/parsec/issues/194
+ ]
, package cabal ? pure [ "-Wno-deriving-typeable", "-Wno-incomplete-record-selectors" ]
-- The -Wno-incomplete-record-selectors is due to
@@ -80,7 +83,9 @@ ghcWarningsArgs = do
-- If that ticket is fixed, bwe can remove the flag again
, package cabalSyntax ? pure [ "-Wno-deriving-typeable" ]
- , package time ? pure [ "-Wno-deriving-typeable" ]
+ , package time ? pure [ "-Wno-deriving-typeable"
+ , "-Wno-x-partial" -- Awaiting time-1.15 release
+ ]
, package transformers ? pure [ "-Wno-unused-matches"
, "-Wno-unused-imports"
, "-Wno-redundant-constraints"
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8
+Subproject commit 9a343d137bcc5ae97a8d6e7a670dd4fb67ea7294
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
+Subproject commit 62e71a8f512a0f2a477d8004751ccf2420b8ac28
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
=====================================
@@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib
import GHC.Boot.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr )
-import Data.List ( intersperse )
+import Data.List ( intersperse, unsnoc )
import GHC.Show ( showMultiLineString )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
@@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $
pprStms [s] = ppr s
pprStms ss = braces (semiSep ss)
-pprExp _ (CompE []) = text "<<Empty CompExp>>"
-- This will probably break with fixity declarations - would need a ';'
-pprExp _ (CompE ss) =
+pprExp _ (CompE ss) = case unsnoc ss of
+ Nothing -> text "<<Empty CompExp>>"
+ Just (ss', s) ->
if null ss'
-- If there are no statements in a list comprehension besides the last
-- one, we simply treat it like a normal list.
@@ -225,8 +226,6 @@ pprExp _ (CompE ss) =
<+> bar
<+> commaSep ss'
<> text "]"
- where s = last ss
- ss' = init ss
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets (commaSep es)
pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
=====================================
libraries/ghc-internal/src/GHC/Internal/Float.hs
=====================================
@@ -13,6 +13,9 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+-- For init in formatRealFloatAlt
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Internal.Float
=====================================
libraries/ghc-internal/src/GHC/Internal/List.hs
=====================================
@@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a]
tail (_:xs) = xs
tail [] = errorEmptyList "tail"
-{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
-- | \(\mathcal{O}(n)\). Extract the last element of a list, which must be
-- finite and non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs
lastError :: HasCallStack => a
lastError = errorEmptyList "last"
+{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(n)\). Return all the elements of a list except the last one.
-- The list must be non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -240,6 +254,8 @@ init (x:xs) = init' x xs
where init' _ [] = []
init' y (z:zs) = y : init' z zs
+{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(1)\). Test whether a list is empty.
--
-- >>> null []
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO.hs
=====================================
@@ -840,11 +840,12 @@ output_flags = std_flags
where
-- XXX bits copied from System.FilePath, since that's not available here
- combine a b
- | null b = a
- | null a = b
- | pathSeparator [last a] = a ++ b
- | otherwise = a ++ [pathSeparatorChar] ++ b
+ combine a [] = a
+ combine a b = case unsnoc a of
+ Nothing -> b
+ Just (_, lastA)
+ | pathSeparator [lastA] -> a ++ b
+ | otherwise -> a ++ [pathSeparatorChar] ++ b
tempCounter :: IORef Int
tempCounter = unsafePerformIO $ newIORef 0
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable
+import GHC.Internal.List (unsnoc)
import GHC.Internal.Word
import GHC.Internal.Generics (Generic)
import GHC.Internal.IORef
@@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix
import GHC.Internal.Control.Exception
import GHC.Internal.Num
import GHC.Internal.IO.Unsafe
-import GHC.Internal.List (dropWhile, break, replicate, reverse, last)
+import GHC.Internal.List (dropWhile, break, replicate, reverse)
import GHC.Internal.MVar
import GHC.Internal.IO.Exception
import GHC.Internal.Unicode
@@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type)
import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
+#ifdef BOOTSTRAP_TH
+#if MIN_VERSION_base(4,19,0)
+import Data.List (unsnoc)
+#else
+import Data.Maybe (maybe)
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+#endif
+#endif
+
-----------------------------------------------------
--
-- The Quasi class
@@ -1296,7 +1307,7 @@ mkName str
-- (i.e. non-empty, starts with capital, all alpha)
is_rev_mod_name rev_mod_str
| (compt, rest) <- break (== '.') rev_mod_str
- , not (null compt), isUpper (last compt), all is_mod_char compt
+ , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt
= case rest of
[] -> True
(_dot : rest') -> is_rev_mod_name rest'
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Posix
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Windows
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
testsuite/tests/driver/j-space/jspace.hs
=====================================
@@ -7,7 +7,7 @@ import System.Environment
import GHC.Driver.Env.Types
import GHC.Profiling
import System.Mem
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, unsnoc)
import Control.Monad
import System.Exit
import GHC.Platform
@@ -41,7 +41,9 @@ initGhcM xs = do
requestHeapCensus
performGC
[ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp"
- let (n :: Int) = read (last (words ys))
+ let (n :: Int) = case unsnoc (words ys) of
+ Nothing -> error "input is unexpectedly empty"
+ Just (_, lst) -> read lst
-- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures):
-- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH,
-- and each ModDetails contains 1 (info table) + 8 word-sized fields.
=====================================
testsuite/tests/rts/KeepCafsBase.hs
=====================================
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
module KeepCafsBase (x) where
x :: Int
=====================================
utils/check-exact/Main.hs
=====================================
@@ -6,6 +6,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
import Data.Data
import Data.List (intercalate)
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -96,6 +96,7 @@ import GHC.Data.FastString
import GHC.Types.SrcLoc
import Data.Data
+import Data.List (unsnoc)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
@@ -212,8 +213,9 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns (
where
-- we want DPs for the distance from the end of the ns to the
-- AnnDColon, and to the start of the ty
- rd = case last ns of
- L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc'
+ rd = case unsnoc ns of
+ Nothing -> error "unexpected empty list in 'ns' variable"
+ Just (_, L (EpAnn anc' _ _) _) -> epaLocationRealSrcSpan anc'
dca' = case dca of
EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) [])
_ -> dca
@@ -294,7 +296,7 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp
where
cs'' = setPriorComments cs []
csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs'
- lc = last $ (L ca c:cs')
+ lc = NE.last (L ca c :| cs')
delta = case getLoc lc of
EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
EpaSpan _ -> (SameLine 0)
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..))
import GHC.Parser.Lexer (allocateComments)
import Data.Data hiding ( Fixity )
-import Data.List (sortBy, partition)
+import Data.List (sortBy, partition, unsnoc)
import qualified Data.Map.Strict as Map
import Debug.Trace
@@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []"
ghead _info (h:_) = h
glast :: String -> [a] -> a
-glast info [] = error $ "glast " ++ info ++ " []"
-glast _info h = last h
+glast info xs = case unsnoc xs of
+ Nothing -> error $ "glast " ++ info ++ " []"
+ Just (_, lst) -> lst
gtail :: String -> [a] -> [a]
gtail info [] = error $ "gtail " ++ info ++ " []"
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -8,7 +8,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-}
-- Fine if this comes from make/Hadrian or the pre-built base.
#include <ghcplatform.h>
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
=====================================
@@ -1,6 +1,6 @@
module GHC.Toolchain.CheckArm ( findArmIsa ) where
-import Data.List (isInfixOf)
+import Data.List (isInfixOf, unsnoc)
import Data.Maybe (catMaybes)
import Control.Monad.IO.Class
import System.Process
@@ -76,8 +76,7 @@ findArmIsa cc = do
_ -> throwE $ "unexpected output from test program: " ++ out
lastLine :: String -> String
-lastLine "" = ""
-lastLine s = last $ lines s
+lastLine = maybe "" snd . unsnoc . lines
-- | Raspbian unfortunately makes some extremely questionable packaging
-- decisions, configuring gcc to compile for ARMv6 despite the fact that the
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -755,7 +755,7 @@ ppHtmlIndex
divAlphabet
<< unordList
( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
- [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index
+ [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index
]
++ [merged_name]
)
@@ -772,7 +772,7 @@ ppHtmlIndex
writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
- index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c]
+ index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c]
index :: [(String, Map GHC.Name [(Module, Bool)])]
index = sortBy cmp (Map.toAscList full_index)
=====================================
utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
=====================================
@@ -30,7 +30,7 @@ import Control.Arrow (first)
import Control.Monad
import Data.Char (chr, isAlpha, isSpace, isUpper)
import Data.Functor (($>))
-import Data.List (elemIndex, intercalate, intersperse, unfoldr)
+import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
@@ -870,10 +870,10 @@ codeblock =
DocCodeBlock . parseParagraph . dropSpaces
<$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
where
- dropSpaces xs =
- case splitByNl xs of
- [] -> xs
- ys -> case T.uncons (last ys) of
+ dropSpaces xs = let ys = splitByNl xs in
+ case unsnoc ys of
+ Nothing -> xs
+ Just (_, lastYs) -> case T.uncons lastYs of
Just (' ', _) -> case mapM dropSpace ys of
Nothing -> xs
Just zs -> T.intercalate "\n" zs
=====================================
utils/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5
+Subproject commit dd43f7e139d7a4f4908d1e8af35a75939f763ef1
=====================================
utils/hsc2hs
=====================================
@@ -1 +1 @@
-Subproject commit fe3990b9f35000427b016a79330d9f195587cad8
+Subproject commit 2059c961fc28bbfd0cafdbef96d5d21f1d911b53
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0bc00e399a947203ca49d88efbe9a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0bc00e399a947203ca49d88efbe9a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/remove-ddump-json] 10 commits: Refactoring: Don't misuse `MCDiagnostic` for lint messages
by Simon Hengel (＠sol) 09 Aug '25
by Simon Hengel (＠sol) 09 Aug '25
09 Aug '25
Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC
Commits:
f99e4bae by Simon Hengel at 2025-08-09T16:50:20+07:00
Refactoring: Don't misuse `MCDiagnostic` for lint messages
`MCDiagnostic` is meant to be used for compiler diagnostics.
Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json`
(see e.g. !14475, !14492 !14548).
To avoid this in the future I want to control more narrowly who creates
`MCDiagnostic` (see #24113).
Some parts of the compiler use `MCDiagnostic` purely for formatting
purposes, without creating any real compiler diagnostics. This change
introduces a helper function, `formatDiagnostic`, that can be used in
such cases instead of constructing `MCDiagnostic`.
- - - - -
a5393c7b by Simon Hengel at 2025-08-09T16:50:40+07:00
Rename MCDiagnostic to UnsafeMCDiagnostic
- - - - -
3b67a005 by Simon Hengel at 2025-08-09T16:50:40+07:00
Remove -ddump-json (fixes #24113)
- - - - -
e06295d3 by Simon Hengel at 2025-08-09T16:50:40+07:00
Add SrcSpan to MCDiagnostic
- - - - -
8c0d0320 by Simon Hengel at 2025-08-09T16:50:40+07:00
Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg
- - - - -
e61d74f4 by Simon Hengel at 2025-08-09T16:50:40+07:00
Get rid of mkLocMessage
- - - - -
26fe025d by Simon Hengel at 2025-08-09T16:50:40+07:00
Add Message data type
- - - - -
0fe6bd7f by Simon Hengel at 2025-08-09T16:50:40+07:00
Get rid of MessageClass
- - - - -
8e45d9f3 by Simon Hengel at 2025-08-09T16:50:40+07:00
Rename DiagnosticMessage to GenericDiagnosticMessage
- - - - -
42b5dedb by Simon Hengel at 2025-08-09T16:50:40+07:00
Remove JSON logging
- - - - -
36 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/LogQueue.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/SourceError.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debugging.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
- utils/check-exact/Main.hs
- utils/check-exact/Preprocess.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f3a82a3d650fe6703cf0369ecf31e5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f3a82a3d650fe6703cf0369ecf31e5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/lint-messages] Refactoring: Don't misuse `MCDiagnostic` for lint messages
by Simon Hengel (＠sol) 09 Aug '25
by Simon Hengel (＠sol) 09 Aug '25
09 Aug '25
Simon Hengel pushed to branch wip/sol/lint-messages at Glasgow Haskell Compiler / GHC
Commits:
f99e4bae by Simon Hengel at 2025-08-09T16:50:20+07:00
Refactoring: Don't misuse `MCDiagnostic` for lint messages
`MCDiagnostic` is meant to be used for compiler diagnostics.
Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json`
(see e.g. !14475, !14492 !14548).
To avoid this in the future I want to control more narrowly who creates
`MCDiagnostic` (see #24113).
Some parts of the compiler use `MCDiagnostic` purely for formatting
purposes, without creating any real compiler diagnostics. This change
introduces a helper function, `formatDiagnostic`, that can be used in
such cases instead of constructing `MCDiagnostic`.
- - - - -
4 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Error.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -3418,7 +3418,7 @@ addMsg show_context env msgs msg
[] -> noSrcSpan
(s:_) -> s
!diag_opts = le_diagOpts env
- mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span
+ mk_msg msg = mkLintWarning diag_opts msg_span
(msg $$ context)
addLoc :: LintLocInfo -> LintM a -> LintM a
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -107,7 +107,6 @@ import GHC.Core.Type
import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
import GHC.Types.CostCentre ( isCurrentCCS )
-import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) )
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom )
@@ -116,7 +115,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Logger
import GHC.Utils.Outputable
-import GHC.Utils.Error ( mkLocMessage, DiagOpts )
+import GHC.Utils.Error ( DiagOpts )
import qualified GHC.Utils.Error as Err
import GHC.Unit.Module ( Module )
@@ -540,7 +539,7 @@ addErr diag_opts errs_so_far msg locs
= errs_so_far `snocBag` mk_msg locs
where
mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
- in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing)
+ in Err.mkLintWarning diag_opts
l (hdr $$ msg)
mk_msg [] = msg
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -72,6 +72,7 @@ module GHC.Types.Error
, pprMessageBag
, mkLocMessage
, mkLocMessageWarningGroups
+ , formatDiagnostic
, getCaretDiagnostic
, jsonDiagnostic
@@ -495,11 +496,11 @@ data MessageClass
-- ^ Diagnostics from the compiler. This constructor is very powerful as
-- it allows the construction of a 'MessageClass' with a completely
-- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
- -- users are encouraged to use the 'mkMCDiagnostic' smart constructor
+ -- users are encouraged to use higher level primitives
-- instead. Use this constructor directly only if you need to construct
-- and manipulate diagnostic messages directly, for example inside
-- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when
- -- emitting compiler diagnostics, use the smart constructor.
+ -- emitting compiler diagnostics, use higher level primitives.
--
-- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for
-- this diagnostic. If you are creating a message not tied to any
@@ -656,32 +657,51 @@ mkLocMessageWarningGroups
-> SrcSpan -- ^ location
-> SDoc -- ^ message
-> SDoc
- -- Always print the location, even if it is unhelpful. Error messages
- -- are supposed to be in a standard format, and one without a location
- -- would look strange. Better to say explicitly "<no location info>".
mkLocMessageWarningGroups show_warn_groups msg_class locn msg
- = sdocOption sdocColScheme $ \col_scheme ->
- let locn' = sdocOption sdocErrorSpans $ \case
- True -> ppr locn
- False -> ppr (srcSpanStart locn)
-
+ = case msg_class of
+ MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg
+ _ -> sdocOption sdocColScheme $ \col_scheme ->
+ let
msg_colour = getMessageClassColour msg_class col_scheme
- col = coloured msg_colour . text
msg_title = coloured msg_colour $
case msg_class of
- MCDiagnostic SevError _ _ -> text "error"
- MCDiagnostic SevWarning _ _ -> text "warning"
MCFatal -> text "fatal"
_ -> empty
+ in formatLocMessageWarningGroups locn msg_title empty empty msg
+
+formatDiagnostic
+ :: Bool -- ^ Print warning groups?
+ -> SrcSpan -- ^ location
+ -> Severity
+ -> ResolvedDiagnosticReason
+ -> Maybe DiagnosticCode
+ -> SDoc -- ^ message
+ -> SDoc
+formatDiagnostic show_warn_groups locn severity reason code msg
+ = sdocOption sdocColScheme $ \col_scheme ->
+ let
+ msg_colour :: Col.PprColour
+ msg_colour = getSeverityColour severity col_scheme
+
+ col :: String -> SDoc
+ col = coloured msg_colour . text
+
+ msg_title :: SDoc
+ msg_title = coloured msg_colour $
+ case severity of
+ SevError -> text "error"
+ SevWarning -> text "warning"
+ SevIgnore -> empty
+
+ warning_flag_doc :: SDoc
warning_flag_doc =
- case msg_class of
- MCDiagnostic sev reason _code
- | Just msg <- flag_msg sev (resolvedDiagnosticReason reason)
- -> brackets msg
- _ -> empty
+ case flag_msg severity (resolvedDiagnosticReason reason) of
+ Nothing -> empty
+ Just msg -> brackets msg
+ ppr_with_hyperlink :: DiagnosticCode -> SDoc
ppr_with_hyperlink code =
-- this is a bit hacky, but we assume that if the terminal supports colors
-- then it should also support links
@@ -691,10 +711,11 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
then ppr $ LinkedDiagCode code
else ppr code
+ code_doc :: SDoc
code_doc =
- case msg_class of
- MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code)
- _ -> empty
+ case code of
+ Just code -> brackets (ppr_with_hyperlink code)
+ Nothing -> empty
flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
flag_msg SevIgnore _ = Nothing
@@ -725,13 +746,35 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
vcat [ text "locn:" <+> ppr locn
, text "msg:" <+> ppr msg ]
+ warn_flag_grp :: [WarningGroup] -> SDoc
warn_flag_grp groups
| show_warn_groups, not (null groups)
= text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")"
| otherwise = empty
+ in formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
+
+formatLocMessageWarningGroups
+ :: SrcSpan -- ^ location
+ -> SDoc -- ^ title
+ -> SDoc -- ^ diagnostic code
+ -> SDoc -- ^ warning groups
+ -> SDoc -- ^ message
+ -> SDoc
+formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
+ = sdocOption sdocColScheme $ \col_scheme ->
+ let
+ -- Always print the location, even if it is unhelpful. Error messages
+ -- are supposed to be in a standard format, and one without a location
+ -- would look strange. Better to say explicitly "<no location info>".
+ locn' :: SDoc
+ locn' = sdocOption sdocErrorSpans $ \case
+ True -> ppr locn
+ False -> ppr (srcSpanStart locn)
+
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
+ header :: SDoc
header = locn' <> colon <+>
msg_title <> colon <+>
code_doc <+> warning_flag_doc
@@ -741,11 +784,16 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
msg)
getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
-getMessageClassColour (MCDiagnostic SevError _reason _code) = Col.sError
-getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning
+getMessageClassColour (MCDiagnostic severity _reason _code) = getSeverityColour severity
getMessageClassColour MCFatal = Col.sFatal
getMessageClassColour _ = const mempty
+getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
+getSeverityColour severity = case severity of
+ SevError -> Col.sError
+ SevWarning -> Col.sWarning
+ SevIgnore -> const mempty
+
getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
getCaretDiagnostic msg_class (RealSrcSpan span _) =
=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -32,7 +32,7 @@ module GHC.Utils.Error (
emptyMessages, mkDecorated, mkLocMessage,
mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
mkErrorMsgEnvelope,
- mkMCDiagnostic, diagReasonSeverity,
+ mkLintWarning, diagReasonSeverity,
mkPlainError,
mkPlainDiagnostic,
@@ -160,12 +160,10 @@ diag_reason_severity opts reason = fmap ResolvedDiagnosticReason $ case reason o
ErrorWithoutFlag
-> (SevError, reason)
--- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the
--- 'DiagOpts'.
-mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
-mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code
+mkLintWarning :: DiagOpts -> SrcSpan -> SDoc -> SDoc
+mkLintWarning opts span = formatDiagnostic True span severity reason Nothing
where
- (sev, reason') = diag_reason_severity opts reason
+ (severity, reason) = diag_reason_severity opts WarningWithoutFlag
--
-- Creating MsgEnvelope(s)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f99e4baee82989bf2fd49cdae241d55…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f99e4baee82989bf2fd49cdae241d55…
You're receiving this email because of your account on gitlab.haskell.org.
1
0