July 2025 - ghc-commits

[Git][ghc/ghc] Pushed new branch wip/andreask/linker_fix
by Andreas Klebinger (＠AndreasK) 31 Jul '25

31 Jul '25

Andreas Klebinger pushed new branch wip/andreask/linker_fix at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/linker_fix You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/supersven/fix_MO_S_Shr
by Sven Tennie (＠supersven) 31 Jul '25

31 Jul '25

Sven Tennie pushed new branch wip/supersven/fix_MO_S_Shr at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/supersven/fix_MO_S_Shr You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] docs/users_guide/win32-dlls.rst: Remove references to `readline`
by Marge Bot (＠marge-bot) 31 Jul '25

31 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 618687ef by Simon Hengel at 2025-07-31T06:27:03-04:00 docs/users_guide/win32-dlls.rst: Remove references to `readline` - - - - - 1 changed file: - docs/users_guide/win32-dlls.rst Changes: ===================================== docs/users_guide/win32-dlls.rst ===================================== @@ -76,11 +76,6 @@ window, use the flag ``-optl-mwindows`` in the link step. However using Debug.Trace.trace is alright because it uses Windows debugging output support rather than ``stderr``. -For some reason, Mingw ships with the ``readline`` library, but not with -the ``readline`` headers. As a result, GHC (like Hugs) does not use -``readline`` for interactive input on Windows. You can get a close -simulation by using an emacs shell buffer! - .. _library-differences: Differences in library behaviour View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/618687ef9ce3980780edc522941e4f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/618687ef9ce3980780edc522941e4f5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: rts: Disable --eventlog-flush-interval unless compiled with -threaded.
by Marge Bot (＠marge-bot) 31 Jul '25

