- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/bytecode-serialize-3] 2 commits: compiler: WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 11 Aug '25

11 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: 1286aefe by Cheng Shao at 2025-08-11T07:38:39+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - 18e8f955 by Cheng Shao at 2025-08-11T07:38:44+00:00 driver: test bytecode roundtrip serialization - - - - - 14 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/Data/SmallArray.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -53,10 +53,12 @@ import GHC.Types.Unique ( Unique ) import GHC.Unit.Types ( Unit ) +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString +import GHC.Data.SmallArray {- ************************************************************************ @@ -929,3 +931,12 @@ primOpIsReallyInline = \case DataToTagSmallOp -> False DataToTagLargeOp -> False p -> not (primOpOutOfLine p) + +instance Binary PrimOp where + get bh = (allThePrimOpsArr `indexSmallArray`) <$> get bh + + put_ bh = put_ bh . primOpTag + +allThePrimOpsArr :: SmallArray PrimOp +{-# NOINLINE allThePrimOpsArr #-} +allThePrimOpsArr = listToArray (maxPrimOpTag + 1) primOpTag id allThePrimOps ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} -- | Breakpoint information constructed during ByteCode generation. -- @@ -44,6 +45,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 +299,26 @@ instance Outputable CgBreakInfo where parens (ppr (cgb_vars info) <+> ppr (cgb_resty info) <+> ppr (cgb_tick_id info)) + +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 InternalModBreaks where + get bh = InternalModBreaks <$> get bh <*> get bh + + put_ bh InternalModBreaks {..} = + put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks + +deriving via BreakpointId 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,186 @@ +{-# 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.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +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 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 UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaSerializableName bh + <*> get bh + <*> (Binary.decode <$> get bh) + <*> (Binary.decode <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaSerializableName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ Binary.encode unlinkedBCOInstrs + put_ bh $ 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.Panic -- | Store elements in a flattened representation. -- @@ -66,6 +68,21 @@ 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 + t <- getByte bh + case t of + 0 -> pure EmptyFlatBag + 1 -> UnitFlatBag <$> get bh + 2 -> TupleFlatBag <$> get bh <*> get bh + 3 -> FlatBag <$> get bh + _ -> panic "Binary FlatBag: invalid byte" + + put_ bh EmptyFlatBag = putByte bh 0 + put_ bh (UnitFlatBag a) = putByte bh 1 *> put_ bh a + put_ bh (TupleFlatBag a b) = putByte bh 2 *> put_ bh a *> put_ bh b + put_ bh (FlatBag arr) = putByte bh 3 *> put_ bh arr + -- | Create an empty 'FlatBag'. -- -- The empty 'FlatBag' is shared over all instances. @@ -129,4 +146,3 @@ fromSmallArray s = case sizeofSmallArray s of 1 -> UnitFlatBag (indexSmallArray s 0) 2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1) _ -> FlatBag s - ===================================== compiler/GHC/Data/SmallArray.hs ===================================== @@ -29,7 +29,9 @@ import GHC.Exts import GHC.Prelude import GHC.IO import GHC.ST +import GHC.Utils.Binary import Control.DeepSeq +import Data.Foldable data SmallArray a = SmallArray (SmallArray# a) @@ -166,3 +168,17 @@ listToArray (I# size) index_of value_of xs = runST $ ST \s -> (# s', ma #) -> case write_elems ma xs s' of s'' -> case unsafeFreezeSmallArray# ma s'' of (# s''', a #) -> (# s''', SmallArray a #) + +instance (Binary a) => Binary (SmallArray a) where + get bh = do + len <- get bh + ma <- newSmallArrayIO len undefined + for_ [0 .. len - 1] $ \i -> do + a <- get bh + writeSmallArrayIO ma i a + unsafeFreezeSmallArrayIO ma + + put_ bh sa = do + let len = sizeofSmallArray sa + put_ bh len + for_ [0 .. len - 1] $ \i -> put_ bh $ sa `indexSmallArray` i ===================================== 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/HsToCore/Breakpoints.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Name (OccName) import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) import GHC.Unit.Module (Module) +import GHC.Utils.Binary import GHC.Utils.Outputable import Data.List (intersperse) @@ -106,3 +107,13 @@ The breakpoint is in the function called "baz" that is declared in a `let` or `where` clause of a declaration called "bar", which itself is declared in a `let` or `where` clause of the top-level function called "foo". -} + +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 ===================================== 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,8 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHCi.FFI +import GHCi.Message import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) @@ -140,8 +143,10 @@ import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) import Data.Array import Data.Array.IO import Data.Array.Unsafe +import qualified Data.Binary as Binary import Data.ByteString (ByteString, copy) import Data.Coerce +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Short.Internal as SBS @@ -929,6 +934,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 @@ -1849,6 +1860,18 @@ instance Binary ByteString where put_ bh f = putBS bh f get bh = getBS bh +instance Binary LBS.ByteString where + put_ bh lbs = do + put_ bh (fromIntegral (LBS.length lbs) :: Int) + let f bs acc = + ( BS.unsafeUseAsCStringLen bs $ + \(ptr, l) -> putPrim bh l $ \op -> copyBytes op (castPtr ptr) l + ) + *> acc + LBS.foldrChunks f (pure ()) lbs + + get bh = LBS.fromStrict <$> get bh + instance Binary FastString where put_ bh f = case findUserDataWriter (Proxy :: Proxy FastString) bh of @@ -2106,6 +2129,7 @@ instance Binary BinSrcSpan where _ -> do s <- get bh return $ BinSrcSpan (UnhelpfulSpan s) +deriving via BinSrcSpan instance Binary SrcSpan {- Note [Source Location Wrappers] @@ -2163,3 +2187,40 @@ 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 ConInfoTable where + get bh = Binary.decode <$> get bh + + put_ bh = put_ bh . Binary.encode + +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 ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -71,6 +71,7 @@ GHC.Data.Maybe GHC.Data.OrdList GHC.Data.OsPath GHC.Data.Pair +GHC.Data.SmallArray GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -73,6 +73,7 @@ GHC.Data.Maybe GHC.Data.OrdList GHC.Data.OsPath GHC.Data.Pair +GHC.Data.SmallArray GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/806b69e52c7ab779f21488ca87be26… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/806b69e52c7ab779f21488ca87be26… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Handle non-fractional CmmFloats in Cmm's CBE (#26229)
by Marge Bot (＠marge-bot) 11 Aug '25

11 Aug '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 03555ed8 by Sylvain Henry at 2025-08-10T22:20:57-04:00 Handle non-fractional CmmFloats in Cmm's CBE (#26229) Since f8d9d016305be355f518c141f6c6d4826f2de9a2, toRational for Float and Double converts float's infinity and NaN into Rational's infinity and NaN (respectively 1%0 and 0%0). Cmm CommonBlockEliminator hashing function needs to take these values into account as they can appear as literals now. See added testcase. - - - - - 6c956af3 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00 Fix extensions list in `DoAndIfThenElse` docs - - - - - 6dc420b1 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00 Document status of `RelaxedPolyRec` extension This adds a brief extension page explaining the status of the `RelaxedPolyRec` extension. The behaviour of this mode is already explained elsewhere, so this page is mainly for completeness so that various lists of extensions have somewhere to point to for this flag. Fixes #18630 - - - - - 0927bda0 by Simon Peyton Jones at 2025-08-11T03:30:50-04:00 Take more care in zonkEqTypes on AppTy/AppTy This patch fixes #26256. See Note [zonkEqTypes and the PKTI] in GHC.Tc.Solver.Equality - - - - - e7755f73 by Zubin Duggal at 2025-08-11T03:30:51-04:00 ci: upgrade bootstrap compiler on windows to 9.10.1 - - - - - 16 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Cmm/CommonBlockElim.hs - compiler/GHC/Tc/Solver/Equality.hs - docs/users_guide/conf.py - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/exts/doandifthenelse.rst - + docs/users_guide/exts/relaxed_poly_rec.rst - docs/users_guide/exts/types.rst - + testsuite/tests/numeric/should_compile/T26229.hs - testsuite/tests/numeric/should_compile/all.T - + testsuite/tests/partial-sigs/should_compile/T26256.hs - + testsuite/tests/partial-sigs/should_compile/T26256.stderr - testsuite/tests/partial-sigs/should_compile/all.T - + testsuite/tests/typecheck/should_compile/T26256a.hs - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -478,7 +478,7 @@ opsysVariables _ (Windows {}) = mconcat , "LANG" =: "en_US.UTF-8" , "CABAL_INSTALL_VERSION" =: "3.10.2.0" , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs" - , "GHC_VERSION" =: "9.6.4" + , "GHC_VERSION" =: "9.10.1" ] opsysVariables _ _ = mempty ===================================== .gitlab/jobs.yaml ===================================== @@ -3698,7 +3698,7 @@ "BUILD_FLAVOUR": "validate", "CABAL_INSTALL_VERSION": "3.10.2.0", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "GHC_VERSION": "9.6.4", + "GHC_VERSION": "9.10.1", "HADRIAN_ARGS": "--docs=no-sphinx-pdfs", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "LANG": "en_US.UTF-8", @@ -3761,7 +3761,7 @@ "BUILD_FLAVOUR": "validate", "CABAL_INSTALL_VERSION": "3.10.2.0", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "GHC_VERSION": "9.6.4", + "GHC_VERSION": "9.10.1", "HADRIAN_ARGS": "--docs=no-sphinx-pdfs", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "LANG": "en_US.UTF-8", @@ -5579,7 +5579,7 @@ "BUILD_FLAVOUR": "release", "CABAL_INSTALL_VERSION": "3.10.2.0", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "GHC_VERSION": "9.6.4", + "GHC_VERSION": "9.10.1", "HADRIAN_ARGS": "--docs=no-sphinx-pdfs", "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", @@ -5643,7 +5643,7 @@ "BUILD_FLAVOUR": "release", "CABAL_INSTALL_VERSION": "3.10.2.0", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "GHC_VERSION": "9.6.4", + "GHC_VERSION": "9.10.1", "HADRIAN_ARGS": "--docs=no-sphinx-pdfs", "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", @@ -7982,7 +7982,7 @@ "BUILD_FLAVOUR": "validate", "CABAL_INSTALL_VERSION": "3.10.2.0", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "GHC_VERSION": "9.6.4", + "GHC_VERSION": "9.10.1", "HADRIAN_ARGS": "--docs=no-sphinx-pdfs", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "LANG": "en_US.UTF-8", @@ -8044,7 +8044,7 @@ "BUILD_FLAVOUR": "validate", "CABAL_INSTALL_VERSION": "3.10.2.0", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "GHC_VERSION": "9.6.4", + "GHC_VERSION": "9.10.1", "HADRIAN_ARGS": "--docs=no-sphinx-pdfs", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "LANG": "en_US.UTF-8", ===================================== compiler/GHC/Cmm/CommonBlockElim.hs ===================================== @@ -29,6 +29,7 @@ import GHC.Utils.Word64 (truncateWord64ToWord32) import Control.Arrow (first, second) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import GHC.Real (infinity,notANumber) -- ----------------------------------------------------------------------------- -- Eliminate common blocks @@ -167,7 +168,12 @@ hash_block block = hash_lit :: CmmLit -> Word32 hash_lit (CmmInt i _) = fromInteger i - hash_lit (CmmFloat r _) = truncate r + hash_lit (CmmFloat r _) + -- handle these special cases as `truncate` fails on non-fractional numbers (#26229) + | r == infinity = 9999999 + | r == -infinity = 9999998 + | r == notANumber = 6666666 + | otherwise = truncate r hash_lit (CmmVec ls) = hash_list hash_lit ls hash_lit (CmmLabel _) = 119 -- ugh hash_lit (CmmLabelOff _ i) = cvt $ 199 + i ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -197,12 +197,8 @@ zonkEqTypes ev eq_rel ty1 ty2 then tycon tc1 tys1 tys2 else bale_out ty1 ty2 - go ty1 ty2 - | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 - , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 - = do { res_a <- go ty1a ty2a - ; res_b <- go ty1b ty2b - ; return $ combine_rev mkAppTy res_b res_a } + -- If you are temppted to add a case for AppTy/AppTy, be careful + -- See Note [zonkEqTypes and the PKTI] go ty1@(LitTy lit1) (LitTy lit2) | lit1 == lit2 @@ -278,6 +274,32 @@ zonkEqTypes ev eq_rel ty1 ty2 combine_rev f (Right tys) (Right ty) = Right (f ty tys) +{- Note [zonkEqTypes and the PKTI] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because `zonkEqTypes` does /partial/ zonking, we need to be very careful +to maintain the Purely Kinded Type Invariant: see GHC.Tc.Gen/HsType +HsNote [The Purely Kinded Type Invariant (PKTI)]. + +In #26256 we try to solve this equality constraint: + Int :-> Maybe Char ~# k0 Int (m0 Char) +where m0 and k0 are unification variables, and + m0 :: Type -> Type +It happens that m0 was already unified + m0 := (w0 :: kappa) +where kappa is another unification variable that is also already unified: + kappa := Type->Type. +So the original type satisifed the PKTI, but a partially-zonked form + k0 Int (w0 Char) +does not!! (This a bit reminiscent of Note [mkAppTyM].) + +The solution I have adopted is simply to make `zonkEqTypes` bale out on `AppTy`. +After all, it's only supposed to be a quick hack to see if two types are already +equal; if we bale out we'll just get into the "proper" canonicaliser. + +The only tricky thing about this approach is that it relies on /omitting/ +code -- for the AppTy/AppTy case! Hence this Note +-} + {- ********************************************************************* * * * canonicaliseEquality ===================================== docs/users_guide/conf.py ===================================== @@ -35,8 +35,6 @@ nitpick_ignore = [ ("envvar", "TMPDIR"), ("c:type", "bool"), - - ("extension", "RelaxedPolyRec"), ] rst_prolog = """ ===================================== docs/users_guide/expected-undocumented-flags.txt ===================================== @@ -14,7 +14,6 @@ -XPolymorphicComponents -XRecordPuns -XRelaxedLayout --XRelaxedPolyRec -copy-libs-when-linking -dannot-lint -dppr-ticks ===================================== docs/users_guide/exts/doandifthenelse.rst ===================================== @@ -8,7 +8,7 @@ Do And If Then Else :since: 7.0.1 - :status: Included in :extension:`Haskell2010` + :status: Included in :extension:`GHC2024`, :extension:`GHC2021`, :extension:`Haskell2010` Allow semicolons in ``if`` expressions. ===================================== docs/users_guide/exts/relaxed_poly_rec.rst ===================================== @@ -0,0 +1,17 @@ +.. _relaxed-poly-rec: + +Generalised typing of mutually recursive bindings +------------------------------------------------- + +.. extension:: RelaxedPolyRec + :shortdesc: Generalised typing of mutually recursive bindings. + + :since: 6.8.1 + + :status: Included in :extension:`GHC2024`, :extension:`GHC2021`, :extension:`Haskell2010` + +See :ref:`infelicities-recursive-groups` for a description of this extension. +This is a long-standing GHC extension. Around the time of GHC 7.6.3, this +extension became required as part of a typechecker refactoring. +The ``-XRelaxedPolyRec`` flag is now deprecated (since the feature is always +enabled) and may be removed at some future time. ===================================== docs/users_guide/exts/types.rst ===================================== @@ -30,3 +30,4 @@ Types type_errors defer_type_errors roles + relaxed_poly_rec ===================================== testsuite/tests/numeric/should_compile/T26229.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE NegativeLiterals #-} + +module T26229 where + +sqrte2pqiq :: (Floating a, Ord a) => a -> a -> a +sqrte2pqiq e qiq -- = sqrt (e*e + qiq) + | e < - 1.5097698010472593e153 = -(qiq/e) - e + | e < 5.582399551122541e57 = sqrt (e*e + qiq) -- test Infinity# + | e < -5.582399551122541e57 = -sqrt (e*e + qiq) -- test -Infinity# + | otherwise = (qiq/e) + e +{-# SPECIALIZE sqrte2pqiq :: Double -> Double -> Double #-} +{-# SPECIALIZE sqrte2pqiq :: Float -> Float -> Float #-} ===================================== testsuite/tests/numeric/should_compile/all.T ===================================== @@ -22,3 +22,4 @@ test('T15547', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-b test('T23019', normal, compile, ['-O']) test('T23907', [ when(wordsize(32), expect_broken(23908))], compile, ['-ddump-simpl -O2 -dsuppress-all -dno-typeable-binds -dsuppress-uniques']) test('T24331', normal, compile, ['-O -ddump-simpl -dsuppress-all -dsuppress-uniques -dno-typeable-binds']) +test('T26229', normal, compile, ['-O2']) ===================================== testsuite/tests/partial-sigs/should_compile/T26256.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PartialTypeSignatures #-} + +module M (go) where + +import Data.Kind + +type Apply :: (Type -> Type) -> Type +data Apply m + +type (:->) :: Type -> Type -> Type +type family (:->) where (:->) = (->) + +f :: forall (k :: Type -> Type -> Type) (m :: Type -> Type). + k Int (m Char) -> k Bool (Apply m) +f = f + +x :: Int :-> Maybe Char +x = x + +go :: Bool -> _ _ +go = f x ===================================== testsuite/tests/partial-sigs/should_compile/T26256.stderr ===================================== @@ -0,0 +1,8 @@ +T26256.hs:22:15: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Apply :: (* -> *) -> *’ + • In the type signature: go :: Bool -> _ _ + +T26256.hs:22:17: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Maybe :: * -> *’ + • In the first argument of ‘_’, namely ‘_’ + In the type signature: go :: Bool -> _ _ ===================================== testsuite/tests/partial-sigs/should_compile/all.T ===================================== @@ -108,3 +108,4 @@ test('T21667', normal, compile, ['']) test('T22065', normal, compile, ['']) test('T16152', normal, compile, ['']) test('T20076', expect_broken(20076), compile, ['']) +test('T26256', normal, compile, ['']) ===================================== testsuite/tests/typecheck/should_compile/T26256a.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE TypeFamilies #-} + +module T26256 (go) where + +import Data.Kind + +class Cat k where (<<<) :: k a b -> k x a -> k x b +instance Cat (->) where (<<<) = (.) +class Pro k p where pro :: k a b s t -> p a b -> p s t +data Hiding o a b s t = forall e. Hiding (s -> o e a) +newtype Apply e a = Apply (e a) + +type (:->) :: Type -> Type -> Type +type family (:->) where + (:->) = (->) + +go :: (Pro (Hiding Apply) p) => (s :-> e a) -> p a b -> p s t +go sea = pro (Hiding (Apply <<< sea)) ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -940,3 +940,4 @@ test('T26020', normal, compile, ['']) test('T26020a', [extra_files(['T26020a_help.hs'])], multimod_compile, ['T26020a', '-v0']) test('T25992', normal, compile, ['']) test('T14010', normal, compile, ['']) +test('T26256a', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/464c54b8490fbb21049cc184bd1fac… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/464c54b8490fbb21049cc184bd1fac… 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) 11 Aug '25

11 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: bf7738d9 by Cheng Shao at 2025-08-11T07:07:03+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - 806b69e5 by Cheng Shao at 2025-08-11T07:07:06+00:00 driver: test bytecode roundtrip serialization - - - - - 13 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/HsToCore/Breakpoints.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -53,10 +53,12 @@ import GHC.Types.Unique ( Unique ) import GHC.Unit.Types ( Unit ) +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString +import GHC.Data.SmallArray {- ************************************************************************ @@ -929,3 +931,12 @@ primOpIsReallyInline = \case DataToTagSmallOp -> False DataToTagLargeOp -> False p -> not (primOpOutOfLine p) + +instance Binary PrimOp where + get bh = (allThePrimOpsArr `indexSmallArray`) <$> get bh + + put_ bh = put_ bh . primOpTag + +allThePrimOpsArr :: SmallArray PrimOp +{-# NOINLINE allThePrimOpsArr #-} +allThePrimOpsArr = listToArray (maxPrimOpTag + 1) primOpTag id allThePrimOps ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} -- | Breakpoint information constructed during ByteCode generation. -- @@ -44,6 +45,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 +299,26 @@ instance Outputable CgBreakInfo where parens (ppr (cgb_vars info) <+> ppr (cgb_resty info) <+> ppr (cgb_tick_id info)) + +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 InternalModBreaks where + get bh = InternalModBreaks <$> get bh <*> get bh + + put_ bh InternalModBreaks {..} = + put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks + +deriving via BreakpointId 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,186 @@ +{-# 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.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +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 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 UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaSerializableName bh + <*> get bh + <*> (Binary.decode <$> get bh) + <*> (Binary.decode <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaSerializableName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ Binary.encode unlinkedBCOInstrs + put_ bh $ 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/HsToCore/Breakpoints.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Name (OccName) import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) import GHC.Unit.Module (Module) +import GHC.Utils.Binary import GHC.Utils.Outputable import Data.List (intersperse) @@ -106,3 +107,13 @@ The breakpoint is in the function called "baz" that is declared in a `let` or `where` clause of a declaration called "bar", which itself is declared in a `let` or `where` clause of the top-level function called "foo". -} + +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 ===================================== 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,8 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHCi.FFI +import GHCi.Message import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) @@ -140,8 +143,10 @@ import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) import Data.Array import Data.Array.IO import Data.Array.Unsafe +import qualified Data.Binary as Binary import Data.ByteString (ByteString, copy) import Data.Coerce +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Short.Internal as SBS @@ -929,6 +934,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 @@ -1849,6 +1860,18 @@ instance Binary ByteString where put_ bh f = putBS bh f get bh = getBS bh +instance Binary LBS.ByteString where + put_ bh lbs = do + put_ bh (fromIntegral (LBS.length lbs) :: Int) + let f bs acc = + ( BS.unsafeUseAsCStringLen bs $ + \(ptr, l) -> putPrim bh l $ \op -> copyBytes op (castPtr ptr) l + ) + *> acc + LBS.foldrChunks f (pure ()) lbs + + get bh = LBS.fromStrict <$> get bh + instance Binary FastString where put_ bh f = case findUserDataWriter (Proxy :: Proxy FastString) bh of @@ -2106,6 +2129,7 @@ instance Binary BinSrcSpan where _ -> do s <- get bh return $ BinSrcSpan (UnhelpfulSpan s) +deriving via BinSrcSpan instance Binary SrcSpan {- Note [Source Location Wrappers] @@ -2163,3 +2187,40 @@ 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 ConInfoTable where + get bh = Binary.decode <$> get bh + + put_ bh = put_ bh . Binary.encode + +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 ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -71,6 +71,7 @@ GHC.Data.Maybe GHC.Data.OrdList GHC.Data.OsPath GHC.Data.Pair +GHC.Data.SmallArray GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -73,6 +73,7 @@ GHC.Data.Maybe GHC.Data.OrdList GHC.Data.OsPath GHC.Data.Pair +GHC.Data.SmallArray GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b7dc69b5223abaf4860917472bba7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b7dc69b5223abaf4860917472bba7… 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) 11 Aug '25

11 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: 617cd7c0 by Cheng Shao at 2025-08-11T06:47:11+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - 0b7dc69b by Cheng Shao at 2025-08-11T06:47:16+00:00 driver: test bytecode roundtrip serialization - - - - - 11 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/HsToCore/Breakpoints.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 ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} -- | Breakpoint information constructed during ByteCode generation. -- @@ -44,6 +45,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 +299,26 @@ instance Outputable CgBreakInfo where parens (ppr (cgb_vars info) <+> ppr (cgb_resty info) <+> ppr (cgb_tick_id info)) + +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 InternalModBreaks where + get bh = InternalModBreaks <$> get bh <*> get bh + + put_ bh InternalModBreaks {..} = + put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks + +deriving via BreakpointId 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,186 @@ +{-# 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.Foldable +import Data.IORef +import Data.Proxy +import Data.Word +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 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 UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaSerializableName bh + <*> get bh + <*> (Binary.decode <$> get bh) + <*> (Binary.decode <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaSerializableName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ Binary.encode unlinkedBCOInstrs + put_ bh $ 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/HsToCore/Breakpoints.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Name (OccName) import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) import GHC.Unit.Module (Module) +import GHC.Utils.Binary import GHC.Utils.Outputable import Data.List (intersperse) @@ -106,3 +107,13 @@ The breakpoint is in the function called "baz" that is declared in a `let` or `where` clause of a declaration called "bar", which itself is declared in a `let` or `where` clause of the top-level function called "foo". -} + +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 ===================================== 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,8 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHCi.FFI +import GHCi.Message import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) @@ -140,8 +143,10 @@ import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) import Data.Array import Data.Array.IO import Data.Array.Unsafe +import qualified Data.Binary as Binary import Data.ByteString (ByteString, copy) import Data.Coerce +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Short.Internal as SBS @@ -929,6 +934,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 @@ -1849,6 +1860,18 @@ instance Binary ByteString where put_ bh f = putBS bh f get bh = getBS bh +instance Binary LBS.ByteString where + put_ bh lbs = do + put_ bh (fromIntegral (LBS.length lbs) :: Int) + let f bs acc = + ( BS.unsafeUseAsCStringLen bs $ + \(ptr, l) -> putPrim bh l $ \op -> copyBytes op (castPtr ptr) l + ) + *> acc + LBS.foldrChunks f (pure ()) lbs + + get bh = LBS.fromStrict <$> get bh + instance Binary FastString where put_ bh f = case findUserDataWriter (Proxy :: Proxy FastString) bh of @@ -2106,6 +2129,7 @@ instance Binary BinSrcSpan where _ -> do s <- get bh return $ BinSrcSpan (UnhelpfulSpan s) +deriving via BinSrcSpan instance Binary SrcSpan {- Note [Source Location Wrappers] @@ -2163,3 +2187,40 @@ 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 ConInfoTable where + get bh = Binary.decode <$> get bh + + put_ bh = put_ bh . Binary.encode + +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/61b8a371217865d7f9da800d746ce4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/61b8a371217865d7f9da800d746ce4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-serialize-3] 11 commits: Handle non-fractional CmmFloats in Cmm's CBE (#26229)
by Cheng Shao (＠TerrorJack) 11 Aug '25

11 Aug '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: 03555ed8 by Sylvain Henry at 2025-08-10T22:20:57-04:00 Handle non-fractional CmmFloats in Cmm's CBE (#26229) Since f8d9d016305be355f518c141f6c6d4826f2de9a2, toRational for Float and Double converts float's infinity and NaN into Rational's infinity and NaN (respectively 1%0 and 0%0). Cmm CommonBlockEliminator hashing function needs to take these values into account as they can appear as literals now. See added testcase. - - - - - 6c956af3 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00 Fix extensions list in `DoAndIfThenElse` docs - - - - - 6dc420b1 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00 Document status of `RelaxedPolyRec` extension This adds a brief extension page explaining the status of the `RelaxedPolyRec` extension. The behaviour of this mode is already explained elsewhere, so this page is mainly for completeness so that various lists of extensions have somewhere to point to for this flag. Fixes #18630 - - - - - 0ce8f9d1 by Rodrigo Mesquita at 2025-08-11T05:31:32+00:00 cleanup: Move dehydrateCgBreakInfo to Stg2Bc This no longer has anything to do with Core. - - - - - 9b594494 by Rodrigo Mesquita at 2025-08-11T05:31:32+00:00 rts/Disassembler: Fix spacing of BRK_FUN - - - - - 90037367 by Rodrigo Mesquita at 2025-08-11T05:31:32+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. - - - - - 996462bc by Rodrigo Mesquita at 2025-08-11T05:31:32+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). - - - - - 56619123 by Rodrigo Mesquita at 2025-08-11T05:31:33+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 - - - - - 7a37151e by Rodrigo Mesquita at 2025-08-11T05:31:33+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 - - - - - b0e060d8 by Cheng Shao at 2025-08-11T05:31:33+00:00 compiler: WIP GHC.ByteCode.Serialize - - - - - 61b8a371 by Cheng Shao at 2025-08-11T05:31:33+00:00 driver: test bytecode roundtrip serialization - - - - - 47 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/CommonBlockElim.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - docs/users_guide/conf.py - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/exts/doandifthenelse.rst - + docs/users_guide/exts/relaxed_poly_rec.rst - docs/users_guide/exts/types.rst - ghc/GHCi/UI.hs - libraries/ghci/GHCi/Run.hs - rts/Disassembler.c - rts/Interpreter.c - rts/Profiling.c - rts/include/rts/Bytecodes.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/numeric/should_compile/T26229.hs - testsuite/tests/numeric/should_compile/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7ccecd378a7b4c08c371f7ab81e3e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7ccecd378a7b4c08c371f7ab81e3e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Fix extensions list in `DoAndIfThenElse` docs
by Marge Bot (＠marge-bot) 11 Aug '25

11 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6c956af3 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00 Fix extensions list in `DoAndIfThenElse` docs - - - - - 6dc420b1 by J. Ryan Stinnett at 2025-08-10T22:21:42-04:00 Document status of `RelaxedPolyRec` extension This adds a brief extension page explaining the status of the `RelaxedPolyRec` extension. The behaviour of this mode is already explained elsewhere, so this page is mainly for completeness so that various lists of extensions have somewhere to point to for this flag. Fixes #18630 - - - - - 5 changed files: - docs/users_guide/conf.py - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/exts/doandifthenelse.rst - + docs/users_guide/exts/relaxed_poly_rec.rst - docs/users_guide/exts/types.rst Changes: ===================================== docs/users_guide/conf.py ===================================== @@ -35,8 +35,6 @@ nitpick_ignore = [ ("envvar", "TMPDIR"), ("c:type", "bool"), - - ("extension", "RelaxedPolyRec"), ] rst_prolog = """ ===================================== docs/users_guide/expected-undocumented-flags.txt ===================================== @@ -14,7 +14,6 @@ -XPolymorphicComponents -XRecordPuns -XRelaxedLayout --XRelaxedPolyRec -copy-libs-when-linking -dannot-lint -dppr-ticks ===================================== docs/users_guide/exts/doandifthenelse.rst ===================================== @@ -8,7 +8,7 @@ Do And If Then Else :since: 7.0.1 - :status: Included in :extension:`Haskell2010` + :status: Included in :extension:`GHC2024`, :extension:`GHC2021`, :extension:`Haskell2010` Allow semicolons in ``if`` expressions. ===================================== docs/users_guide/exts/relaxed_poly_rec.rst ===================================== @@ -0,0 +1,17 @@ +.. _relaxed-poly-rec: + +Generalised typing of mutually recursive bindings +------------------------------------------------- + +.. extension:: RelaxedPolyRec + :shortdesc: Generalised typing of mutually recursive bindings. + + :since: 6.8.1 + + :status: Included in :extension:`GHC2024`, :extension:`GHC2021`, :extension:`Haskell2010` + +See :ref:`infelicities-recursive-groups` for a description of this extension. +This is a long-standing GHC extension. Around the time of GHC 7.6.3, this +extension became required as part of a typechecker refactoring. +The ``-XRelaxedPolyRec`` flag is now deprecated (since the feature is always +enabled) and may be removed at some future time. ===================================== docs/users_guide/exts/types.rst ===================================== @@ -30,3 +30,4 @@ Types type_errors defer_type_errors roles + relaxed_poly_rec View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/03555ed8bad1cc3dc0bf5744bb0924… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/03555ed8bad1cc3dc0bf5744bb0924… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Handle non-fractional CmmFloats in Cmm's CBE (#26229)
by Marge Bot (＠marge-bot) 11 Aug '25

11 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 03555ed8 by Sylvain Henry at 2025-08-10T22:20:57-04:00 Handle non-fractional CmmFloats in Cmm's CBE (#26229) Since f8d9d016305be355f518c141f6c6d4826f2de9a2, toRational for Float and Double converts float's infinity and NaN into Rational's infinity and NaN (respectively 1%0 and 0%0). Cmm CommonBlockEliminator hashing function needs to take these values into account as they can appear as literals now. See added testcase. - - - - - 3 changed files: - compiler/GHC/Cmm/CommonBlockElim.hs - + testsuite/tests/numeric/should_compile/T26229.hs - testsuite/tests/numeric/should_compile/all.T Changes: ===================================== compiler/GHC/Cmm/CommonBlockElim.hs ===================================== @@ -29,6 +29,7 @@ import GHC.Utils.Word64 (truncateWord64ToWord32) import Control.Arrow (first, second) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import GHC.Real (infinity,notANumber) -- ----------------------------------------------------------------------------- -- Eliminate common blocks @@ -167,7 +168,12 @@ hash_block block = hash_lit :: CmmLit -> Word32 hash_lit (CmmInt i _) = fromInteger i - hash_lit (CmmFloat r _) = truncate r + hash_lit (CmmFloat r _) + -- handle these special cases as `truncate` fails on non-fractional numbers (#26229) + | r == infinity = 9999999 + | r == -infinity = 9999998 + | r == notANumber = 6666666 + | otherwise = truncate r hash_lit (CmmVec ls) = hash_list hash_lit ls hash_lit (CmmLabel _) = 119 -- ugh hash_lit (CmmLabelOff _ i) = cvt $ 199 + i ===================================== testsuite/tests/numeric/should_compile/T26229.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE NegativeLiterals #-} + +module T26229 where + +sqrte2pqiq :: (Floating a, Ord a) => a -> a -> a +sqrte2pqiq e qiq -- = sqrt (e*e + qiq) + | e < - 1.5097698010472593e153 = -(qiq/e) - e + | e < 5.582399551122541e57 = sqrt (e*e + qiq) -- test Infinity# + | e < -5.582399551122541e57 = -sqrt (e*e + qiq) -- test -Infinity# + | otherwise = (qiq/e) + e +{-# SPECIALIZE sqrte2pqiq :: Double -> Double -> Double #-} +{-# SPECIALIZE sqrte2pqiq :: Float -> Float -> Float #-} ===================================== testsuite/tests/numeric/should_compile/all.T ===================================== @@ -22,3 +22,4 @@ test('T15547', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-b test('T23019', normal, compile, ['-O']) test('T23907', [ when(wordsize(32), expect_broken(23908))], compile, ['-ddump-simpl -O2 -dsuppress-all -dno-typeable-binds -dsuppress-uniques']) test('T24331', normal, compile, ['-O -ddump-simpl -dsuppress-all -dsuppress-uniques -dno-typeable-binds']) +test('T26229', normal, compile, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03555ed8bad1cc3dc0bf5744bb0924b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03555ed8bad1cc3dc0bf5744bb0924b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] do not wrap last do statement in an XExpr
by Apoorv Ingle (＠ani) 11 Aug '25

11 Aug '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 35d5a38d by Apoorv Ingle at 2025-08-10T19:30:13-05:00 do not wrap last do statement in an XExpr - - - - - 1 changed file: - compiler/GHC/Tc/Gen/Do.hs Changes: ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -81,14 +81,16 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt` | NoSyntaxExprRn <- ret_expr -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt - = return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField body)) + -- = return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField body)) + = return body | SyntaxExprRn ret <- ret_expr -- -- ------------------------------------------------ -- return e ~~> return e -- to make T18324 work = do let expansion = L body_loc (genHsApp ret body) - return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField expansion)) + --return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField expansion)) + return expansion expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) = -- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35d5a38dc11ddbc6e4482d595de1875… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35d5a38dc11ddbc6e4482d595de1875… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109] 39 commits: Update comments on `OptKind` to reflect the code reality
by Ben Gamari (＠bgamari) 11 Aug '25

11 Aug '25

Ben Gamari pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC Commits: ee2dc248 by Simon Hengel at 2025-07-31T06:25:35-04:00 Update comments on `OptKind` to reflect the code reality - - - - - b029633a by Wen Kokke at 2025-07-31T06:26:21-04:00 rts: Disable --eventlog-flush-interval unless compiled with -threaded. This commit fixes issue #26222: Using --eventlog-flush-interval with the non-threaded RTS leads to eventlog corruption. https://gitlab.haskell.org/ghc/ghc/-/issues/26222 This commit makes three changes when code is compiled against the non-threaded RTS: 1. It disables the --eventlog-flush-interval flag. 2. It disables the documentation for the --eventlog-flush-interval flag. 3. It disables the relevant state from RtsConfig and code from Timer. 4. It updates the entry for --eventlog-flush-interval in the users guide. - - - - - 31159f1d by Wen Kokke at 2025-07-31T06:26:21-04:00 rts: Split T20006 into tests with and without -threaded - - - - - 618687ef by Simon Hengel at 2025-07-31T06:27:03-04:00 docs/users_guide/win32-dlls.rst: Remove references to `readline` - - - - - 083e40f1 by Rodrigo Mesquita at 2025-08-01T04:38:23-04:00 debugger: Uniquely identify breakpoints by internal id Since b85b11994e0130ff2401dd4bbdf52330e0bcf776 (support inlining breakpoints), a breakpoint has been identified at runtime by *two* pairs of <module,index>. - The first, aka a 'BreakpointId', uniquely identifies a breakpoint in the source of a module by using the Tick index. A Tick index can index into ModBreaks.modBreaks_xxx to fetch source-level information about where that tick originated. - When a user specifies e.g. a line breakpoint using :break, we'll reverse engineer what a Tick index for that line - We update the `BreakArray` of that module (got from the LoaderState) at that tick index to `breakOn`. - A BCO we can stop at is headed by a BRK_FUN instruction. This instruction stores in an operand the `tick index` it is associated to. We look it up in the associated `BreakArray` (also an operand) and check wheter it was set to `breakOn`. - The second, aka the `ibi_info_mod` + `ibi_info_ix` of the `InternalBreakpointId`, uniquely index into the `imodBreaks_breakInfo` -- the information we gathered during code generation about the existing breakpoint *ocurrences*. - Note that with optimisation there may be many occurrences of the same source-tick-breakpoint across different modules. The `ibi_info_ix` is unique per occurrence, but the `bi_tick_ix` may be shared. See Note [Breakpoint identifiers] about this. - Note that besides the tick ids, info ids are also stored in `BRK_FUN` so the break handler can refer to the associated `CgBreakInfo`. In light of that, the driving changes come from the desire to have the info_id uniquely identify the breakpoint at runtime, and the source tick id being derived from it: - An InternalBreakpointId should uniquely identify a breakpoint just from the code-generation identifiers of `ibi_info_ix` and `ibi_info_mod`. So we drop `ibi_tick_mod` and `ibi_tick_ix`. - A BRK_FUN instruction need only record the "internal breakpoint id", not the tick-level id. So we drop the tick mod and tick index operands. - A BreakArray should be indexed by InternalBreakpointId rather than BreakpointId That means we need to do some more work when setting a breakpoint. Specifically, we need to figure out the internal ids (occurrences of a breakpoint) from the source-level BreakpointId we want to set the breakpoint at (recall :break refers to breaks at the source level). Besides this change being an improvement to the handling of breakpoints (it's clearer to have a single unique identifier than two competing ones), it unlocks the possibility of generating "internal" breakpoints during Cg (needed for #26042). It should also be easier to introduce multi-threaded-aware `BreakArrays` following this change (needed for #26064). Se also the new Note [ModBreaks vs InternalModBreaks] On i386-linux: ------------------------- Metric Decrease: interpreter_steplocal ------------------------- - - - - - bf03bbaa by Simon Hengel at 2025-08-01T04:39:05-04:00 Don't use MCDiagnostic for `ghcExit` This changes the error message of `ghcExit` from ``` <no location info>: error: Compilation had errors ``` to ``` Compilation had errors ``` - - - - - a889ec75 by Simon Hengel at 2025-08-01T04:39:05-04:00 Respect `-fdiagnostics-as-json` for driver diagnostics (see #24113) - - - - - 81577fe7 by Ben Gamari at 2025-08-02T04:29:39-04:00 configure: Allow override of CrossCompiling As noted in #26236, the current inference logic is a bit simplistic. In particular, there are many cases (e.g. building for a new libc) where the target and host triples may differ yet we are still able to run the produced artifacts as native code. Closes #26236. - - - - - 01136779 by Andreas Klebinger at 2025-08-02T04:30:20-04:00 rts: Support COFF BigObj files in archives. - - - - - 1f9e4f54 by Stephen Morgan at 2025-08-03T15:14:08+10:00 refactor: Modify Data.List.sortOn to use (>) instead of compare. (#26184) This lets a more efficient (>) operation be used if one exists. This is technically a breaking change for malformed Ord instances, where x > y is not equivalent to compare x y == GT. Discussed by the CLC in issue #332: https://github.com/haskell/core-libraries-committee/issues/332 - - - - - 4f6bc9cf by fendor at 2025-08-04T17:50:06-04:00 Revert "base: Expose Backtraces constructor and fields" This reverts commit 17db44c5b32fff82ea988fa4f1a233d1a27bdf57. - - - - - bcdec657 by Zubin Duggal at 2025-08-05T10:37:29+05:30 compiler: Export a version of `newNameCache` that is not prone to footguns. `newNameCache` must be initialized with both a non-"reserved" unique tag, as well as a list of known key names. Failing to do so results in hard to debug unique conflicts. It is difficult for API users to tell which unique tags are safe to use. So instead of leaving this up to the user to decide, we now export a version of `newNameCache` which uses a guaranteed non-reserved unique tag. In fact, this is now the way the unique tag is initialized for all invocations of the compiler. The original version of `newNameCache` is now exported as `newNameCache'` for advanced users. We also deprecate `initNameCache` as it is also prone to footguns and is completely subsumed in functionality by `newNameCache` and `newNameCache'`. Fixes #26135 and #26055 - - - - - 57d3b4a8 by Andrew Lelechenko at 2025-08-05T18:36:31-04:00 hadrian: bump Stackage snapshot to LTS 24.2 / GHC 9.10.2 In line with #25693 we should use GHC 9.10 as a boot compiler, while Hadrian stack.yaml was stuck on GHC 9.6. - - - - - c2a78cea by Peng Fan at 2025-08-05T18:37:27-04:00 NCG/LA64: implement atomic write with finer-grained DBAR hints Signed-off-by: Peng Fan <fanpeng(a)loongson.cn> - - - - - 95231c8e by Teo Camarasu at 2025-08-06T08:35:58-04:00 CODEOWNERS: add CLC as codeowner of base We also remove hvr, since I think he is no longer active - - - - - 77df0ded by Andrew Lelechenko at 2025-08-06T08:36:39-04:00 Bump submodule text to 2.1.3 - - - - - 8af260d0 by Nikolaos Chatzikonstantinou at 2025-08-06T08:37:23-04:00 docs: fix internal import in getopt examples This external-facing doc example shouldn't mention GHC internals when using 'fromMaybe'. - - - - - 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. - - - - - e5b5268f by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Make injecting implicit bindings into its own pass Previously we were injecting "impliicit bindings" (data constructor worker and wrappers etc) - both at the end of CoreTidy, - and at the start of CorePrep This is unpleasant and confusing. This patch puts it it its own pass, addImplicitBinds, which runs between the two. The function `GHC.CoreToStg.AddImplicitBinds.addImplicitBinds` now takes /all/ TyCons, not just the ones for algebraic data types. That change ripples through to - corePrepPgm - doCodeGen - byteCodeGen All take [TyCon] which includes all TyCons - - - - - e4cdadc6 by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Implement unary classes The big change is described exhaustively in Note [Unary class magic] in GHC.Core.TyCon Other changes * We never unbox class dictionaries in worker/wrapper. This has been true for some time now, but the logic is now centralised in functions in GHC.Core.Opt.WorkWrap.Utils, namely `canUnboxTyCon`, and `canUnboxArg` See Note [Do not unbox class dictionaries] in GHC.Core.Opt.WorkWrap.Utils. * Refactored the `notWorthFloating` logic in GHc.Core.Opt.SetLevels. I can't remember if I actually changed any behaviour here, but if so it's only in a corner cases. * Fixed a bug in `GHC.Core.TyCon.isEnumerationTyCon`, which was wrongly returning True for (##). * Remove redundant Role argument to `liftCoSubstWithEx`. It was always Representational. * I refactored evidence generation in the constraint solver: * Made GHC.Tc.Types.Evidence contain better abstactions for evidence generation. * I deleted the file `GHC.Tc.Types.EvTerm` and merged its (small) contents elsewhere. It wasn't paying its way. * Made evidence for implicit parameters go via a proper abstraction. * Fix inlineBoringOk; see (IB6) in Note [inlineBoringOk] This fixes a slowdown in `countdownEffectfulDynLocal` in the `effectful` library. Smaller things * Rename `isDataTyCon` to `isBoxedDataTyCon`. * GHC.Core.Corecion.liftCoSubstWithEx was only called with Representational role, so I baked that into the function and removed the argument. * Get rid of `GHC.Core.TyCon.tyConSingleAlgDataCon_maybe` in favour of calling `not isNewTyCon` at the call sites; more explicit. * Refatored `GHC.Core.TyCon.isInjectiveTyCon`; but I don't think I changed its behaviour * Moved `decomposeIPPred` to GHC.Core.Predicate Compile time performance changes: geo. mean +0.1% minimum -6.8% maximum +14.4% The +14% one is in T21839c, where it seems that a bit more inlining is taking place. That seems acceptable; and the average change is small Metric Decrease: LargeRecord T12227 T16577 T21839r T5642 Metric Increase: T15164 T21839c T3294 T5321FD T5321Fun WWRec - - - - - 380ceca4 by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Accept GHCi debugger output change @alt-romes says this is fine - - - - - e5752bad by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Small hacky fix to specUnfolding ...just using mkApps instead of mkCoreApps (This part is likely to change again in a future commit.) - - - - - 6d7fcedf by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Slight improvement to pre/postInlineUnconditionally Avoids an extra simplifier iteration - - - - - 81e0e41a by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Fix a long-standing assertion error in normSplitTyConApp_maybe - - - - - 23de351b by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Add comment to coercion optimiser - - - - - cea977bd by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Fix mergo bugs - - - - - 0eea5e06 by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Wibble imports - - - - - d092bfb2 by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Fix specialiser ..needs documentation - - - - - dcf28a84 by Simon Peyton Jones at 2025-08-11T00:27:08+00:00 Wibbles - - - - - 977ee0da by Ben Gamari at 2025-08-11T00:27:08+00:00 Move addImplicitBinds - - - - - 182 changed files: - .gitlab/darwin/toolchain.nix - CODEOWNERS - README.md - compiler/GHC/Builtin/Types.hs - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm.hs - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core/Class.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unfold/Make.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - + compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/CmdLine.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/SysTools/Tasks.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - − compiler/GHC/Tc/Types/EvTerm.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/RepType.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Utils/Error.hs - compiler/ghc.cabal.in - configure.ac - docs/users_guide/debug-info.rst - docs/users_guide/exts/linear_types.rst - docs/users_guide/exts/strict.rst - docs/users_guide/runtime_control.rst - docs/users_guide/win32-dlls.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - hadrian/stack.yaml - hadrian/stack.yaml.lock - libraries/base/changelog.md - libraries/base/src/Control/Exception/Backtrace.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - libraries/template-haskell/changelog.md - libraries/text - rts/Disassembler.c - rts/Exception.cmm - rts/IPE.c - rts/Interpreter.c - rts/ProfHeap.c - rts/RtsFlags.c - rts/Timer.c - rts/eventlog/EventLog.c - rts/include/rts/Flags.h - rts/include/rts/IPE.h - rts/linker/LoadArchive.c - testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/corelint/T21115b.stderr - testsuite/tests/deSugar/should_compile/T2431.stderr - testsuite/tests/dmdanal/should_compile/T16029.stdout - testsuite/tests/dmdanal/sigs/T21119.stderr - testsuite/tests/dmdanal/sigs/T21888.stderr - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break024.stdout - testsuite/tests/hiefile/should_run/TestUtils.hs - testsuite/tests/indexed-types/should_compile/T2238.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/numeric/should_compile/T15547.stderr - testsuite/tests/numeric/should_compile/T23907.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/rts/flags/all.T - testsuite/tests/rts/ipe/ipeMap.c - testsuite/tests/rts/ipe/ipe_lib.c - testsuite/tests/simplCore/should_compile/DataToTagFamilyScrut.stderr - testsuite/tests/simplCore/should_compile/T15205.stderr - testsuite/tests/simplCore/should_compile/T17366.stderr - testsuite/tests/simplCore/should_compile/T17966.stderr - testsuite/tests/simplCore/should_compile/T22309.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr - testsuite/tests/simplCore/should_compile/T23307.stderr - testsuite/tests/simplCore/should_compile/T23307a.stderr - testsuite/tests/simplCore/should_compile/T25389.stderr - testsuite/tests/simplCore/should_compile/T25713.stderr - testsuite/tests/simplCore/should_compile/T7360.stderr - testsuite/tests/simplStg/should_compile/T15226b.stderr - + 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 - testsuite/tests/tcplugins/CtIdPlugin.hs - testsuite/tests/typecheck/should_compile/Makefile - testsuite/tests/typecheck/should_compile/T12763.stderr - testsuite/tests/typecheck/should_compile/T14774.stdout - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/unboxedsums/unpack_sums_7.stdout - testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs - testsuite/tests/wasm/should_run/control-flow/RunWasm.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ca4024884440b8b03fdcb509c1ea0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ca4024884440b8b03fdcb509c1ea0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] - rename tcMonoExpr -> tcMonoLExpr, tcMonoExprNC tcMonoLExpr
by Apoorv Ingle (＠ani) 10 Aug '25

10 Aug '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 9dab3569 by Apoorv Ingle at 2025-08-10T18:54:05-05:00 - rename tcMonoExpr -> tcMonoLExpr, tcMonoExprNC tcMonoLExpr - add error ctx before type checking statements to mirror record updates - - - - - 4 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Match.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1328,7 +1328,7 @@ second field. The resulting renamed AST would look like: ) When comes the time to typecheck the program, we end up calling -tcMonoExpr on the AST above. If this expression gives rise to +tcMonoLExpr on the AST above. If this expression gives rise to a type error, then it will appear in a context line and GHC will pretty-print it using the 'Outputable (XXExprGhcRn a b)' instance defined below, which *only prints the original ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -17,7 +17,7 @@ module GHC.Tc.Gen.Expr ( tcCheckPolyExpr, tcCheckPolyExprNC, tcCheckMonoExpr, tcCheckMonoExprNC, - tcMonoExpr, tcMonoExprNC, + tcMonoLExpr, tcMonoLExprNC, tcInferRho, tcInferRhoNC, tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, @@ -243,23 +243,23 @@ tcCheckMonoExpr, tcCheckMonoExprNC -> TcRhoType -- Expected type -- Definitely no foralls at the top -> TcM (LHsExpr GhcTc) -tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty) -tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty) +tcCheckMonoExpr expr res_ty = tcMonoLExpr expr (mkCheckExpType res_ty) +tcCheckMonoExprNC expr res_ty = tcMonoLExprNC expr (mkCheckExpType res_ty) --------------- -tcMonoExpr, tcMonoExprNC +tcMonoLExpr, tcMonoLExprNC :: LHsExpr GhcRn -- Expression to type check -> ExpRhoType -- Expected type -- Definitely no foralls at the top -> TcM (LHsExpr GhcTc) -tcMonoExpr (L loc expr) res_ty +tcMonoLExpr (L loc expr) res_ty = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcExpr expr res_ty ; return (L loc expr') } -tcMonoExprNC (L loc expr) res_ty +tcMonoLExprNC (L loc expr) res_ty = setSrcSpanA loc $ do { expr' <- tcExpr expr res_ty ; return (L loc expr') } @@ -313,11 +313,11 @@ tcExpr e@(HsLit x lit) res_ty ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } tcExpr (HsPar x expr) res_ty - = do { expr' <- tcMonoExprNC expr res_ty + = do { expr' <- tcMonoLExprNC expr res_ty ; return (HsPar x expr') } tcExpr (HsPragE x prag expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty + = do { expr' <- tcMonoLExpr expr res_ty ; return (HsPragE x (tcExprPrag prag) expr') } tcExpr (NegApp x expr neg_expr) res_ty @@ -471,7 +471,7 @@ tcExpr (ExplicitSum _ alt arity expr) res_ty tcExpr (HsLet x binds expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ - tcMonoExpr expr res_ty + tcMonoLExpr expr res_ty ; return (HsLet x binds' expr') } tcExpr (HsCase ctxt scrut matches) res_ty @@ -500,8 +500,8 @@ tcExpr (HsCase ctxt scrut matches) res_ty tcExpr (HsIf x pred b1 b2) res_ty = do { pred' <- tcCheckMonoExpr pred boolTy - ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty - ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty + ; (u1,b1') <- tcCollectingUsage $ tcMonoLExpr b1 res_ty + ; (u2,b2') <- tcCollectingUsage $ tcMonoLExpr b2 res_ty ; tcEmitBindingUsage (supUE u1 u2) ; return (HsIf x pred' b1' b2') } ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -15,7 +15,7 @@ tcCheckPolyExpr, tcCheckPolyExprNC :: -> TcSigmaType -> TcM (LHsExpr GhcTc) -tcMonoExpr, tcMonoExprNC :: +tcMonoLExpr, tcMonoLExprNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -40,7 +40,7 @@ where import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC - , tcMonoExprNC, tcMonoExpr, tcExpr + , tcMonoLExprNC, tcMonoLExpr, tcExpr , tcCheckMonoExpr, tcCheckMonoExprNC , tcCheckPolyExpr, tcPolyLExpr ) @@ -404,15 +404,16 @@ tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty ; return (HsDo res_ty doExpr (L l stmts')) } else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly ; let orig = HsDo noExtField doExpr ss - ; e' <- tcMonoExpr expanded_expr res_ty - ; return (mkExpandedExprTc orig (unLoc e')) + ; setInGeneratedCode (OrigExpr orig) $ do + { e' <- tcMonoLExpr expanded_expr res_ty + ; return (mkExpandedExprTc orig (unLoc e'))} } } tcDoStmts mDoExpr ss@(L _ stmts) res_ty = do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly ; let orig = HsDo noExtField mDoExpr ss - ; e' <- tcMonoExpr expanded_expr res_ty + ; e' <- tcMonoLExpr expanded_expr res_ty ; return (mkExpandedExprTc orig (unLoc e')) } @@ -567,7 +568,7 @@ tcLcStmt :: TyCon -- The list type constructor ([]) -> TcExprStmtChecker tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside - = do { body' <- tcMonoExprNC body elt_ty + = do { body' <- tcMonoLExprNC body elt_ty ; thing <- thing_inside (panic "tcLcStmt: thing_inside") ; return (LastStmt x body' noret noSyntaxExpr, thing) } @@ -970,7 +971,7 @@ tcMcStmt _ stmt _ _ tcDoStmt :: TcExprStmtChecker tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside - = do { body' <- tcMonoExprNC body res_ty + = do { body' <- tcMonoLExprNC body res_ty ; thing <- thing_inside (panic "tcDoStmt: thing_inside") ; return (LastStmt x body' noret noSyntaxExpr, thing) } tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9dab3569adba10bc1f8a70c88be6c16… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9dab3569adba10bc1f8a70c88be6c16… You're receiving this email because of your account on gitlab.haskell.org.

1 0