31 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 5 changed files: - docs/users_guide/runtime_control.rst - rts/RtsFlags.c - rts/Timer.c - rts/include/rts/Flags.h - testsuite/tests/rts/flags/all.T Changes: ===================================== docs/users_guide/runtime_control.rst ===================================== @@ -1361,7 +1361,8 @@ When the program is linked with the :ghc-flag:`-eventlog` option :since: 9.2 When enabled, the eventlog will be flushed periodically every - ⟨seconds⟩. This can be useful in live-monitoring situations where the + ⟨seconds⟩ (only available with :ghc-flag:`-threaded`). + This can be useful in live-monitoring situations where the eventlog is consumed in real-time by another process. .. rts-flag:: -v [⟨flags⟩] ===================================== rts/RtsFlags.c ===================================== @@ -248,7 +248,9 @@ void initRtsFlagsDefaults(void) RtsFlags.TraceFlags.user = false; RtsFlags.TraceFlags.ticky = false; RtsFlags.TraceFlags.trace_output = NULL; +# if defined(THREADED_RTS) RtsFlags.TraceFlags.eventlogFlushTime = 0; +# endif RtsFlags.TraceFlags.nullWriter = false; #endif @@ -448,8 +450,10 @@ usage_text[] = { # endif " -x disable an event class, for any flag above", " the initial enabled event classes are 'sgpu'", +# if defined(THREADED_RTS) " --eventlog-flush-interval=<secs>", " Periodically flush the eventlog at the specified interval.", +# endif #endif "", @@ -1052,12 +1056,14 @@ error = true; else if (!strncmp("eventlog-flush-interval=", &rts_argv[arg][2], 24)) { OPTION_SAFE; + THREADED_BUILD_ONLY( double intervalSeconds = parseDouble(rts_argv[arg]+26, &error); if (error) { errorBelch("bad value for --eventlog-flush-interval"); } RtsFlags.TraceFlags.eventlogFlushTime = fsecondsToTime(intervalSeconds); + ) break; } else if (strequal("copying-gc", &rts_argv[arg][2])) { @@ -1963,6 +1969,7 @@ static void normaliseRtsOpts (void) RtsFlags.ProfFlags.heapProfileIntervalTicks = 0; } +#if defined(THREADED_RTS) if (RtsFlags.TraceFlags.eventlogFlushTime > 0 && RtsFlags.MiscFlags.tickInterval != 0) { RtsFlags.TraceFlags.eventlogFlushTicks = RtsFlags.TraceFlags.eventlogFlushTime / @@ -1970,6 +1977,7 @@ static void normaliseRtsOpts (void) } else { RtsFlags.TraceFlags.eventlogFlushTicks = 0; } +#endif if (RtsFlags.GcFlags.stkChunkBufferSize > RtsFlags.GcFlags.stkChunkSize / 2) { ===================================== rts/Timer.c ===================================== @@ -43,8 +43,10 @@ static StgWord timer_disabled; /* ticks left before next pre-emptive context switch */ static int ticks_to_ctxt_switch = 0; +#if defined(THREADED_RTS) /* ticks left before next next forced eventlog flush */ static int ticks_to_eventlog_flush = 0; +#endif /* @@ -118,7 +120,7 @@ handle_tick(int unused STG_UNUSED) contextSwitchAllCapabilities(); /* schedule a context switch */ } } - +#if defined(THREADED_RTS) if (eventLogStatus() == EVENTLOG_RUNNING && RtsFlags.TraceFlags.eventlogFlushTicks > 0) { ticks_to_eventlog_flush--; @@ -127,6 +129,7 @@ handle_tick(int unused STG_UNUSED) flushEventLog(NULL); } } +#endif /* * If we've been inactive for idleGCDelayTime (set by +RTS ===================================== rts/include/rts/Flags.h ===================================== @@ -188,8 +188,11 @@ typedef struct _TRACE_FLAGS { bool sparks_full; /* trace spark events 100% accurately */ bool ticky; /* trace ticky-ticky samples */ bool user; /* trace user events (emitted from Haskell code) */ - Time eventlogFlushTime; /* Time between force eventlog flushes (or 0 if disabled) */ +#if defined(THREADED_RTS) + /* Time between force eventlog flushes (or 0 if disabled) */ + Time eventlogFlushTime; int eventlogFlushTicks; +#endif char *trace_output; /* output filename for eventlog */ bool nullWriter; /* use null writer instead of file writer */ } TRACE_FLAGS; ===================================== testsuite/tests/rts/flags/all.T ===================================== @@ -57,6 +57,14 @@ test('T12870h', multimod_compile_and_run, ['T12870g', '-rtsopts=ignoreAll -with-rtsopts="-G3"']) -test('T20006', [extra_run_opts('+RTS --eventlog-flush-interval=1')], - compile_and_run, - ['']) +test('T20006a', + [extra_files(['T20006.hs']), extra_run_opts('+RTS --eventlog-flush-interval=1'), + only_ways(['threaded1', 'threaded2'])], + multimod_compile_and_run, + ['T20006', '']) + +test('T20006b', + [extra_files(['T20006.hs']), extra_run_opts('+RTS --eventlog-flush-interval=1'), + expect_fail_for(['normal'])], + multimod_compile_and_run, + ['T20006', '']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee2dc24851889e88895908c2bb088e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee2dc24851889e88895908c2bb088e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Update comments on `OptKind` to reflect the code reality
by Marge Bot (＠marge-bot) 31 Jul '25

31 Jul '25

Marge Bot pushed to branch master 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 - - - - - 1 changed file: - compiler/GHC/Driver/CmdLine.hs Changes: ===================================== compiler/GHC/Driver/CmdLine.hs ===================================== @@ -92,14 +92,14 @@ data GhcFlagMode data OptKind m -- Suppose the flag is -f = NoArg (EwM m ()) -- -f all by itself - | HasArg (String -> EwM m ()) -- -farg or -f arg + | HasArg (String -> EwM m ()) -- -farg or -f=arg or -f arg | SepArg (String -> EwM m ()) -- -f arg - | Prefix (String -> EwM m ()) -- -farg - | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) - | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn - | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn - | Word64Suffix (Word64 -> EwM m ()) -- -f or -f=n; pass n to fn - | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn + | Prefix (String -> EwM m ()) -- -farg or -f=arg + | OptPrefix (String -> EwM m ()) -- -f or -farg or -f=arg (i.e. the arg is optional) + | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -fn or -f=n; pass n to fn + | IntSuffix (Int -> EwM m ()) -- -fn or -f=n; pass n to fn + | Word64Suffix (Word64 -> EwM m ()) -- -fn or -f=n; pass n to fn + | FloatSuffix (Float -> EwM m ()) -- -fn or -f=n; pass n to fn | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee2dc24851889e88895908c2bb088ec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee2dc24851889e88895908c2bb088ec… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/ccs-index-table
by Hannes Siebenhandl (＠fendor) 31 Jul '25

31 Jul '25

Hannes Siebenhandl pushed new branch wip/fendor/ccs-index-table at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/ccs-index-table You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109] Wibble imports
by Simon Peyton Jones (＠simonpj) 31 Jul '25

31 Jul '25

Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC Commits: d82a402d by Simon Peyton Jones at 2025-07-31T08:45:50+01:00 Wibble imports - - - - - 1 changed file: - compiler/GHC/Core/Utils.hs Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -76,7 +76,7 @@ import GHC.Core.FVs( bindFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type import GHC.Core.Predicate( isEqPred ) -import GHC.Core.Predicate( isCoVarType, isUnaryClass ) +import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.FamInstEnv import GHC.Core.TyCo.Compare( eqType, eqTypeX ) import GHC.Core.Coercion View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d82a402d613000feb7d16e4e78d51e6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d82a402d613000feb7d16e4e78d51e6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Update comments on `OptKind` to reflect the code reality
by Marge Bot (＠marge-bot) 31 Jul '25

31 Jul '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c6267c76 by Simon Hengel at 2025-07-30T22:55:03-04:00 Update comments on `OptKind` to reflect the code reality - - - - - a4b8da56 by Wen Kokke at 2025-07-30T22:55:06-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. - - - - - eea75a0a by Wen Kokke at 2025-07-30T22:55:06-04:00 rts: Split T20006 into tests with and without -threaded - - - - - 625f5d88 by Simon Hengel at 2025-07-30T22:55:07-04:00 docs/users_guide/win32-dlls.rst: Remove references to `readline` - - - - - 7 changed files: - compiler/GHC/Driver/CmdLine.hs - docs/users_guide/runtime_control.rst - docs/users_guide/win32-dlls.rst - rts/RtsFlags.c - rts/Timer.c - rts/include/rts/Flags.h - testsuite/tests/rts/flags/all.T Changes: ===================================== compiler/GHC/Driver/CmdLine.hs ===================================== @@ -92,14 +92,14 @@ data GhcFlagMode data OptKind m -- Suppose the flag is -f = NoArg (EwM m ()) -- -f all by itself - | HasArg (String -> EwM m ()) -- -farg or -f arg + | HasArg (String -> EwM m ()) -- -farg or -f=arg or -f arg | SepArg (String -> EwM m ()) -- -f arg - | Prefix (String -> EwM m ()) -- -farg - | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) - | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn - | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn - | Word64Suffix (Word64 -> EwM m ()) -- -f or -f=n; pass n to fn - | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn + | Prefix (String -> EwM m ()) -- -farg or -f=arg + | OptPrefix (String -> EwM m ()) -- -f or -farg or -f=arg (i.e. the arg is optional) + | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -fn or -f=n; pass n to fn + | IntSuffix (Int -> EwM m ()) -- -fn or -f=n; pass n to fn + | Word64Suffix (Word64 -> EwM m ()) -- -fn or -f=n; pass n to fn + | FloatSuffix (Float -> EwM m ()) -- -fn or -f=n; pass n to fn | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn ===================================== docs/users_guide/runtime_control.rst ===================================== @@ -1361,7 +1361,8 @@ When the program is linked with the :ghc-flag:`-eventlog` option :since: 9.2 When enabled, the eventlog will be flushed periodically every - ⟨seconds⟩. This can be useful in live-monitoring situations where the + ⟨seconds⟩ (only available with :ghc-flag:`-threaded`). + This can be useful in live-monitoring situations where the eventlog is consumed in real-time by another process. .. rts-flag:: -v [⟨flags⟩] ===================================== docs/users_guide/win32-dlls.rst ===================================== @@ -76,11 +76,6 @@ window, use the flag ``-optl-mwindows`` in the link step. However using Debug.Trace.trace is alright because it uses Windows debugging output support rather than ``stderr``. -For some reason, Mingw ships with the ``readline`` library, but not with -the ``readline`` headers. As a result, GHC (like Hugs) does not use -``readline`` for interactive input on Windows. You can get a close -simulation by using an emacs shell buffer! - .. _library-differences: Differences in library behaviour ===================================== rts/RtsFlags.c ===================================== @@ -248,7 +248,9 @@ void initRtsFlagsDefaults(void) RtsFlags.TraceFlags.user = false; RtsFlags.TraceFlags.ticky = false; RtsFlags.TraceFlags.trace_output = NULL; +# if defined(THREADED_RTS) RtsFlags.TraceFlags.eventlogFlushTime = 0; +# endif RtsFlags.TraceFlags.nullWriter = false; #endif @@ -448,8 +450,10 @@ usage_text[] = { # endif " -x disable an event class, for any flag above", " the initial enabled event classes are 'sgpu'", +# if defined(THREADED_RTS) " --eventlog-flush-interval=<secs>", " Periodically flush the eventlog at the specified interval.", +# endif #endif "", @@ -1052,12 +1056,14 @@ error = true; else if (!strncmp("eventlog-flush-interval=", &rts_argv[arg][2], 24)) { OPTION_SAFE; + THREADED_BUILD_ONLY( double intervalSeconds = parseDouble(rts_argv[arg]+26, &error); if (error) { errorBelch("bad value for --eventlog-flush-interval"); } RtsFlags.TraceFlags.eventlogFlushTime = fsecondsToTime(intervalSeconds); + ) break; } else if (strequal("copying-gc", &rts_argv[arg][2])) { @@ -1963,6 +1969,7 @@ static void normaliseRtsOpts (void) RtsFlags.ProfFlags.heapProfileIntervalTicks = 0; } +#if defined(THREADED_RTS) if (RtsFlags.TraceFlags.eventlogFlushTime > 0 && RtsFlags.MiscFlags.tickInterval != 0) { RtsFlags.TraceFlags.eventlogFlushTicks = RtsFlags.TraceFlags.eventlogFlushTime / @@ -1970,6 +1977,7 @@ static void normaliseRtsOpts (void) } else { RtsFlags.TraceFlags.eventlogFlushTicks = 0; } +#endif if (RtsFlags.GcFlags.stkChunkBufferSize > RtsFlags.GcFlags.stkChunkSize / 2) { ===================================== rts/Timer.c ===================================== @@ -43,8 +43,10 @@ static StgWord timer_disabled; /* ticks left before next pre-emptive context switch */ static int ticks_to_ctxt_switch = 0; +#if defined(THREADED_RTS) /* ticks left before next next forced eventlog flush */ static int ticks_to_eventlog_flush = 0; +#endif /* @@ -118,7 +120,7 @@ handle_tick(int unused STG_UNUSED) contextSwitchAllCapabilities(); /* schedule a context switch */ } } - +#if defined(THREADED_RTS) if (eventLogStatus() == EVENTLOG_RUNNING && RtsFlags.TraceFlags.eventlogFlushTicks > 0) { ticks_to_eventlog_flush--; @@ -127,6 +129,7 @@ handle_tick(int unused STG_UNUSED) flushEventLog(NULL); } } +#endif /* * If we've been inactive for idleGCDelayTime (set by +RTS ===================================== rts/include/rts/Flags.h ===================================== @@ -188,8 +188,11 @@ typedef struct _TRACE_FLAGS { bool sparks_full; /* trace spark events 100% accurately */ bool ticky; /* trace ticky-ticky samples */ bool user; /* trace user events (emitted from Haskell code) */ - Time eventlogFlushTime; /* Time between force eventlog flushes (or 0 if disabled) */ +#if defined(THREADED_RTS) + /* Time between force eventlog flushes (or 0 if disabled) */ + Time eventlogFlushTime; int eventlogFlushTicks; +#endif char *trace_output; /* output filename for eventlog */ bool nullWriter; /* use null writer instead of file writer */ } TRACE_FLAGS; ===================================== testsuite/tests/rts/flags/all.T ===================================== @@ -57,6 +57,14 @@ test('T12870h', multimod_compile_and_run, ['T12870g', '-rtsopts=ignoreAll -with-rtsopts="-G3"']) -test('T20006', [extra_run_opts('+RTS --eventlog-flush-interval=1')], - compile_and_run, - ['']) +test('T20006a', + [extra_files(['T20006.hs']), extra_run_opts('+RTS --eventlog-flush-interval=1'), + only_ways(['threaded1', 'threaded2'])], + multimod_compile_and_run, + ['T20006', '']) + +test('T20006b', + [extra_files(['T20006.hs']), extra_run_opts('+RTS --eventlog-flush-interval=1'), + expect_fail_for(['normal'])], + multimod_compile_and_run, + ['T20006', '']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/605491ceb6ea363d333663766f8b04… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/605491ceb6ea363d333663766f8b04… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-serialize-3] WIP GHC.ByteCode.Serialize
by Cheng Shao (＠TerrorJack) 31 Jul '25

31 Jul '25

Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC Commits: 6586920f by Cheng Shao at 2025-07-31T02:17:49+00:00 WIP GHC.ByteCode.Serialize - - - - - 2 changed files: - + compiler/GHC/ByteCode/Serialize.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -0,0 +1,274 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.ByteCode.Serialize (testBinByteCode) where + +import GHC.Prelude +import GHC.Utils.Binary +import GHC.ByteCode.Types +import GHC.Utils.Exception +import GHC.Data.FlatBag as FlatBag +import GHCi.FFI +import GHC.Builtin.PrimOps +import GHC.Driver.Env +import GHC.Types.Name +import Data.Proxy +import GHC.Data.FastString +import Data.IORef +import GHC.Types.Name.Cache +import GHC.Types.SrcLoc +import GHC.Types.SptEntry +import GHC.Builtin.Types +import GHC.Types.Id +import Data.Word +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Binary as Binary +import GHCi.Message +import Data.Foldable +import Control.Monad +import GHC.Iface.Binary +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 + cbc' <- readBinByteCode hsc_env f + pure cbc' { bc_breaks = bc_breaks cbc } + +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_spt_entries <- get bh + evaluate + CompiledByteCode + { bc_bcos, + bc_itbls, + bc_strs, + bc_breaks = Nothing, + 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_spt_entries + +instance Binary CgBreakInfo where + put_ bh CgBreakInfo {..} = put_ bh cgb_tyvars *> put_ bh cgb_vars *> put_ bh cgb_resty *> put_ bh cgb_tick_id + + get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh + +instance Binary ConInfoTable where + get bh = Binary.decode . LBS.fromStrict <$> get bh + + put_ bh = put_ bh . LBS.toStrict . Binary.encode + + +instance Binary UnlinkedBCO where + get bh = + UnlinkedBCO + <$> getViaSerializableName bh + <*> get bh + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> (Binary.decode . LBS.fromStrict <$> get bh) + <*> get bh + <*> get bh + + put_ bh UnlinkedBCO {..} = do + putViaSerializableName bh unlinkedBCOName + put_ bh unlinkedBCOArity + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs + put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap + put_ bh unlinkedBCOLits + put_ bh unlinkedBCOPtrs + +instance Binary BCOPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCOPtrName <$> getViaSerializableName bh + 1 -> BCOPtrPrimOp <$> get bh + 2 -> BCOPtrBCO <$> get bh + _ -> BCOPtrBreakArray <$> get bh + + put_ bh ptr = case ptr of + BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm + BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op + BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco + BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod + +instance Binary BCONPtr where + get bh = do + t <- getByte bh + case t of + 0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64) + 1 -> BCONPtrLbl <$> get bh + 2 -> BCONPtrItbl <$> getViaSerializableName bh + 3 -> BCONPtrAddr <$> getViaSerializableName bh + 4 -> BCONPtrStr <$> get bh + 5 -> BCONPtrFS <$> get bh + 6 -> BCONPtrFFIInfo <$> get bh + _ -> BCONPtrCostCentre <$> get bh + + put_ bh ptr = case ptr of + BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64) + BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym + BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm + BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm + BCONPtrStr str -> putByte bh 4 *> put_ bh str + BCONPtrFS fs -> putByte bh 5 *> put_ bh fs + BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi + BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi + +instance Binary BreakpointId where + get bh = BreakpointId <$> get bh <*> get bh + + put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index + +instance Binary InternalBreakpointId where + get bh = InternalBreakpointId <$> get bh <*> get bh + + put_ bh InternalBreakpointId {..} = put_ bh ibi_info_mod *> put_ bh ibi_info_index + +instance Binary SptEntry where + get bh = do + nm <- getViaSerializableName bh + fp <- get bh + pure $ SptEntry (mkVanillaGlobal nm anyTy) fp + + put_ bh (SptEntry nm fp) = putViaSerializableName bh (getName nm) *> put_ bh fp + + +newtype SerializableName = SerializableName {unSerializableName :: Name} + +getViaSerializableName :: ReadBinHandle -> IO Name +getViaSerializableName bh = case findUserDataReader Proxy bh of + BinaryReader f -> unSerializableName <$> f bh + +putViaSerializableName :: WriteBinHandle -> Name -> IO () +putViaSerializableName bh nm = case findUserDataWriter Proxy bh of + BinaryWriter f -> f bh $ SerializableName nm + +addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle +addSerializableNameWriter bh' = + evaluate + $ flip addWriterToUserData bh' + $ BinaryWriter + $ \bh + ( SerializableName + nm + ) -> + if + | isExternalName nm -> do + putByte bh 0 + put_ bh nm + | otherwise -> do + putByte bh 1 + put_ bh $ occNameFS (occName nm) `appendFS` mkFastString (show $ nameUnique nm) + +addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle +addSerializableNameReader HscEnv {..} bh' = do + nc <- evaluate hsc_NC + env_ref <- newIORef emptyOccEnv + evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do + t <- getByte bh + case t of + 0 -> do + nm <- get bh + evaluate $ SerializableName nm + _ -> do + occ <- mkVarOccFS <$> get bh + u <- takeUniqFromNameCache nc + nm' <- evaluate $ mkInternalName u occ noSrcSpan + fmap SerializableName + $ atomicModifyIORef' env_ref + $ \env -> case lookupOccEnv env occ of + Just nm -> (env, nm) + _ -> (extendOccEnv env occ nm', nm') + +instance Binary PrimOp where + get bh = (allThePrimOps !!) <$> get bh + + put_ bh = put_ bh . primOpTag + +instance Binary FFIInfo where + get bh = FFIInfo <$> get bh <*> get bh + + put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet + +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 + _ -> FFIUInt64 + + 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 + + +instance (Binary a) => Binary (FlatBag a) where + get bh = do + xs <- get bh + evaluate $ FlatBag.fromList (fromIntegral $ length xs) xs + + put_ bh = put_ bh . FlatBag.elemsFlatBag ===================================== 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/-/commit/6586920fd22e5bf2f6e6ba3158ed96a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6586920fd22e5bf2f6e6ba3158ed96a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/bytecode-serialize-3
by Cheng Shao (＠TerrorJack) 30 Jul '25

30 Jul '25

Cheng Shao pushed new branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/bytecode-serialize-3 You're receiving this email because of your account on gitlab.haskell.org.

1 0