- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/spj-reinstallable-base2] fix [skip ci]
by Rodrigo Mesquita (＠alt-romes) 14 May '26

14 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 17f61ab5 by Rodrigo Mesquita at 2026-05-14T16:45:27+01:00 fix [skip ci] - - - - - 1 changed file: - compiler/GHC/Builtin/KnownKeys.hs Changes: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -140,7 +140,7 @@ knownKeyTable , (mkTcOcc "Functor", functorClassKey) , (mkTcOcc "Lift", liftClassKey) , (mkTcOcc "MonadPlus", monadPlusClassKey) - , (mkTcOcc "MonadFail", monadPlusClassKey) + , (mkTcOcc "MonadFail", monadFailClassKey) -- Numeric classes , (mkTcOcc "Num", numClassKey) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/17f61ab58d0b4dff5e56a34243bf148… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/17f61ab58d0b4dff5e56a34243bf148… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wenkokke/trace-ipe] 4 commits: ghc-internal: Add @since to TraceFlags.traceIpe
by Wen Kokke (＠wenkokke) 14 May '26

14 May '26

Wen Kokke pushed to branch wip/wenkokke/trace-ipe at Glasgow Haskell Compiler / GHC Commits: 334ba7f8 by Wen Kokke at 2026-05-14T16:44:50+01:00 ghc-internal: Add @since to TraceFlags.traceIpe - - - - - 72a5375b by Wen Kokke at 2026-05-14T16:44:53+01:00 ghc-internal: Add ipe to DebugFlags - - - - - b1a695cd by Wen Kokke at 2026-05-14T16:44:53+01:00 testsuite: Add test for DebugFlags.ipe - - - - - 97983c96 by Wen Kokke at 2026-05-14T16:44:53+01:00 ghc-internal: Add @since to DebugFlags.ipe - - - - - 5 changed files: - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - + testsuite/tests/rts/T25275/DebugIpe.hs - + testsuite/tests/rts/T25275/T25275_C.stdout - + testsuite/tests/rts/T25275/T25275_D.stdout - testsuite/tests/rts/T25275/all.T Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc ===================================== @@ -211,6 +211,8 @@ data DebugFlags = DebugFlags , squeeze :: Bool -- ^ @z@ stack squeezing & lazy blackholing , hpc :: Bool -- ^ @c@ coverage , sparks :: Bool -- ^ @r@ + , ipe :: Bool -- ^ @I@ + -- @since ghc-experimental-9.1001.0 } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -360,6 +362,7 @@ data TraceFlags = TraceFlags , sparksFull :: Bool -- ^ trace spark events 100% accurately , user :: Bool -- ^ trace user events (emitted from Haskell code) , traceIpe :: Bool -- ^ trace IPE events + -- @since ghc-experimental-9.1001.0 } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -589,6 +592,8 @@ getDebugFlags = do (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool)) <*> (toBool <$> (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, ipe} ptr :: IO CBool)) getCCFlags :: IO CCFlags getCCFlags = do ===================================== testsuite/tests/rts/T25275/DebugIpe.hs ===================================== @@ -0,0 +1,6 @@ +module Main where + +import GHC.RTS.Flags.Experimental (DebugFlags (..), getDebugFlags) + +main :: IO () +main = print . ipe =<< getDebugFlags ===================================== testsuite/tests/rts/T25275/T25275_C.stdout ===================================== @@ -0,0 +1 @@ +False \ No newline at end of file ===================================== testsuite/tests/rts/T25275/T25275_D.stdout ===================================== @@ -0,0 +1 @@ +True \ No newline at end of file ===================================== testsuite/tests/rts/T25275/all.T ===================================== @@ -18,3 +18,26 @@ test( multimod_compile_and_run, ['TraceIpe', ''], ) + +# Compile and run with default RTS options +test( + 'T25275_C', + [ + only_ways(['debug']), + extra_files(['DebugIpe.hs']), + ], + multimod_compile_and_run, + ['DebugIpe', ''], +) + +# Compile and run with -DI +test( + 'T25275_D', + [ + only_ways(['debug']), + extra_files(['DebugIpe.hs']), + extra_run_opts('+RTS -DI -RTS'), + ], + multimod_compile_and_run, + ['DebugIpe', ''], +) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/989f67ba0ea2c9cbd0652f428d9cbe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/989f67ba0ea2c9cbd0652f428d9cbe… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wenkokke/trace-ipe] 4 commits: ghc-internal: Add @since to TraceFlags.traceIpe
by Wen Kokke (＠wenkokke) 14 May '26

14 May '26

Wen Kokke pushed to branch wip/wenkokke/trace-ipe at Glasgow Haskell Compiler / GHC Commits: 96feb43b by Wen Kokke at 2026-05-14T16:39:47+01:00 ghc-internal: Add @since to TraceFlags.traceIpe - - - - - d55fe459 by Wen Kokke at 2026-05-14T16:39:56+01:00 ghc-internal: Add ipe to DebugFlags - - - - - fbf31b1c by Wen Kokke at 2026-05-14T16:39:56+01:00 testsuite: Add test for DebugFlags.ipe - - - - - 989f67ba by Wen Kokke at 2026-05-14T16:40:00+01:00 ghc-internal: Add @since to DebugFlags.ipe - - - - - 5 changed files: - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - + testsuite/tests/rts/T25275/DebugIpe.hs - + testsuite/tests/rts/T25275/T25275_C.stdout - + testsuite/tests/rts/T25275/T25275_D.stdout - testsuite/tests/rts/T25275/all.T Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc ===================================== @@ -211,6 +211,8 @@ data DebugFlags = DebugFlags , squeeze :: Bool -- ^ @z@ stack squeezing & lazy blackholing , hpc :: Bool -- ^ @c@ coverage , sparks :: Bool -- ^ @r@ + , ipe :: Bool -- ^ @I@ + -- @since base-4.23.0.0 } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -360,6 +362,7 @@ data TraceFlags = TraceFlags , sparksFull :: Bool -- ^ trace spark events 100% accurately , user :: Bool -- ^ trace user events (emitted from Haskell code) , traceIpe :: Bool -- ^ trace IPE events + -- @since base-4.23.0.0 } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -589,6 +592,8 @@ getDebugFlags = do (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool)) <*> (toBool <$> (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, ipe} ptr :: IO CBool)) getCCFlags :: IO CCFlags getCCFlags = do ===================================== testsuite/tests/rts/T25275/DebugIpe.hs ===================================== @@ -0,0 +1,6 @@ +module Main where + +import GHC.RTS.Flags.Experimental (DebugFlags (..), getDebugFlags) + +main :: IO () +main = print . ipe =<< getDebugFlags ===================================== testsuite/tests/rts/T25275/T25275_C.stdout ===================================== @@ -0,0 +1 @@ +False \ No newline at end of file ===================================== testsuite/tests/rts/T25275/T25275_D.stdout ===================================== @@ -0,0 +1 @@ +True \ No newline at end of file ===================================== testsuite/tests/rts/T25275/all.T ===================================== @@ -18,3 +18,26 @@ test( multimod_compile_and_run, ['TraceIpe', ''], ) + +# Compile and run with default RTS options +test( + 'T25275_C', + [ + only_ways(['debug']), + extra_files(['DebugIpe.hs']), + ], + multimod_compile_and_run, + ['DebugIpe', ''], +) + +# Compile and run with -DI +test( + 'T25275_D', + [ + only_ways(['debug']), + extra_files(['DebugIpe.hs']), + extra_run_opts('+RTS -DI -RTS'), + ], + multimod_compile_and_run, + ['DebugIpe', ''], +) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9762f8151437c174482511f4d94368… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9762f8151437c174482511f4d94368… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] fix serialization; tuples; [skip ci]
by Rodrigo Mesquita (＠alt-romes) 14 May '26

14 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 186353a8 by Rodrigo Mesquita at 2026-05-14T16:36:36+01:00 fix serialization; tuples; [skip ci] - - - - - 5 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Iface/Binary.hs - libraries/ghc-internal/src/GHC/Internal/Records.hs Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -26,11 +26,15 @@ module GHC.Builtin ( knownKeyTable, knownKeyOccMap, knownKeyUniqMap, knownKeyOccName, knownKeyOccName_maybe, + -- * Known names + isWiredInKnownKeyName, + lookupWiredInKnownKeyName, + lookupKnownNameInfo, + -- * Random other things maybeCharLikeCon, maybeIntLikeCon, allNameStrings, allNameStringList, itName, mkUnboundName, isUnboundName, - lookupKnownNameInfo, -- * Class categories isNumericClass, isStandardClass, @@ -42,6 +46,7 @@ module GHC.Builtin ( import GHC.Prelude +import GHC.Builtin.Uniques import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids import GHC.Builtin.WiredIn.Types @@ -72,6 +77,10 @@ import GHC.Data.List.SetOps import GHC.Data.FastString import qualified GHC.Data.List.Infinite as Inf +import Control.Applicative ((<|>)) +import Data.Maybe + + {- ********************************************************************* * * @@ -570,11 +579,17 @@ wiredInNames Nothing -> [] -- | Check the known-key names list of consistency. --- (a) Distinct uniques +-- (a) Unique is in-range +-- (b) Distinct uniques knownKeyNamesOkay :: [Name] -> Maybe SDoc knownKeyNamesOkay all_names - | null badNamesPairs = Nothing - | otherwise = Just badNamesDoc + | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names + = Just $ text " Out-of-range known-key uniques: " <> + brackets (pprWithCommas (ppr . nameOccName) ns) + | null badNamesPairs + = Nothing + | otherwise + = Just badNamesDoc where namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n) emptyUFM all_names @@ -591,6 +606,25 @@ knownKeyNamesOkay all_names text ": " <> brackets (pprWithCommas (ppr . nameOccName) ns) +-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a +-- wired-in thing. +lookupWiredInKnownKeyName :: Unique -> Maybe Name +lookupWiredInKnownKeyName u = + knownUniqueTupleName u <|> lookupUFM_Directly wiredInNamesMap u + +-- | Is a 'Name' a wired-in known-key name? +isWiredInKnownKeyName :: Name -> Bool +isWiredInKnownKeyName n = + isJust (knownUniqueTupleName $ nameUnique n) || elemUFM n wiredInNamesMap + +-- | Maps 'Unique's to known-key names. +-- +-- The type is @UniqFM Name Name@ to denote that the 'Unique's used +-- in the domain are 'Unique's associated with 'Name's (as opposed +-- to some other namespace of 'Unique's). +wiredInNamesMap :: UniqFM Name Name +wiredInNamesMap = listToIdentityUFM wiredInNames + -- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by -- GHCi's ':info' command. lookupKnownNameInfo :: Name -> SDoc ===================================== compiler/GHC/Builtin/Uniques.hs ===================================== @@ -8,8 +8,8 @@ -- module GHC.Builtin.Uniques - ( -- * Looking up known-key names - knownUniqueName + ( -- * Looking up known-key tuples + knownUniqueTupleName -- * Getting the 'Unique's of 'Name's -- ** Anonymous sums @@ -73,9 +73,9 @@ import GHC.Utils.Panic import Data.Maybe import GHC.Utils.Word64 (word64ToInt) --- | Get the 'Name' associated with a known-key 'Unique'. -knownUniqueName :: Unique -> Maybe Name -knownUniqueName u = +-- | Get the 'Name' of a tuple associated with a known-key 'Unique' with a tuple tag. +knownUniqueTupleName :: Unique -> Maybe Name +knownUniqueTupleName u = case tag of SumTag -> Just $ getUnboxedSumName n BoxedTupleTyConTag -> Just $ getTupleTyConName Boxed n ===================================== compiler/GHC/Builtin/Uniques.hs-boot ===================================== @@ -2,12 +2,8 @@ module GHC.Builtin.Uniques where import GHC.Prelude import GHC.Types.Unique -import {-# SOURCE #-} GHC.Types.Name import GHC.Types.Basic --- Needed by GHC.Builtin.Types -knownUniqueName :: Unique -> Maybe Name - mkSumTyConUnique :: Arity -> Unique mkSumDataConUnique :: ConTagZ -> Arity -> Unique ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -32,13 +32,14 @@ module GHC.Iface.Binary ( import GHC.Prelude -import GHC.Builtin ( knownKeyOccMap ) +import GHC.Builtin ( knownKeyOccMap, isWiredInKnownKeyName, lookupWiredInKnownKeyName ) import GHC.Utils.Panic import GHC.Utils.Binary as Binary import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Unique.FM +import GHC.Types.Unique import GHC.Types.SrcLoc import GHC.Types.Name.Cache @@ -57,6 +58,7 @@ import Control.Monad import Data.Array import Data.Array.IO import Data.Array.Unsafe +import Data.Char import Data.IORef import Data.Map.Strict (Map) import Data.Word @@ -701,11 +703,43 @@ getSymbolTable bh name_cache ; writeArray mut_arr (fromIntegral i) name ; return new_cache } + +{- +Note [Symbol table representation of names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An occurrence of a name in an interface file is serialized as a single 32-bit +word. The format of this word is: + 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx + A normal name. x is an index into the symbol table + 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy + A wired-in name. x is the Unique's Char, y is the int part. We assume that + all wired-in known-key uniques fit in this space. This is asserted by + GHC.Builtin.knownKeyNamesOkay. + +During serialization we check for tuples or wired-in things with 'isWiredInKnownKeyName'. +During deserialization we use 'lookupWiredInKnownKeyName' to get from the +unique back to its tuple or corresponding Name. + +Tuples are a special case of wired-in names that we can construct from the +unique alone (see 'knownUniqueTupleName'). Tuples aren't included in the +wired-in names map: see Note [Infinite families of known-key names]. +-} + + +-- See Note [Symbol table representation of names] putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO () putName BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } bh name + | isWiredInKnownKeyName name + , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits + = -- assert (u < 2^(22 :: Int)) + put_ bh (0x80000000 + .|. (fromIntegral (ord c) `shiftL` 22) + .|. (fromIntegral u :: Word32)) + + | otherwise = do symtab_map <- readIORef symtab_map_ref case lookupUFM symtab_map name of Just (off,_) -> put_ bh (fromIntegral off :: Word32) @@ -717,8 +751,23 @@ putName BinSymbolTable{ $! addToUFM symtab_map name (off,name) put_ bh (fromIntegral off :: Word32) +-- See Note [Symbol table representation of names] getSymtabName :: SymbolTable Name -> ReadBinHandle -> IO Name getSymtabName symtab bh = do i :: Word32 <- get bh - return $! symtab ! fromIntegral i + case i .&. 0xC0000000 of + 0x00000000 -> return $! symtab ! fromIntegral i + + 0x80000000 -> + let + tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) + ix = fromIntegral i .&. 0x003FFFFF + u = mkUniqueGrimilyWithTag tag ix + in + return $! case lookupWiredInKnownKeyName u of + Nothing -> pprPanic "getSymtabName:unknown known-key unique" + (ppr i $$ ppr u $$ char tag $$ ppr ix) + Just n -> n + + _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) ===================================== libraries/ghc-internal/src/GHC/Internal/Records.hs ===================================== @@ -32,7 +32,7 @@ module GHC.Internal.Records import GHC.Internal.Base import GHC.Internal.Err( error ) -import GHC.Internal.Stack.Types +import GHC.Internal.Stack.Types as Rebindable -- | Constraint representing the fact that the field @x@ belongs to -- the record type @r@ and has field type @a@. This will be solved View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/186353a82aa0fc1145b887d4b63610e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/186353a82aa0fc1145b887d4b63610e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wenkokke/trace-ipe] 5 commits: rts: Add IPE event class for -l
by Wen Kokke (＠wenkokke) 14 May '26

14 May '26

Wen Kokke pushed to branch wip/wenkokke/trace-ipe at Glasgow Haskell Compiler / GHC Commits: b3fc54c6 by Wen Kokke at 2026-05-14T16:34:02+01:00 rts: Add IPE event class for -l This commit adds a new IPE event class to the -l RTS flag. Previously, IPE events were enabled unconditionally. However, the IPE events can easily grow to hundreds or thousands of megabytes. With the new event class you can pass, e.g., -l-I to disable IPE events. - - - - - b17dc233 by Wen Kokke at 2026-05-14T16:36:27+01:00 ghc-internal: Add traceIPE to TraceFlags - - - - - afcd997b by Wen Kokke at 2026-05-14T16:36:27+01:00 testsuite: Add test for TraceFlags.traceIpe - - - - - 3820da2a by Wen Kokke at 2026-05-14T16:36:27+01:00 ghc-internal: Add ipe to DebugFlags - - - - - 9762f815 by Wen Kokke at 2026-05-14T16:36:27+01:00 testsuite: Add test for DebugFlags.ipe - - - - - 16 changed files: - + changelog.d/ipe-event-class - docs/users_guide/runtime_control.rst - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - rts/IPE.c - rts/RtsFlags.c - rts/Trace.c - rts/Trace.h - rts/include/rts/EventLogWriter.h - rts/include/rts/Flags.h - + testsuite/tests/rts/T25275/DebugIpe.hs - + testsuite/tests/rts/T25275/T25275_A.stdout - + testsuite/tests/rts/T25275/T25275_B.stdout - + testsuite/tests/rts/T25275/T25275_C.stdout - + testsuite/tests/rts/T25275/T25275_D.stdout - + testsuite/tests/rts/T25275/TraceIpe.hs - + testsuite/tests/rts/T25275/all.T Changes: ===================================== changelog.d/ipe-event-class ===================================== @@ -0,0 +1,9 @@ +section: compiler +synopsis: Add eventlog flag -lI to enable/disable IPE tracing +issues: #27239 +mrs: !16004 + +description: { + The RTS `-l` flag now accepts the new event class `I`, + which controls whether or not IPE events are emitted. +} ===================================== docs/users_guide/runtime_control.rst ===================================== @@ -1304,6 +1304,9 @@ When the program is linked with the :ghc-flag:`-eventlog` option - ``u`` — user events. These are events emitted from Haskell code using functions such as ``Debug.Trace.traceEvent``. Enabled by default. + - ``I`` — IPE events. These events describe source position information + for info tables. See :ghc-flag:`-finfo-table-map`. + You can disable specific classes, or enable/disable all classes at once: ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc ===================================== @@ -211,6 +211,7 @@ data DebugFlags = DebugFlags , squeeze :: Bool -- ^ @z@ stack squeezing & lazy blackholing , hpc :: Bool -- ^ @c@ coverage , sparks :: Bool -- ^ @r@ + , ipe :: Bool -- ^ @I@ } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -359,6 +360,7 @@ data TraceFlags = TraceFlags , sparksSampled :: Bool -- ^ trace spark events by a sampled method , sparksFull :: Bool -- ^ trace spark events 100% accurately , user :: Bool -- ^ trace user events (emitted from Haskell code) + , traceIpe :: Bool -- ^ trace IPE events } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -588,6 +590,8 @@ getDebugFlags = do (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool)) <*> (toBool <$> (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, ipe} ptr :: IO CBool)) getCCFlags :: IO CCFlags getCCFlags = do @@ -647,6 +651,8 @@ getTraceFlags = do (#{peek TRACE_FLAGS, sparks_full} ptr :: IO CBool)) <*> (toBool <$> (#{peek TRACE_FLAGS, user} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, ipe} ptr :: IO CBool)) #endif getTickyFlags :: IO TickyFlags ===================================== rts/IPE.c ===================================== @@ -165,26 +165,46 @@ static void traceIPEFromHashTable(void *data STG_UNUSED, StgWord key STG_UNUSED, } void dumpIPEToEventLog(void) { - // Dump pending entries - IpeBufferListNode *node = RELAXED_LOAD(&ipeBufferList); - while (node != NULL) { - if (ipe_node_valid(node)){ - decompressIPEBufferListNodeIfCompressed(node); - - for (uint32_t i = 0; i < node->count; i++) { - const InfoProvEnt ent = ipeBufferEntryToIpe(node, i); - traceIPE(&ent); - } + /* + Usually, traceX functions are defined as a pair of a traceX_ function that + traces unconditionally and a traceX functional macro that performs the test + for the relevant TRACE_x flag. + + This function is the only function that calls traceIPE, but it takes a lot + of work just to prepare the IPE information. If traceIPE does not trace that + IPE information, all that work is wasted. Hence, the test of TRACE_ipe is + performed in this function instead. + + This function is called via traceInitEvent in RtsStartup.c, which registers + it as an init event handler. It is important that this happens regardless + of whether or not IPE tracing is enabled at startup, since IPE tracing can + be started/stopped at runtime using the dynamic trace flags API. + + IPE tracing is enabled whenever IPE debug printing is enabled via -DI, so + this test does not prevent IPE debug printing. + */ + if (RTS_UNLIKELY(TRACE_ipe)) { + // Dump pending entries + IpeBufferListNode *node = RELAXED_LOAD(&ipeBufferList); + while (node != NULL) { + if (ipe_node_valid(node)){ + decompressIPEBufferListNodeIfCompressed(node); + + for (uint32_t i = 0; i < node->count; i++) { + const InfoProvEnt ent = ipeBufferEntryToIpe(node, i); + traceIPE(&ent); + } + } + node = node->next; } - node = node->next; - } - // Dump entries already in hashmap - ACQUIRE_LOCK(&ipeMapLock); - if (ipeMap != NULL) { - mapHashTable(ipeMap, NULL, &traceIPEFromHashTable); + // Dump entries already in hashmap + ACQUIRE_LOCK(&ipeMapLock); + if (ipeMap != NULL) { + mapHashTable(ipeMap, NULL, &traceIPEFromHashTable); + } + RELEASE_LOCK(&ipeMapLock); } - RELEASE_LOCK(&ipeMapLock); } ===================================== rts/RtsFlags.c ===================================== @@ -249,6 +249,7 @@ void initRtsFlagsDefaults(void) RtsFlags.TraceFlags.sparks_sampled= false; RtsFlags.TraceFlags.sparks_full = false; RtsFlags.TraceFlags.user = false; + RtsFlags.TraceFlags.ipe = false; RtsFlags.TraceFlags.ticky = false; RtsFlags.TraceFlags.trace_output = NULL; # if defined(THREADED_RTS) @@ -449,6 +450,7 @@ usage_text[] = { " p par spark events (sampled)", " f par spark events (full detail)", " u user events (emitted from Haskell code)", +" I IPE events", #if defined(TICKY_TICKY) " T ticky-ticky counter samples", #endif @@ -457,7 +459,7 @@ usage_text[] = { " t add time stamps (only useful with -v)", # endif " -x disable an event class, for any flag above", -" the initial enabled event classes are 'sgpu'", +" the initial enabled event classes are 'sgIpu'", # if defined(THREADED_RTS) " --eventlog-flush-interval=<secs>", " Periodically flush the eventlog at the specified interval.", @@ -2528,6 +2530,7 @@ static void read_trace_flags(const char *arg) RtsFlags.TraceFlags.gc = true; RtsFlags.TraceFlags.sparks_sampled = true; RtsFlags.TraceFlags.user = true; + RtsFlags.TraceFlags.ipe = true; for (c = arg; *c != '\0'; c++) { switch(*c) { @@ -2541,8 +2544,9 @@ static void read_trace_flags(const char *arg) RtsFlags.TraceFlags.gc = enabled; RtsFlags.TraceFlags.sparks_sampled = enabled; RtsFlags.TraceFlags.sparks_full = enabled; - RtsFlags.TraceFlags.user = enabled; RtsFlags.TraceFlags.nonmoving_gc = enabled; + RtsFlags.TraceFlags.user = enabled; + RtsFlags.TraceFlags.ipe = enabled; #if defined(TICKY_TICKY) RtsFlags.TraceFlags.ticky = enabled; #endif @@ -2577,6 +2581,10 @@ static void read_trace_flags(const char *arg) RtsFlags.TraceFlags.user = enabled; enabled = true; break; + case 'I': + RtsFlags.TraceFlags.ipe = enabled; + enabled = true; + break; case 'T': #if defined(TICKY_TICKY) RtsFlags.TraceFlags.ticky = enabled; ===================================== rts/Trace.c ===================================== @@ -47,6 +47,8 @@ bool getTraceFlag(RUNTIME_TRACE_FLAG flag) { return RuntimeTraceFlagCache.user; case TRACE_CAP: return RuntimeTraceFlagCache.cap; + case TRACE_IPE: + return RuntimeTraceFlagCache.ipe; default: return false; } @@ -75,6 +77,9 @@ void setTraceFlag(RUNTIME_TRACE_FLAG flag, bool value) { case TRACE_CAP: RuntimeTraceFlagCache.cap = value; break; + case TRACE_IPE: + RuntimeTraceFlagCache.ipe = value; + break; } } @@ -119,13 +124,19 @@ static void updateTraceFlagCache(void) { RuntimeTraceFlagCache.user = RtsFlags.TraceFlags.user; + // -DI turns on IPE tracing too + RuntimeTraceFlagCache.ipe = + RtsFlags.TraceFlags.ipe || + RtsFlags.DebugFlags.ipe; + // We trace cap events if we're tracing anything else RuntimeTraceFlagCache.cap = TRACE_sched || TRACE_gc || TRACE_spark_sampled || TRACE_spark_full || - TRACE_user; + TRACE_user || + TRACE_ipe; } void initTracing (void) @@ -720,6 +731,7 @@ void traceHeapProfSampleString(const char *label, StgWord residency) } } +// The TRACE_ipe test happens in dumpIPEToEventLog. void traceIPE(const InfoProvEnt *ipe) { #if defined(DEBUG) ===================================== rts/Trace.h ===================================== @@ -79,6 +79,7 @@ enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM, #define TRACE_spark_full ((const bool)RuntimeTraceFlagCache.spark_full) #define TRACE_user ((const bool)RuntimeTraceFlagCache.user) #define TRACE_cap ((const bool)RuntimeTraceFlagCache.cap) +#define TRACE_ipe ((const bool)RuntimeTraceFlagCache.ipe) /* * Runtime trace flags. @@ -91,6 +92,7 @@ typedef struct { bool spark_full; bool user; bool cap; + bool ipe; } RUNTIME_TRACE_FLAG_CACHE; /* ===================================== rts/include/rts/EventLogWriter.h ===================================== @@ -90,6 +90,7 @@ typedef enum { TRACE_SPARK_FULL, TRACE_USER, TRACE_CAP, + TRACE_IPE, } RUNTIME_TRACE_FLAG; /* ===================================== rts/include/rts/Flags.h ===================================== @@ -191,6 +191,7 @@ 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) */ + bool ipe; /* trace IPE events */ #if defined(THREADED_RTS) /* Time between force eventlog flushes (or 0 if disabled) */ Time eventlogFlushTime; ===================================== testsuite/tests/rts/T25275/DebugIpe.hs ===================================== @@ -0,0 +1,6 @@ +module Main where + +import GHC.RTS.Flags.Experimental (DebugFlags (..), getDebugFlags) + +main :: IO () +main = print . ipe =<< getDebugFlags ===================================== testsuite/tests/rts/T25275/T25275_A.stdout ===================================== @@ -0,0 +1 @@ +False \ No newline at end of file ===================================== testsuite/tests/rts/T25275/T25275_B.stdout ===================================== @@ -0,0 +1 @@ +True \ No newline at end of file ===================================== testsuite/tests/rts/T25275/T25275_C.stdout ===================================== @@ -0,0 +1 @@ +False \ No newline at end of file ===================================== testsuite/tests/rts/T25275/T25275_D.stdout ===================================== @@ -0,0 +1 @@ +True \ No newline at end of file ===================================== testsuite/tests/rts/T25275/TraceIpe.hs ===================================== @@ -0,0 +1,6 @@ +module Main where + +import GHC.RTS.Flags.Experimental (TraceFlags (..), getTraceFlags) + +main :: IO () +main = print . traceIpe =<< getTraceFlags ===================================== testsuite/tests/rts/T25275/all.T ===================================== @@ -0,0 +1,43 @@ +# Compile and run with default RTS options +test( + 'T25275_A', + [ + extra_files(['TraceIpe.hs']), + ], + multimod_compile_and_run, + ['TraceIpe', ''], +) + +# Compile and run with -lI +test( + 'T25275_B', + [ + extra_files(['TraceIpe.hs']), + extra_run_opts('+RTS -lI -RTS'), + ], + multimod_compile_and_run, + ['TraceIpe', ''], +) + +# Compile and run with default RTS options +test( + 'T25275_C', + [ + only_ways(['debug']), + extra_files(['DebugIpe.hs']), + ], + multimod_compile_and_run, + ['DebugIpe', ''], +) + +# Compile and run with -DI +test( + 'T25275_D', + [ + only_ways(['debug']), + extra_files(['DebugIpe.hs']), + extra_run_opts('+RTS -DI -RTS'), + ], + multimod_compile_and_run, + ['DebugIpe', ''], +) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5fa202dc32db37bd27bae5cab16472… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5fa202dc32db37bd27bae5cab16472… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wenkokke/trace-ipe] 3 commits: testsuite: Add test for TraceFlags.traceIpe
by Wen Kokke (＠wenkokke) 14 May '26

14 May '26

Wen Kokke pushed to branch wip/wenkokke/trace-ipe at Glasgow Haskell Compiler / GHC Commits: 184ba494 by Wen Kokke at 2026-05-14T16:32:27+01:00 testsuite: Add test for TraceFlags.traceIpe - - - - - 10828fd1 by Wen Kokke at 2026-05-14T16:32:27+01:00 ghc-internal: Add ipe to DebugFlags - - - - - 5fa202dc by Wen Kokke at 2026-05-14T16:32:27+01:00 testsuite: Add test for DebugFlags.ipe - - - - - 8 changed files: - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - + testsuite/tests/rts/T25275/DebugIpe.hs - + testsuite/tests/rts/T25275/T25275_A.stdout - + testsuite/tests/rts/T25275/T25275_B.stdout - + testsuite/tests/rts/T25275/T25275_C.stdout - + testsuite/tests/rts/T25275/T25275_D.stdout - + testsuite/tests/rts/T25275/TraceIpe.hs - + testsuite/tests/rts/T25275/all.T Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc ===================================== @@ -211,6 +211,7 @@ data DebugFlags = DebugFlags , squeeze :: Bool -- ^ @z@ stack squeezing & lazy blackholing , hpc :: Bool -- ^ @c@ coverage , sparks :: Bool -- ^ @r@ + , ipe :: Bool -- ^ @I@ } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -589,6 +590,8 @@ getDebugFlags = do (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool)) <*> (toBool <$> (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, ipe} ptr :: IO CBool)) getCCFlags :: IO CCFlags getCCFlags = do ===================================== testsuite/tests/rts/T25275/DebugIpe.hs ===================================== @@ -0,0 +1,6 @@ +module Main where + +import GHC.RTS.Flags.Experimental (DebugFlags (..), getDebugFlags) + +main :: IO () +main = print . ipe =<< getDebugFlags ===================================== testsuite/tests/rts/T25275/T25275_A.stdout ===================================== @@ -0,0 +1 @@ +False \ No newline at end of file ===================================== testsuite/tests/rts/T25275/T25275_B.stdout ===================================== @@ -0,0 +1 @@ +True \ No newline at end of file ===================================== testsuite/tests/rts/T25275/T25275_C.stdout ===================================== @@ -0,0 +1 @@ +False \ No newline at end of file ===================================== testsuite/tests/rts/T25275/T25275_D.stdout ===================================== @@ -0,0 +1 @@ +True \ No newline at end of file ===================================== testsuite/tests/rts/T25275/TraceIpe.hs ===================================== @@ -0,0 +1,6 @@ +module Main where + +import GHC.RTS.Flags.Experimental (TraceFlags (..), getTraceFlags) + +main :: IO () +main = print . traceIpe =<< getTraceFlags ===================================== testsuite/tests/rts/T25275/all.T ===================================== @@ -0,0 +1,43 @@ +# Compile and run with default RTS options +test( + 'T25275_A', + [ + extra_files(['TraceIpe.hs']), + ], + multimod_compile_and_run, + ['TraceIpe', ''], +) + +# Compile and run with -lI +test( + 'T25275_B', + [ + extra_files(['TraceIpe.hs']), + extra_run_opts('+RTS -lI -RTS'), + ], + multimod_compile_and_run, + ['TraceIpe', ''], +) + +# Compile and run with default RTS options +test( + 'T25275_C', + [ + only_ways(['debug']), + extra_files(['DebugIpe.hs']), + ], + multimod_compile_and_run, + ['DebugIpe', ''], +) + +# Compile and run with -DI +test( + 'T25275_D', + [ + only_ways(['debug']), + extra_files(['DebugIpe.hs']), + extra_run_opts('+RTS -DI -RTS'), + ], + multimod_compile_and_run, + ['DebugIpe', ''], +) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4e1129245363db2fcacfe22d45408… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4e1129245363db2fcacfe22d45408… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] rts: Align stack to 64-byte boundary in StgRun on x86
by Magnus (＠MangoIV) 14 May '26

14 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 9f20f0e9 by ARATA Mizuki at 2026-05-14T17:08:40+02:00 rts: Align stack to 64-byte boundary in StgRun on x86 When LLVM spills AVX/AVX-512 vector registers to the stack, it requires 32-byte (__m256) or 64-byte (__m512) alignment. If the stack is not sufficiently aligned, LLVM inserts a realignment prologue that reserves %rbp as a frame pointer, conflicting with GHC's use of %rbp as an STG callee-saved register and breaking the tail-call-based calling convention. Previously, GHC worked around this by lying to LLVM about the stack alignment and rewriting aligned vector loads/stores (VMOVDQA, VMOVAPS) to unaligned ones (VMOVDQU, VMOVUPS) in the LLVM Mangler. This had two problems: - It did not extend to AVX-512, which requires 64-byte alignment. (#26595) - When Haskell calls a C function that takes __m256/__m512 arguments on the stack, the callee requires genuine alignment, which could cause a segfault. (#26822) This patch genuinely aligns the stack to 64 bytes in StgRun by saving the original stack pointer before alignment and restoring it in StgReturn. We now unconditionally advertise 64-byte stack alignment to LLVM for all x86 targets, making rewriteAVX in the LLVM Mangler unnecessary. STG_RUN_STACK_FRAME_SIZE is increased from 48 to 56 bytes on non-Windows x86-64 to store the saved stack pointer. Closes #26595 and #26822 Co-Authored-By: Claude Opus 4.5 <noreply(a)anthropic.com> (cherry picked from commit a5ec467ee3d4e77c026437a545981269acde3434) - - - - - 13 changed files: - compiler/GHC/CmmToLlvm.hs - compiler/GHC/CmmToLlvm/Config.hs - compiler/GHC/CmmToLlvm/Mangler.hs - compiler/GHC/Driver/Config/CmmToLlvm.hs - rts/StgCRun.c - rts/include/rts/Constants.h - + testsuite/tests/simd/should_run/StackAlignment32.hs - + testsuite/tests/simd/should_run/StackAlignment32.stdout - + testsuite/tests/simd/should_run/StackAlignment32_main.c - + testsuite/tests/simd/should_run/StackAlignment64.hs - + testsuite/tests/simd/should_run/StackAlignment64.stdout - + testsuite/tests/simd/should_run/StackAlignment64_main.c - testsuite/tests/simd/should_run/all.T Changes: ===================================== compiler/GHC/CmmToLlvm.hs ===================================== @@ -217,11 +217,15 @@ cmmMetaLlvmPrelude = do Nothing -> [ MetaStr name ] platform <- getPlatform - cfg <- getConfig let stack_alignment_metas = case platformArch platform of - ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32] - _ -> [] + -- LLVM inserts stack realignment prologue/epilogue when it wants to place __m256 or __m512 on the stack. + -- However, it reserves %rbp as the frame pointer, conflicting with our use of it. + -- Therefore, we tell LLVM that the stack is already aligned to avoid stack realignment. + -- See also Note [Stack Alignment on X86] and https://gitlab.haskell.org/ghc/ghc/-/issues/26595. + ArchX86 -> [mkStackAlignmentMeta 64] + ArchX86_64 -> [mkStackAlignmentMeta 64] + _ -> [] let codel_model_metas = case platformArch platform of -- FIXME: We should not rely on LLVM ===================================== compiler/GHC/CmmToLlvm/Config.hs ===================================== @@ -22,7 +22,6 @@ data LlvmCgConfig = LlvmCgConfig , llvmCgContext :: !SDocContext -- ^ Context for LLVM code generation , llvmCgFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values , llvmCgSplitSection :: !Bool -- ^ Split sections - , llvmCgAvxEnabled :: !Bool , llvmCgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions , llvmCgLlvmVersion :: Maybe LlvmVersion -- ^ version of Llvm we're using , llvmCgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version ===================================== compiler/GHC/CmmToLlvm/Mangler.hs ===================================== @@ -38,7 +38,7 @@ llvmFixupAsm platform f1 f2 = {-# SCC "llvm_mangler" #-} -- | These are the rewrites that the mangler will perform rewrites :: [Rewrite] -rewrites = [rewriteSymType, rewriteAVX, rewriteCall, rewriteJump] +rewrites = [rewriteSymType, rewriteCall, rewriteJump] type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString @@ -85,23 +85,6 @@ rewriteSymType _ l funcType = prefix `B.cons` B.pack "function" objType = prefix `B.cons` B.pack "object" --- | This rewrites aligned AVX instructions to their unaligned counterparts on --- x86-64. This is necessary because the stack is not adequately aligned for --- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer --- and disable tail call optimization. Both would be catastrophic here so GHC --- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then --- rewrites the instructions in the mangler. -rewriteAVX :: Rewrite -rewriteAVX platform s - | not isX86_64 = Nothing - | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s - | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s - | otherwise = Nothing - where - isX86_64 = platformArch platform == ArchX86_64 - isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") - isVmovap = B.isPrefixOf (B.pack "vmovap") - -- | This rewrites (tail) calls to avoid creating PLT entries for -- functions on riscv64. The replacement will load the address from the -- GOT, which is resolved to point to the real address of the function. ===================================== compiler/GHC/Driver/Config/CmmToLlvm.hs ===================================== @@ -23,7 +23,6 @@ initLlvmCgConfig logger config_cache dflags = do , llvmCgContext = initSDocContext dflags PprCode , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags , llvmCgSplitSection = gopt Opt_SplitSections dflags - , llvmCgAvxEnabled = isAvxEnabled dflags , llvmCgBmiVersion = case platformArch (targetPlatform dflags) of ArchX86_64 -> bmiVersion dflags ArchX86 -> bmiVersion dflags ===================================== rts/StgCRun.c ===================================== @@ -108,19 +108,24 @@ StgFunPtr StgReturn(void) /* * Note [Stack Alignment on X86] * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * On X86 (both 32bit and 64bit) we keep the stack aligned on function calls at - * a 16-byte boundary. This is done because on a number of architectures the - * ABI requires this (e.g. the System V AMD64 ABI, Mac OS X 32-bit/64-bit ABIs, - * and the Win64 ABI) as well as interfacing with * other libraries through the - * FFI. + * On X86, we keep the stack aligned on function calls. We use 64-byte alignment + * because it is required for passing AVX-512 vector types (__m512 and friends) + * as arguments. See #26822 for a problem caused by insufficient stack alignment. * - * As part of this arrangement we must maintain the stack at a 16-byte boundary - * - word_size-bytes (so 16n - 4 for i386 and 16n - 8 for x64) on entry to a - * procedure since both GCC and LLVM expect this. This is because the stack - * should have been 16-byte boundary aligned and then a call made which pushes - * a return address onto the stack (so word_size more space used). In STG code - * we only jump to other STG procedures, so we maintain the 16n - word_size - * alignment for these jumps. + * Strictly speaking, we only need 16-byte alignment when we do not use AVX or + * AVX-512, but dispatching based on the available ISA extensions would + * complicate things. Always using 64-byte alignment is simpler. + * + * However, the C ABI only requires 16-byte alignment, which is just sufficient + * for SSE2 vectors. Therefore, we dynamically align the stack with + * `and{l,q} $-64`, and save the original stack pointer. + * + * On entry to a procedure, we must maintain the stack at a 64-byte boundary + * - word_size-bytes (so 64n - 4 for i386 and 64n - 8 for x64) since both GCC + * and LLVM expect this. This is because the stack should have been aligned to + * a 64-byte boundary, and then a call made which pushes a return address onto + * the stack (so word_size more space used). In STG code we only jump to other + * STG procedures, so we maintain the 64n - word_size alignment for these jumps. * * This gives us binary compatibility with LLVM and GCC as well as dealing * with the FFI. Previously we just maintained a 16n byte alignment for @@ -157,51 +162,84 @@ StgFunPtr StgReturn(void) * Concretely this means we must always keep the stack valid. * */ +/* Stack layout on x86-32: + +-----------------------------+ <------ esp + | 4-byte padding | + |-----------------------------| <------ esp + 4 (64-byte aligned) + | | + | RESERVED_C_STACK_BYTES ~16k | + | | + |-----------------------------| <------ 64-byte aligned + | ebx | + |-----------------------------| + | esi | + |-----------------------------| + | edi | + |-----------------------------| + | ebp | + |-----------------------------| + | saved esp |----+ + |-----------------------------| | + | (padding for alignment) | | + |-----------------------------| <--+ + | eip saved by call StgRun | + | in schedule() | + +-----------------------------+ + | the function pointer | + +-----------------------------+ + | BaseReg | + +-----------------------------+ + ... + schedule() stack frame + + Lower addresses on the top + */ + +#if RESERVED_C_STACK_BYTES % 64 != 0 +#error "RESERVED_C_STACK_BYTES must be a multiple of 64. If you are changing it, please make sure %esp+4 is a multiple of 64" +#endif static void STG_USED StgRunIsImplementedInAssembler(void) { __asm__ volatile ( STG_GLOBAL STG_RUN "\n" -#if !defined(mingw32_HOST_OS) STG_HIDDEN STG_RUN "\n" -#endif STG_RUN ":\n\t" /* * move %esp down to reserve an area for temporary storage * during the execution of STG code. * - * The stack pointer has to be aligned to a multiple of 16 - * bytes from here - this is a requirement of the C ABI, so - * that C code can assign SSE2 registers directly to/from - * stack locations. - * - * See Note [Windows Stack allocations] + * We want the stack pointer to be aligned to a multiple of 64 + * bytes from here - this is a requirement of the C ABI for + * AVX-512, so that C code can assign ZMM registers directly + * to/from stack locations. */ -#if defined(mingw32_HOST_OS) - "movl %0, %%eax\n\t" - "call ___chkstk_ms\n\t" -#endif - "subl %0, %%esp\n\t" + /* We no longer support i386 Windows, so no need to call __chkstk_ms */ + + /* Save the original esp in eax */ + "movl %%esp, %%eax\n\t" + "subl $20, %%esp\n\t" /* area to save 5 registers */ + "andl $-64, %%esp\n\t" /* * save callee-saves registers on behalf of the STG code. */ - "movl %%esp, %%eax\n\t" - "addl %0-16, %%eax\n\t" - "movl %%ebx,0(%%eax)\n\t" - "movl %%esi,4(%%eax)\n\t" - "movl %%edi,8(%%eax)\n\t" - "movl %%ebp,12(%%eax)\n\t" + "movl %%ebx, 0(%%esp)\n\t" + "movl %%esi, 4(%%esp)\n\t" + "movl %%edi, 8(%%esp)\n\t" + "movl %%ebp, 12(%%esp)\n\t" + "movl %%eax, 16(%%esp)\n\t" + "subl %0, %%esp\n\t" /* * Set BaseReg */ - "movl 24(%%eax),%%ebx\n\t" + "movl 8(%%eax),%%ebx\n\t" /* * grab the function argument from the stack */ - "movl 20(%%eax),%%eax\n\t" + "movl 4(%%eax),%%eax\n\t" /* * jump to it */ @@ -216,17 +254,16 @@ StgRunIsImplementedInAssembler(void) * restore callee-saves registers. (Don't stomp on %%eax!) */ "movl %%esp, %%edx\n\t" - "addl %0-16, %%edx\n\t" + "addl %0, %%edx\n\t" "movl 0(%%edx),%%ebx\n\t" /* restore the registers saved above */ "movl 4(%%edx),%%esi\n\t" "movl 8(%%edx),%%edi\n\t" "movl 12(%%edx),%%ebp\n\t" - - "addl %0, %%esp\n\t" + "movl 16(%%edx),%%esp\n\t" "ret" - : : "i" (RESERVED_C_STACK_BYTES + 16) - // + 16 to make room for the 4 registers we have to save + : : "i" (RESERVED_C_STACK_BYTES + 4) + // + 4 to mimic `calll` // See Note [Stack Alignment on X86] ); } @@ -302,10 +339,12 @@ is as follows: C STACK "ADDRESS SPACE" | v +-----------------------------+ <------ rsp + | 8-byte padding | + |-----------------------------| <------ rsp + 8 (64-byte aligned) | | | RESERVED_C_STACK_BYTES ~16k | | | - |-----------------------------| + |-----------------------------| <------ 64-byte aligned | rbx || |-----------------------------| \ | rbp | | @@ -315,9 +354,13 @@ is as follows: | r13 | | STG_RUN_STACK_FRAME_SIZE |-----------------------------| / | r14 | | - |-----------------------------| / - | r15 | | - |-----------------------------|/ + |-----------------------------| | + | r15 | / + |-----------------------------| | + | saved rsp |-+--- + |-----------------------------|/ | + | (padding for alignment) | | + |-----------------------------| <--- | rip saved by call StgRun | | in schedule() | +-----------------------------+ @@ -367,6 +410,10 @@ stack unwinding. */ +#if RESERVED_C_STACK_BYTES % 64 != 0 +#error "RESERVED_C_STACK_BYTES must be a multiple of 64. If you are changing it, please make sure %rsp+8 is a multiple of 64" +#endif + static void STG_USED StgRunIsImplementedInAssembler(void) { @@ -385,9 +432,22 @@ StgRunIsImplementedInAssembler(void) #if defined(mingw32_HOST_OS) "movq %1, %%rax\n\t" "addq %0, %%rax\n\t" + "addq $63, %%rax\n\t" /* extra space for 64-byte alignment */ "callq ___chkstk_ms\n\t" #endif + /* + * Save the original rsp in r11 (caller-saved, so we don't need to + * preserve it across calls). We need this to restore rsp after + * the 64-byte alignment. + */ + "movq %%rsp, %%r11\n\t" + /* + * Allocate space for saved registers, then align to 64-byte boundary. + * The alignment is required for AVX-512 instructions. + * See Note [Stack Alignment on X86]. + */ "subq %1, %%rsp\n\t" + "andq $-64, %%rsp\n\t" "movq %%rsp, %%rax\n\t" "subq %0, %%rsp\n\t" "movq %%rbx,0(%%rax)\n\t" @@ -396,6 +456,7 @@ StgRunIsImplementedInAssembler(void) "movq %%r13,24(%%rax)\n\t" "movq %%r14,32(%%rax)\n\t" "movq %%r15,40(%%rax)\n\t" + "movq %%r11,48(%%rax)\n\t" /* save original rsp */ #if defined(mingw32_HOST_OS) /* * Additional callee saved registers on Win64. This must match @@ -403,25 +464,35 @@ StgRunIsImplementedInAssembler(void) * both represent the Win64 calling convention. * * Note that we must save the entire 128-bit width of the XMM - * registers, as noted in #21465. Moreover, note that, due to the - * presence of the return address on the stack, %rsp+8 is - * 16-byte aligned. Since MOVAPS requires memory operands to be aligned - * to 16-bytes, we must add a word of padding here. + * registers, as noted in #21465. Since we align the stack to + * 64 bytes, MOVAPS alignment requirements are satisfied. + * + * The Win64 calling convention says the upper YMM/ZMM parts are + * volatile, so we do not need to save them. See Microsoft Learn + * for the description of the calling convention: + * https://learn.microsoft.com/en-us/cpp/build/x64-calling-convention?view=msv… + * + * Layout (offsets from rax): + * 0-47: rbx, rbp, r12, r13, r14, r15 + * 48: original rsp + * 56: rdi + * 64: rsi + * 72: padding for 16-byte alignment of XMM registers + * 80-239: xmm6-xmm15 (10 * 16 bytes) */ - "movq %%rdi, 48(%%rax)\n\t" - "movq %%rsi, 56(%%rax)\n\t" - /* 8 bytes of padding for alignment */ - "movaps %%xmm6, 72(%%rax)\n\t" - "movaps %%xmm7, 88(%%rax)\n\t" - "movaps %%xmm8, 104(%%rax)\n\t" - "movaps %%xmm9, 120(%%rax)\n\t" - "movaps %%xmm10,136(%%rax)\n\t" - "movaps %%xmm11,152(%%rax)\n\t" - "movaps %%xmm12,168(%%rax)\n\t" - "movaps %%xmm13,184(%%rax)\n\t" - "movaps %%xmm14,200(%%rax)\n\t" - "movaps %%xmm15,216(%%rax)\n\t" + "movq %%rdi, 56(%%rax)\n\t" + "movq %%rsi, 64(%%rax)\n\t" /* 8 bytes of padding for alignment */ + "movaps %%xmm6, 80(%%rax)\n\t" + "movaps %%xmm7, 96(%%rax)\n\t" + "movaps %%xmm8, 112(%%rax)\n\t" + "movaps %%xmm9, 128(%%rax)\n\t" + "movaps %%xmm10,144(%%rax)\n\t" + "movaps %%xmm11,160(%%rax)\n\t" + "movaps %%xmm12,176(%%rax)\n\t" + "movaps %%xmm13,192(%%rax)\n\t" + "movaps %%xmm14,208(%%rax)\n\t" + "movaps %%xmm15,224(%%rax)\n\t" #endif #if defined(ENABLE_UNWINDING) @@ -431,6 +502,11 @@ StgRunIsImplementedInAssembler(void) * * N.B. We don't support unwinding on Darwin due to * various toolchain insanity. + * + * Note: Due to dynamic 64-byte alignment, the exact stack offset + * varies at runtime. The original rsp is saved at offset 48 in the + * register save area. We use a DWARF expression to compute the + * CFA from the saved rsp value. */ ".cfi_def_cfa rsp, 0\n\t" ".cfi_offset rbx, %c2\n\t" @@ -439,30 +515,69 @@ StgRunIsImplementedInAssembler(void) ".cfi_offset r13, %c5\n\t" ".cfi_offset r14, %c6\n\t" ".cfi_offset r15, %c7\n\t" - ".cfi_offset rip, %c8\n\t" - ".cfi_escape " // DW_CFA_val_expression is not expressible otherwise - "0x16, " // DW_CFA_val_expression - "0x07, " // register num 7 - rsp - "0x04, " // block length - "0x77, " // DW_OP_breg7 - signed LEB128 offset from rsp -#define RSP_DELTA (RESERVED_C_STACK_BYTES + STG_RUN_STACK_FRAME_SIZE + 8) - "%c9" // signed LEB128 encoded delta - byte 1 -#if (RSP_DELTA >> 7) > 0 - ", %c10" // signed LEB128 encoded delta - byte 2 + /* + * The original rsp is saved at RESERVED_C_STACK_BYTES + 56 from + * current rsp. We use DW_CFA_expression to indicate that rsp's + * value can be found by loading from that stack location. + */ +#define RSP_DELTA (RESERVED_C_STACK_BYTES + 56) + ".cfi_escape " + "0x10, " // DW_CFA_expression + "0x07, " // register num 7 - rsp +#if (RSP_DELTA >> 20) > 0 + "0x05, " // block length = 5 +#elif (RSP_DELTA >> 13) > 0 + "0x04, " // block length = 4 +#elif (RSP_DELTA >> 6) > 0 + "0x03, " // block length = 3 +#else + "0x02, " // block length = 2 #endif - -#if (RSP_DELTA >> 14) > 0 - ", %c11" // signed LEB128 encoded delta - byte 3 + "0x77, " // DW_OP_breg7 (rsp + offset) + "%c8" // signed LEB128 offset to saved rsp (RESERVED_C_STACK_BYTES + 56) +#if (RSP_DELTA >> 6) > 0 + ", %c9" // signed LEB128 encoded delta - byte 2 #endif - -#if (RSP_DELTA >> 21) > 0 - ", %c12" // signed LEB128 encoded delta - byte 4 +#if (RSP_DELTA >> 13) > 0 + ", %c10" // signed LEB128 encoded delta - byte 3 #endif - -#if (RSP_DELTA >> 28) > 0 +#if (RSP_DELTA >> 20) > 0 + ", %c11" // signed LEB128 encoded delta - byte 4 +#endif +#if (RSP_DELTA >> 27) > 0 #error "RSP_DELTA too big" #endif "\n\t" + /* + * The return address (rip) is at the original rsp location. + * Since original rsp is saved at offset 48 in register save area, + * rip = *saved_rsp = **(rsp + 8 + RESERVED_C_STACK_BYTES + 48). + */ + ".cfi_escape " + "0x10, " // DW_CFA_expression + "0x10, " // register num 16 - rip +#if (RSP_DELTA >> 20) > 0 + "0x06, " // block length = 6 +#elif (RSP_DELTA >> 13) > 0 + "0x05, " // block length = 5 +#elif (RSP_DELTA >> 6) > 0 + "0x04, " // block length = 4 +#else + "0x03, " // block length = 3 +#endif + "0x77, " // DW_OP_breg7 (rsp + offset) + "%c8" // signed LEB128 offset to saved rsp +#if (RSP_DELTA >> 6) > 0 + ", %c9" // signed LEB128 encoded delta - byte 2 +#endif +#if (RSP_DELTA >> 13) > 0 + ", %c10" // signed LEB128 encoded delta - byte 3 +#endif +#if (RSP_DELTA >> 20) > 0 + ", %c11" // signed LEB128 encoded delta - byte 4 +#endif + ", 0x06" // DW_OP_deref + "\n\t" #endif /* defined(ENABLE_UNWINDING) */ /* @@ -510,55 +625,50 @@ StgRunIsImplementedInAssembler(void) "movq 32(%%rsp),%%r14\n\t" "movq 40(%%rsp),%%r15\n\t" #if defined(mingw32_HOST_OS) - "movq 48(%%rsp),%%rdi\n\t" - "movq 56(%%rsp),%%rsi\n\t" + "movq 56(%%rsp),%%rdi\n\t" + "movq 64(%%rsp),%%rsi\n\t" /* 8 bytes of padding for alignment */ - "movaps 72(%%rsp),%%xmm6\n\t" - "movaps 88(%%rsp),%%xmm7\n\t" - "movaps 104(%%rsp),%%xmm8\n\t" - "movaps 120(%%rsp),%%xmm9\n\t" - "movaps 136(%%rsp),%%xmm10\n\t" - "movaps 152(%%rsp),%%xmm11\n\t" - "movaps 168(%%rsp),%%xmm12\n\t" - "movaps 184(%%rsp),%%xmm13\n\t" - "movaps 200(%%rsp),%%xmm14\n\t" - "movaps 216(%%rsp),%%xmm15\n\t" - /* 8 bytes of padding for alignment */ -#endif - "addq %1, %%rsp\n\t" + "movaps 80(%%rsp),%%xmm6\n\t" + "movaps 96(%%rsp),%%xmm7\n\t" + "movaps 112(%%rsp),%%xmm8\n\t" + "movaps 128(%%rsp),%%xmm9\n\t" + "movaps 144(%%rsp),%%xmm10\n\t" + "movaps 160(%%rsp),%%xmm11\n\t" + "movaps 176(%%rsp),%%xmm12\n\t" + "movaps 192(%%rsp),%%xmm13\n\t" + "movaps 208(%%rsp),%%xmm14\n\t" + "movaps 224(%%rsp),%%xmm15\n\t" +#endif + "movq 48(%%rsp),%%rsp\n\t" /* restore original rsp */ "retq" : - : "i"(RESERVED_C_STACK_BYTES), + : "i"(RESERVED_C_STACK_BYTES + 8), "i"(STG_RUN_STACK_FRAME_SIZE /* stack frame size */), - "i"(RESERVED_C_STACK_BYTES /* rbx relative to cfa (rsp) */), - "i"(RESERVED_C_STACK_BYTES + 8 /* rbp relative to cfa (rsp) */), - "i"(RESERVED_C_STACK_BYTES + 16 /* r12 relative to cfa (rsp) */), - "i"(RESERVED_C_STACK_BYTES + 24 /* r13 relative to cfa (rsp) */), - "i"(RESERVED_C_STACK_BYTES + 32 /* r14 relative to cfa (rsp) */), - "i"(RESERVED_C_STACK_BYTES + 40 /* r15 relative to cfa (rsp) */), - "i"(RESERVED_C_STACK_BYTES + STG_RUN_STACK_FRAME_SIZE - /* rip relative to cfa */) + "i"(RESERVED_C_STACK_BYTES + 8 /* rbx relative to cfa (rsp) */), + "i"(RESERVED_C_STACK_BYTES + 16 /* rbp relative to cfa (rsp) */), + "i"(RESERVED_C_STACK_BYTES + 24 /* r12 relative to cfa (rsp) */), + "i"(RESERVED_C_STACK_BYTES + 32 /* r13 relative to cfa (rsp) */), + "i"(RESERVED_C_STACK_BYTES + 40 /* r14 relative to cfa (rsp) */), + "i"(RESERVED_C_STACK_BYTES + 48 /* r15 relative to cfa (rsp) */) #if defined(ENABLE_UNWINDING) - , "i"((RSP_DELTA & 127) | (128 * ((RSP_DELTA >> 7) > 0))) + /* LEB128-encoded offset to saved rsp (RESERVED_C_STACK_BYTES + 56) */ + , "i"((RSP_DELTA & 127) | (128 * ((RSP_DELTA >> 6) > 0))) /* signed LEB128-encoded delta from rsp - byte 1 */ -#if (RSP_DELTA >> 7) > 0 - , "i"(((RSP_DELTA >> 7) & 127) | (128 * ((RSP_DELTA >> 14) > 0))) +#if (RSP_DELTA >> 6) > 0 + , "i"(((RSP_DELTA >> 7) & 127) | (128 * ((RSP_DELTA >> 13) > 0))) /* signed LEB128-encoded delta from rsp - byte 2 */ #endif - -#if (RSP_DELTA >> 14) > 0 - , "i"(((RSP_DELTA >> 14) & 127) | (128 * ((RSP_DELTA >> 21) > 0))) +#if (RSP_DELTA >> 13) > 0 + , "i"(((RSP_DELTA >> 14) & 127) | (128 * ((RSP_DELTA >> 20) > 0))) /* signed LEB128-encoded delta from rsp - byte 3 */ #endif - -#if (RSP_DELTA >> 21) > 0 - , "i"(((RSP_DELTA >> 21) & 127) | (128 * ((RSP_DELTA >> 28) > 0))) +#if (RSP_DELTA >> 20) > 0 + , "i"(((RSP_DELTA >> 21) & 127) | (128 * ((RSP_DELTA >> 27) > 0))) /* signed LEB128-encoded delta from rsp - byte 4 */ #endif #undef RSP_DELTA - #endif /* defined(ENABLE_UNWINDING) */ ); ===================================== rts/include/rts/Constants.h ===================================== @@ -117,16 +117,14 @@ How large is the stack frame saved by StgRun? world. Used in StgCRun.c. - The size has to be enough to save the registers (see StgCRun) - plus padding if the result is not 16 byte aligned. - See the Note [Stack Alignment on X86] in StgCRun.c for details. + The size has to be enough to save the registers (see StgCRun). -------------------------------------------------------------------------- */ #if defined(x86_64_HOST_ARCH) # if defined(mingw32_HOST_OS) # define STG_RUN_STACK_FRAME_SIZE 240 # else -# define STG_RUN_STACK_FRAME_SIZE 48 +# define STG_RUN_STACK_FRAME_SIZE 56 # endif #endif ===================================== testsuite/tests/simd/should_run/StackAlignment32.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, UnliftedFFITypes #-} +module StackAlignment32 where +import GHC.Exts + +foreign import ccall unsafe add10 :: DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4# -> DoubleX4# + +foo :: Double -> IO () +foo (D# x) = do + let a = broadcastDoubleX4# x + b = packDoubleX4# (# 1.0##, 2.0##, 3.0##, 4.0## #) + c = add10 a a a a a a a a a b + (# c0, c1, c2, c3 #) = unpackDoubleX4# c + print (D# c0, D# c1, D# c2, D# c3) + +foreign export ccall foo :: Double -> IO () ===================================== testsuite/tests/simd/should_run/StackAlignment32.stdout ===================================== @@ -0,0 +1,3 @@ +(1.1,2.1,3.1,4.1) +(2.1,3.1,4.1,5.1) +(3.2,4.2,5.2,6.2) ===================================== testsuite/tests/simd/should_run/StackAlignment32_main.c ===================================== @@ -0,0 +1,42 @@ +#include "HsFFI.h" +#include <immintrin.h> + +extern void foo(double x); + +__m256d add10(__m256d a0, __m256d a1, __m256d a2, __m256d a3, __m256d a4, __m256d a5, __m256d a6, __m256d a7, __m256d a8, __m256d a9) +{ + // Test whether the stack is 32-byte aligned. + // Under the System V ABI, the first eight parameters are passed in registers. + // Here, `a8` and `a9` are passed on the stack. + // We want the compiler to emit `vmovapd` so we can verify 32-byte stack alignment. + // We cannot use `_mm256_add_pd(a0, a9)` because the compiler may fuse the load and + // the addition and emit a `vaddpd m256` form, which permits an unaligned load of `a9`. + // Therefore, we ensure that both operands are read from the stack, + // so that at least one operand is loaded using `vmovapd`. + return _mm256_add_pd(a8, a9); +} + +__attribute__((noinline)) +void baz(void) +{ + // Make the stack pointer shift by 16 bytes on x86-64 + foo(2.2); +} + +__attribute__((noinline)) +void bar(void) +{ + // Make the stack pointer shift by 16 bytes on x86-64 + foo(1.1); + baz(); +} + +int main(int argc, char *argv[]) +{ + hs_init(&argc, &argv); + + foo(0.1); + bar(); + + hs_exit(); +} ===================================== testsuite/tests/simd/should_run/StackAlignment64.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, UnliftedFFITypes #-} +module StackAlignment64 where +import GHC.Exts + +foreign import ccall unsafe add10 :: DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8# -> DoubleX8# + +foo :: Double -> IO () +foo (D# x) = do + let a = broadcastDoubleX8# x + b = packDoubleX8# (# 1.0##, 2.0##, 3.0##, 4.0##, 5.0##, 6.0##, 7.0##, 8.0## #) + c = add10 a a a a a a a a a b + (# c0, c1, c2, c3, c4, c5, c6, c7 #) = unpackDoubleX8# c + print (D# c0, D# c1, D# c2, D# c3, D# c4, D# c5, D# c6, D# c7) + +foreign export ccall foo :: Double -> IO () ===================================== testsuite/tests/simd/should_run/StackAlignment64.stdout ===================================== @@ -0,0 +1,3 @@ +(1.1,2.1,3.1,4.1,5.1,6.1,7.1,8.1) +(2.1,3.1,4.1,5.1,6.1,7.1,8.1,9.1) +(3.2,4.2,5.2,6.2,7.2,8.2,9.2,10.2) ===================================== testsuite/tests/simd/should_run/StackAlignment64_main.c ===================================== @@ -0,0 +1,42 @@ +#include "HsFFI.h" +#include <immintrin.h> + +extern void foo(double x); + +__m512d add10(__m512d a0, __m512d a1, __m512d a2, __m512d a3, __m512d a4, __m512d a5, __m512d a6, __m512d a7, __m512d a8, __m512d a9) +{ + // Test whether the stack is 64-byte aligned. + // Under the System V ABI, the first eight parameters are passed in registers. + // Here, `a8` and `a9` are passed on the stack. + // We want the compiler to emit `vmovapd` so we can verify 64-byte stack alignment. + // We cannot use `_mm512_add_pd(a0, a9)` because the compiler may fuse the load and + // the addition and emit a `vaddpd m512` form, which permits an unaligned load of `a9`. + // Therefore, we ensure that both operands are read from the stack, + // so that at least one operand is loaded using `vmovapd`. + return _mm512_add_pd(a8, a9); +} + +__attribute__((noinline)) +void baz(void) +{ + // Make the stack pointer shift by 16 bytes on x86-64 + foo(2.2); +} + +__attribute__((noinline)) +void bar(void) +{ + // Make the stack pointer shift by 16 bytes on x86-64 + foo(1.1); + baz(); +} + +int main(int argc, char *argv[]) +{ + hs_init(&argc, &argv); + + foo(0.1); + bar(); + + hs_exit(); +} ===================================== testsuite/tests/simd/should_run/all.T ===================================== @@ -92,7 +92,7 @@ test('T26411b', [], compile_and_run, ['-O']) # Even if the CPU we run on doesn't support *executing* those tests we should try to # compile them. # Currently even for compilation we only support 256+ bit on x86 -only_V32_plus_compilation_support = unless(arch('x86_64'), skip) +only_V32_plus_compilation_support = unless(arch('x86_64') or arch('i386'), skip) test('T25062_V32' , [ extra_hc_opts('-mavx2') @@ -116,17 +116,37 @@ test('T25486', [], compile_and_run, ['']) test('T26410_ffi' , [ only_ways(llvm_ways) # SIMD NCG TODO: support 512-bit wide vectors - , unless(arch('x86_64') and have_cpu_feature('avx512f'), skip) + , unless(arch('x86_64') or arch('i386'), skip) , extra_hc_opts('-mavx512f -optc -mavx512f -optlc -mcpu=penryn') - , when(opsys('mingw32'), fragile(26595)) ] , compile_and_run if have_cpu_feature('avx512f') else compile , ['T26410_ffi_c.c']) test('T26410_prim' , [ only_ways(llvm_ways) # SIMD NCG TODO: support 512-bit wide vectors - , unless(arch('x86_64') and have_cpu_feature('avx512f'), skip) + , unless(arch('x86_64') or arch('i386'), skip) , extra_hc_opts('-mavx512f -optlc -mcpu=penryn') ] , compile_and_run if have_cpu_feature('avx512f') else compile , ['']) + +test('FloatConstant', [], compile_and_run, ['']) +test('IntConstant', [], compile_and_run, ['']) + +test('StackAlignment32' + , [ only_ways(llvm_ways) # SIMD NCG TODO: support 256-bit wide vectors + , unless(arch('x86_64') or arch('i386'), skip) + , extra_hc_opts("-mavx -optc -mavx -no-hs-main") + ] + , compile_and_run if have_cpu_feature('avx') else compile + , ['StackAlignment32_main.c'] + ) + +test('StackAlignment64' + , [ only_ways(llvm_ways) # SIMD NCG TODO: support 512-bit wide vectors + , unless(arch('x86_64') or arch('i386'), skip) + , extra_hc_opts("-mavx512f -optc -mavx512f -no-hs-main") + ] + , compile_and_run if have_cpu_feature('avx512f') else compile + , ['StackAlignment64_main.c'] + ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f20f0e9f5009557f9ef0c3268ef427… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f20f0e9f5009557f9ef0c3268ef427… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wenkokke/trace-ipe] 2 commits: ghc-internal: Add traceIPE to TraceFlags
by Wen Kokke (＠wenkokke) 14 May '26

14 May '26

Wen Kokke pushed to branch wip/wenkokke/trace-ipe at Glasgow Haskell Compiler / GHC Commits: 63d22d07 by Wen Kokke at 2026-05-14T15:36:46+01:00 ghc-internal: Add traceIPE to TraceFlags - - - - - c4e11292 by Wen Kokke at 2026-05-14T15:37:54+01:00 ghc-internal: Add ipe to DebugFlags - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc ===================================== @@ -211,6 +211,7 @@ data DebugFlags = DebugFlags , squeeze :: Bool -- ^ @z@ stack squeezing & lazy blackholing , hpc :: Bool -- ^ @c@ coverage , sparks :: Bool -- ^ @r@ + , ipe :: Bool -- ^ @I@ } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -359,6 +360,7 @@ data TraceFlags = TraceFlags , sparksSampled :: Bool -- ^ trace spark events by a sampled method , sparksFull :: Bool -- ^ trace spark events 100% accurately , user :: Bool -- ^ trace user events (emitted from Haskell code) + , traceIpe :: Bool -- ^ trace IPE events } deriving ( Show -- ^ @since base-4.8.0.0 , Generic -- ^ @since base-4.15.0.0 ) @@ -588,6 +590,8 @@ getDebugFlags = do (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool)) <*> (toBool <$> (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, ipe} ptr :: IO CBool)) getCCFlags :: IO CCFlags getCCFlags = do @@ -647,6 +651,8 @@ getTraceFlags = do (#{peek TRACE_FLAGS, sparks_full} ptr :: IO CBool)) <*> (toBool <$> (#{peek TRACE_FLAGS, user} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, ipe} ptr :: IO CBool)) #endif getTickyFlags :: IO TickyFlags View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f9e731963688e28f6eb129ce852bd3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f9e731963688e28f6eb129ce852bd3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] 4 commits: Configure: Fix check for --target support in stage0 CC
by Magnus (＠MangoIV) 14 May '26

14 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 46d50d5f by Andreas Klebinger at 2026-05-14T16:26:57+02:00 Configure: Fix check for --target support in stage0 CC The check FP_PROG_CC_LINKER_TARGET used $CC unconditionally to check for --target support. However this fails for the stage0 config where the C compiler used is not $CC but $CC_STAGE0. Since we already pass the compiler under test into the macro I simply changed it to use that instead. Fixes #26999 (cherry picked from commit 43638643adbe999de8d2288a40bdd15c602f6481) - - - - - 25b0b83a by Ian Duncan at 2026-05-14T16:27:32+02:00 AArch64: fix MOVK regUsageOfInstr to mark dst as both read and written MOVK (move with keep) modifies only a 16-bit slice of the destination register, so the destination is both read and written. The register allocator must know this to avoid clobbering live values. Update regUsageOfInstr to list the destination in both src and dst sets. No regression test: triggering the misallocation requires specific register pressure around a MOVK sequence, which is difficult to reliably provoke from Haskell source. (cherry picked from commit 2823b03966e495581f4695f07649c5885306b656) - - - - - 402e6861 by Zubin Duggal at 2026-05-14T16:33:28+02:00 compiler/ffi: Collapse void pointer chains in capi wrappers New gcc/clang treat -Wincompatible-pointer-types as an error by default. Since C only allows implicit conversion from void*, not void**, capi wrappers for functions taking e.g. abstract** would fail to compile when the Haskell type Ptr (Ptr Abstract) was naively translated to void**. Collapse nested void pointers to a single void* when the pointee type has no known C representation. Fixes #26852 (cherry picked from commit 80e2dd4f084eff9cc857b31daf9ea2e9e460c727) - - - - - ba9d5b97 by Zubin Duggal at 2026-05-14T16:34:02+02:00 hadrian: Don't include the package hash in the haddock directory Since GHC 9.8 and hash_unit_ids, haddock urls have looked like`ghc-9.10.3/doc/html/libraries/base-4.20.2.0-39f9/**/*.html` The inclusion of the hash makes it hard for downstream non-boot packages to properly link to these files, as the hash is not part of a standard cabal substitution. Since we only build one version of each package, we don't need the hash to disambiguate anything, we can just remove it. Fixes #26635 (cherry picked from commit 07267f79d91169f474cacc8bcd38d76a6e97887d) - - - - - 11 changed files: - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/HsToCore/Foreign/C.hs - hadrian/bindist/Makefile - hadrian/src/CommandLine.hs - hadrian/src/Context.hs - hadrian/src/Settings/Builders/Cabal.hs - m4/fp_prog_cc_linker_target.m4 - + testsuite/tests/ffi/should_compile/T26852.h - + testsuite/tests/ffi/should_compile/T26852.hs - + testsuite/tests/ffi/should_compile/T26852.stderr - testsuite/tests/ffi/should_compile/all.T Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/Instr.hs ===================================== @@ -114,7 +114,7 @@ regUsageOfInstr platform instr = case instr of LSL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) LSR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) MOV dst src -> usage (regOp src, regOp dst) - MOVK dst src -> usage (regOp src, regOp dst) + MOVK dst src -> usage (regOp src ++ regOp dst, regOp dst) MOVZ dst src -> usage (regOp src, regOp dst) MVN dst src -> usage (regOp src, regOp dst) ORR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) ===================================== compiler/GHC/HsToCore/Foreign/C.hs ===================================== @@ -328,37 +328,68 @@ dsFCall fn_id co fcall mDeclHeader = do toCName :: Id -> String toCName i = showSDocOneLine defaultSDocContext (pprCode (ppr (idName i))) +{- Note [Collapsing void pointer chains] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When translating Haskell types like (Ptr (Ptr Abstract)) to C types for capi +wrappers, where Abstract has no CType annotation, naively we would produce +"void**". This is problematic because in C, only void* has implicit conversion +to any pointer type. +Modern compilers (gcc, clang) treat -Wincompatible-pointer-types as an error +by default (#26852), causing compilation failures for capi wrappers. + +The fix is to collapse void pointer chains: whenever the inner type of a +Ptr/FunPtr resolves to void (i.e. the Haskell type has no known C +representation), we return void* instead of void**, void***, etc. +This works because void* implicitly converts to any pointer type in C. + +Examples: + Ptr Abstract => void* + Ptr (Ptr Abstract) => void* (used to be void**) + Ptr (Ptr (Ptr Abstract)) => void* + Ptr (Ptr CInt) => int** (CInt has CType "int", don't collapse) +-} + +-- | See Note [Collapsing void pointer chains] toCType :: Type -> (Maybe Header, SDoc) -toCType = f False - where f voidOK t - -- First, if we have (Ptr t) of (FunPtr t), then we need to +toCType t = case f False t of + (mh, _, cType) -> (mh, cType) + where + -- The Bool in the return type indicates whether the C type is + -- "void" due to an unknown Haskell type (True = void-based). + f :: Bool -> Type -> (Maybe Header, Bool, SDoc) + f voidOK t + -- First, if we have (Ptr t) or (FunPtr t), then we need to -- convert t to a C type and put a * after it. If we don't -- know a type for t, then "void" is fine, though. + -- If the inner type is void-based, we collapse the pointer + -- chain to just "void*". See Note [Collapsing void pointer chains]. | Just (ptr, [t']) <- splitTyConApp_maybe t , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] = case f True t' of - (mh, cType') -> - (mh, cType' <> char '*') + (mh, True, _) -> + (mh, True, text "void*") + (mh, False, cType') -> + (mh, False, cType' <> char '*') -- Otherwise, if we have a type constructor application, then -- see if there is a C type associated with that constructor. -- Note that we aren't looking through type synonyms or -- anything, as it may be the synonym that is annotated. | Just tycon <- tyConAppTyConPicky_maybe t - , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon - = (mHeader, ftext cType) + , Just (CType _ mHeader (_, cType)) <- tyConCType_maybe tycon + = (mHeader, False, ftext cType) -- If we don't know a C type for this type, then try looking -- through one layer of type synonym etc. | Just t' <- coreView t = f voidOK t' - -- Handle 'UnliftedFFITypes' argument + -- Handle 'UnliftedFFITypes' argument | Just tyCon <- tyConAppTyConPicky_maybe t , isPrimTyCon tyCon , Just cType <- ppPrimTyConStgType tyCon - = (Nothing, text cType) + = (Nothing, False, text cType) -- Otherwise we don't know the C type. If we are allowing -- void then return that; otherwise something has gone wrong. - | voidOK = (Nothing, text "void") + | voidOK = (Nothing, True, text "void") | otherwise = pprPanic "toCType" (ppr t) ===================================== hadrian/bindist/Makefile ===================================== @@ -252,7 +252,7 @@ update_package_db: install_bin install_lib $(INSTALL_DATA) mk/system-cxx-std-lib-1.0.conf "$(DESTDIR)$(ActualLibsDir)/package.conf.d" @echo "Updating the package DB" $(foreach p, $(PKG_CONFS),\ - $(call patchpackageconf,$(shell echo $(notdir $p) | sed 's/-[0-9.]*-[0-9a-zA-Z]*\.conf//g'),$(shell echo "$p" | sed 's:\0xxx\0: :g'),$(docdir),$(shell mk/relpath.sh "$(ActualLibsDir)" "$(docdir)"),$(shell echo $(notdir $p) | sed 's/.conf//g'))) + $(call patchpackageconf,$(shell echo $(notdir $p) | sed 's/-[0-9.]*-[0-9a-zA-Z]*\.conf//g'),$(shell echo "$p" | sed 's:\0xxx\0: :g'),$(docdir),$(shell mk/relpath.sh "$(ActualLibsDir)" "$(docdir)"),$(shell echo $(notdir $p) | sed 's/-[0-9a-zA-Z]*\.conf$$//'))) '$(DESTDIR)$(ActualBinsDir)/$(CrossCompilePrefix)ghc-pkg' --global-package-db "$(DESTDIR)$(ActualLibsDir)/package.conf.d" recache .PHONY: install_mingw ===================================== hadrian/src/CommandLine.hs ===================================== @@ -113,7 +113,7 @@ data DocArgs = DocArgs } deriving (Eq, Show) defaultDocArgs :: DocArgs -defaultDocArgs = DocArgs { docsBaseUrl = "../%pkgid%" } +defaultDocArgs = DocArgs { docsBaseUrl = "../%pkg%" } readConfigure :: Either String (CommandLineArgs -> CommandLineArgs) readConfigure = Left "hadrian --configure has been deprecated (see #20167). Please run ./boot; ./configure manually" ===================================== hadrian/src/Context.hs ===================================== @@ -128,7 +128,9 @@ pkgSetupConfigFile context = pkgSetupConfigDir context <&> (-/- "setup-config") pkgHaddockFile :: Context -> Action FilePath pkgHaddockFile Context {..} = do root <- buildRoot - version <- pkgUnitId stage package + -- We don't want to use the hash in the html documentation because it + -- makes it harder for non-boot packages to link to boot packages, see #26635 + version <- pkgSimpleIdentifier package return $ root -/- "doc/html/libraries" -/- version -/- pkgName package <.> "haddock" -- | Path to the registered ghc-pkg library file of a given 'Context', e.g.: ===================================== hadrian/src/Settings/Builders/Cabal.hs ===================================== @@ -85,6 +85,9 @@ commonCabalArgs :: Stage -> Args commonCabalArgs stage = do pkg <- getPackage package_id <- expr $ pkgUnitId stage pkg + -- We don't want to use the hash in the html documentation because it + -- makes it harder for non-boot packages to link to boot packages, see #26635 + package_simple_id <- expr $ pkgSimpleIdentifier pkg let prefix = "${pkgroot}" ++ (if windowsHost then "" else "/..") mconcat [ -- Don't strip libraries when cross compiling. -- TODO: We need to set @--with-strip=(stripCmdPath :: Action FilePath)@, @@ -112,7 +115,7 @@ commonCabalArgs stage = do -- -- This doesn't hold if we move the @doc@ folder anywhere else. , arg "--htmldir" - , arg $ "${pkgroot}/../../doc/html/libraries/" ++ package_id + , arg $ "${pkgroot}/../../doc/html/libraries/" ++ package_simple_id -- These trigger a need on each dependency, so every important to need -- them in parallel or it linearises the build of Ghc and GhcPkg ===================================== m4/fp_prog_cc_linker_target.m4 ===================================== @@ -8,7 +8,7 @@ # a linker AC_DEFUN([FP_PROG_CC_LINKER_TARGET], [ - AC_MSG_CHECKING([whether $CC used as a linker understands --target]) + AC_MSG_CHECKING([whether $1 used as a linker understands --target]) echo 'int foo() { return 0; }' > conftest1.c echo 'int main() { return 0; }' > conftest2.c @@ -20,7 +20,7 @@ AC_DEFUN([FP_PROG_CC_LINKER_TARGET], # See Note [Don't pass --target to emscripten toolchain] in GHC.Toolchain.Program CONF_CC_SUPPORTS_TARGET=NO AC_MSG_RESULT([no]) - elif "$CC" $$3 --target=$LlvmTarget -o conftest conftest1.o conftest2.o; + elif "$1" $$3 --target=$LlvmTarget -o conftest conftest1.o conftest2.o; then $3="--target=$LlvmTarget $$3" AC_MSG_RESULT([yes]) ===================================== testsuite/tests/ffi/should_compile/T26852.h ===================================== @@ -0,0 +1,7 @@ +typedef struct abstract abstract; + +void blah(abstract** x); +abstract** get_abstract(void); +abstract*** get_abstract3(void); +abstract* get_simple(void); +int** get_int_pp(void); ===================================== testsuite/tests/ffi/should_compile/T26852.hs ===================================== @@ -0,0 +1,22 @@ +{-# LANGUAGE CApiFFI #-} +module T26852 where + +import Foreign.Ptr +import Foreign.C.Types + +data Abstract + +foreign import capi "T26852.h blah" + c_blah :: Ptr (Ptr Abstract) -> IO () + +foreign import capi "T26852.h get_abstract" + c_get_abstract :: IO (Ptr (Ptr Abstract)) + +foreign import capi "T26852.h get_abstract3" + c_get_abstract3 :: IO (Ptr (Ptr (Ptr Abstract))) + +foreign import capi "T26852.h get_simple" + c_get_simple :: IO (Ptr Abstract) + +foreign import capi "T26852.h get_int_pp" + c_get_int_pp :: IO (Ptr (Ptr CInt)) ===================================== testsuite/tests/ffi/should_compile/T26852.stderr ===================================== @@ -0,0 +1,18 @@ + +==================== Foreign export header file ==================== + + + +==================== Foreign export stubs ==================== +#include "T26852.h" +int** ghczuwrapperZC0ZCmainZCT26852ZCgetzuintzupp(void) {return get_int_pp();} +#include "T26852.h" +void* ghczuwrapperZC1ZCmainZCT26852ZCgetzusimple(void) {return get_simple();} +#include "T26852.h" +void* ghczuwrapperZC2ZCmainZCT26852ZCgetzuabstract3(void) {return get_abstract3();} +#include "T26852.h" +void* ghczuwrapperZC3ZCmainZCT26852ZCgetzuabstract(void) {return get_abstract();} +#include "T26852.h" +void ghczuwrapperZC4ZCmainZCT26852ZCblah(void* a1) {blah(a1);} + + ===================================== testsuite/tests/ffi/should_compile/all.T ===================================== @@ -43,3 +43,4 @@ test('T22774', unless(js_arch() or arch('wasm32'), expect_fail), compile, ['']) test('T24034', normal, compile, ['']) test('T25255', normal, compile, ['-dppr-debug']) +test('T26852', [when(js_arch(), skip), filter_stdout_lines(r'.*ghczuwrapper.*')], compile, ['-ddump-foreign']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52c2ba8f55b6a862df6ff9fc5db5c8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52c2ba8f55b6a862df6ff9fc5db5c8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] 4 commits: Fix -dsuppress-uniques for free variables in demand signatures
by Magnus (＠MangoIV) 14 May '26

14 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 5b5aac16 by Simon Jakobi at 2026-05-14T16:19:04+02:00 Fix -dsuppress-uniques for free variables in demand signatures Before: Str=b{sXyZ->S} With this patch: Str=b{S} T13143.stderr is updated accordingly. Fixes #27106. (cherry picked from commit 5b82080a3f3dd476e198130218d4da729fb5334a) - - - - - 98f24314 by Matthew Pickering at 2026-05-14T16:19:58+02:00 rts: forward clone-stack messages after TSO migration MSG_CLONE_STACK assumed that the target TSO was still owned by the capability that received the message. This is not always true: the TSO can migrate before the inbox entry is handled. When that happened, handleCloneStackMessage could clone a live stack from the wrong capability and use the wrong capability for allocation and performTryPutMVar, leading to stack sanity failures such as checkStackFrame: weird activation record found on stack. Fix this by passing the current capability into handleCloneStackMessage, rechecking msg->tso->cap at handling time, and forwarding the message if the TSO has migrated. Once ownership matches, use the executing capability consistently for cloneStack, rts_apply, and performTryPutMVar. Fixes #27008 (cherry picked from commit 5b550754ca0153a705ec607407074fe5716c1f7e) - - - - - d903097d by Andreas Klebinger at 2026-05-14T16:20:44+02:00 Fix missing profiling header for origin_thunk frame. Fixes #27007 (cherry picked from commit 63ae8eb38c54eaba77949b048a3621a5f4ca76e3) - - - - - 52c2ba8f by Luite Stegeman at 2026-05-14T16:24:20+02:00 bytecode: Carefully SLIDE off the end of a stack chunk The SLIDE bytecode instruction was not checking for stack chunk boundaries and could corrupt the stack underflow frame, leading to crashes. We add a check to use safe writes if we cross the chunk boundary and also handle stack underflow if Sp is advanced past the underflow frame. fix #27001 (cherry picked from commit 72b20fc0ad4b6ad12c67f686af5cb42700656886) - - - - - 15 changed files: - compiler/GHC/Types/Demand.hs - rts/CloneStack.c - rts/CloneStack.h - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - + testsuite/tests/bytecode/T27001.hs - + testsuite/tests/bytecode/T27001.stdout - testsuite/tests/bytecode/all.T - testsuite/tests/dmdanal/should_compile/T13143.stderr - + testsuite/tests/dmdanal/should_compile/T27106.hs - + testsuite/tests/dmdanal/should_compile/T27106.stderr - testsuite/tests/dmdanal/should_compile/all.T - testsuite/tests/rts/all.T - + testsuite/tests/rts/cloneThreadStackMigrating.hs Changes: ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE PatternSynonyms #-} @@ -2844,7 +2845,10 @@ instance Outputable DmdEnv where = ppr div <> if null fv_elts then empty else braces (fsep (map pp_elt fv_elts)) where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + pp_elt (uniq, dmd) = + sdocOption sdocSuppressUniques $ \case + True -> ppr dmd + False -> ppr uniq <> text "->" <> ppr dmd fv_elts = nonDetUFMToList fvs -- It's OK to use nonDetUFMToList here because we only do it for -- pretty printing ===================================== rts/CloneStack.c ===================================== @@ -89,15 +89,31 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) { sendMessage(srcCapability, tso->cap, (Message *)msg); } -void handleCloneStackMessage(MessageCloneStack *msg){ - StgStack* newStackClosure = cloneStack(msg->tso->cap, msg->tso->stackobj); +// The cap argument is the capability which is handling the CloneStack message +void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg){ + // We must check that the current owner of the thread we want to clone the stack for + // is still this capability. + Capability *owner = RELAXED_LOAD(&msg->tso->cap); + if (owner != cap) { + // The target TSO may have migrated after the message was queued on the old + // capability. In that case we must forward the request to the current + // owner; otherwise we would race with another capability mutating the + // stack while we clone it. + sendMessage(cap, owner, (Message *)msg); + return; + } + + // At this point the executing capability owns the TSO, so it is the only + // capability that may safely inspect the live stack and the one whose + // allocator we must use for the cloned StgStack closure. + StgStack* newStackClosure = cloneStack(cap, msg->tso->stackobj); // Lift StackSnapshot# to StackSnapshot by applying it's constructor. // This is necessary because performTryPutMVar() puts the closure onto the // stack for evaluation and stacks can not be evaluated (entered). - HaskellObj result = rts_apply(msg->tso->cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure); + HaskellObj result = rts_apply(cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure); - bool putMVarWasSuccessful = performTryPutMVar(msg->tso->cap, msg->result, result); + bool putMVarWasSuccessful = performTryPutMVar(cap, msg->result, result); if(!putMVarWasSuccessful) { barf("Can't put stack cloning result into MVar."); ===================================== rts/CloneStack.h ===================================== @@ -19,7 +19,7 @@ StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack); #include "BeginPrivate.h" #if defined(THREADED_RTS) -void handleCloneStackMessage(MessageCloneStack *msg); +void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg); #endif #include "EndPrivate.h" ===================================== rts/Interpreter.c ===================================== @@ -179,6 +179,24 @@ tag functions as tag inference currently doesn't rely on those being properly ta #define WITHIN_CHUNK_BOUNDS_W(n, s) \ (RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame)))) +/* Note [Checking for underflow frames] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + We look at the stack slot at offset sizeof(StgUnderflowFrame) from + the start of the chunk to check if we're in the first check chunk. + Every non-first stack chunk has an underflow frame header at that offset. + + We really should change this check, since this stack slot in the first + chunk may not be the start of a stack frame and could in theory contain + an arbitrary value. + + In practice we're unlikely to have interpreted frames that low on the stack. + */ +#define IS_UNDERFLOW_FRAME(info) \ + ((info) == &stg_stack_underflow_frame_d_info || \ + (info) == &stg_stack_underflow_frame_v16_info || \ + (info) == &stg_stack_underflow_frame_v32_info || \ + (info) == &stg_stack_underflow_frame_v64_info) #define W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord))) @@ -431,11 +449,9 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ frame = (StgUnderflowFrame*)(cur_stack->stack + cur_stack->stack_size - sizeofW(StgUnderflowFrame)); - // 2a. Check it is an underflow frame (the top stack chunk won't have one). - if( frame->info == &stg_stack_underflow_frame_d_info - || frame->info == &stg_stack_underflow_frame_v16_info - || frame->info == &stg_stack_underflow_frame_v32_info - || frame->info == &stg_stack_underflow_frame_v64_info ) + // 2a. Check it is an underflow frame (the first stack chunk won't have one). + // See Note [Checking for underflow frames] + if( IS_UNDERFLOW_FRAME(frame->info) ) { INTERP_TICK(it_underflow_lookups); @@ -452,9 +468,11 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ } // 2b. Access the element if there is no underflow frame, it must be right // at the top of the stack. - else { - // Not actually in the underflow case + else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) { + // Still inside the stack chunk return Sp_plusW(offset_words); + } else { + barf("slow_spw: offset_words %d is out of bounds", (int)offset_words); } } } @@ -1788,8 +1806,39 @@ run_BCO: * => * a_1 ... a_n, k */ - while(n-- > 0) { - SpW(n+by) = ReadSpW(n); + if (n == 0 || WITHIN_CAP_CHUNK_BOUNDS_W(n - 1 + by)) { + while(n-- > 0) { + SpW(n+by) = ReadSpW(n); + } + } else { + // We write across a chunk boundary: Use safe access + while(n-- > 0) { + *((StgWord*)SafeSpWP(n+by)) = ReadSpW(n); + } + } + + // If we SLIDE Sp past the chunk bounds we need to handle the underflow + // (possibly multiple times) + while (!WITHIN_CAP_CHUNK_BOUNDS_W(by)) { + StgStack *stk = cap->r.rCurrentTSO->stackobj; + StgUnderflowFrame *uf = (StgUnderflowFrame*) + (stk->stack + stk->stack_size + - sizeofW(StgUnderflowFrame)); + // See Note [Checking for underflow frames] + if (IS_UNDERFLOW_FRAME(uf->info)) { + W_ sp_to_uf = (StgWord*)uf - (StgWord*)Sp; + Sp = (StgPtr)uf; + SAVE_STACK_POINTERS; + threadStackUnderflow(cap, cap->r.rCurrentTSO); + LOAD_STACK_POINTERS; + by -= sp_to_uf; + } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) { + // we're within the first stack chunk, this chunk has + // no underflow frame + break; + } else { + barf("bci_SLIDE: Sp+by outside stack bounds"); + } } Sp_addW(by); INTERP_TICK(it_slides); ===================================== rts/Messages.c ===================================== @@ -135,7 +135,7 @@ loop: } else if(i == &stg_MSG_CLONE_STACK_info){ MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m; - handleCloneStackMessage(cloneStackMessage); + handleCloneStackMessage(cap, cloneStackMessage); } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -47,6 +47,7 @@ import CLOSURE stg_ret_v_info; /* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, W_ info_ptr, + PROF_HDR_FIELDS(W_, p1, p2) W_ thunk_info_ptr) /* no args => explicit stack */ { ===================================== testsuite/tests/bytecode/T27001.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE BangPatterns #-} +-- Test that SLIDE works correctly when it crosses a stack chunk boundary. +-- See #27001. +module Main where + +go :: Int -> Double -> Double +go 0 !acc = acc +go n !acc = go (n - 1) (acc + 1.0) + +result :: Double +result = go 100000 0.0 + +main :: IO () +main = print result ===================================== testsuite/tests/bytecode/T27001.stdout ===================================== @@ -0,0 +1,4 @@ +(0.15 secs,) +it :: () +100000.0 +(0.09 secs, 51,566,104 bytes) ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -9,3 +9,8 @@ test('T25975', extra_ways(ghci_ways), compile_and_run, # Nullary data constructors test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) + +# SLIDE across stack chunk boundary (#27001) +test('T27001', [extra_files(['T27001.hs']), req_interp], + run_command, + ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs']) ===================================== testsuite/tests/dmdanal/should_compile/T13143.stderr ===================================== @@ -6,8 +6,8 @@ Result size of Tidy Core Rec { -- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0} T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker] - :: forall {a}. (# #) -> a -[GblId, Arity=1, Str=b{sBo->S}, Cpr=b, Unf=OtherCon []] + :: forall a. (# #) -> a +[GblId, Arity=1, Str=b{S}, Cpr=b, Unf=OtherCon []] T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Types.(##) end Rec } @@ -15,7 +15,7 @@ end Rec } f [InlPrag=NOINLINE[final]] :: forall a. Int -> a [GblId, Arity=1, - Str=b{sBo->S}, + Str=b{S}, Cpr=b, Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -66,7 +66,7 @@ T13143.$trModule -- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} lvl :: Int -[GblId, Str=b{sBo->S}, Cpr=b] +[GblId, Str=b{S}, Cpr=b] lvl = T13143.$wf @Int GHC.Types.(##) Rec { ===================================== testsuite/tests/dmdanal/should_compile/T27106.hs ===================================== @@ -0,0 +1,5 @@ +module T27106 where + +{-# NOINLINE weird #-} +weird :: Int -> a +weird x = weird x ===================================== testsuite/tests/dmdanal/should_compile/T27106.stderr ===================================== @@ -0,0 +1,4 @@ +weird [InlPrag=NOINLINE[final]] :: forall a. Int -> a +[GblId, + Arity=1, + Str=b{S}, ===================================== testsuite/tests/dmdanal/should_compile/all.T ===================================== @@ -45,6 +45,13 @@ test('T13077a', normal, compile, ['']) # T13143: WW for NOINLINE function f test('T13143', [ grep_errmsg(r'^T13143\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques']) +# Uniques in the free variable part of a demand signature should be +# suppressed by -dsuppress-uniques. +test('T27106', normal, multimod_compile_filter, + ['T27106', + '-v0 -O -ddump-simpl -dsuppress-uniques', + r"sed -n '/^weird /,/.* Str=/p'"]) + # T15627 # Absent bindings of unlifted types should be WW'ed away. # The idea is to check that both $wmutVar and $warray ===================================== testsuite/tests/rts/all.T ===================================== @@ -583,6 +583,15 @@ test('cloneMyStack_retBigStackFrame', [req_c, extra_files(['cloneStackLib.c']), test('cloneThreadStack', [req_c, only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c']), req_ghc_with_threaded_rts], compile_and_run, ['cloneStackLib.c -threaded']) +test('cloneThreadStackMigrating', + [ ignore_stdout + , only_ways(['threaded1']) + , extra_ways(['threaded1']) + , extra_run_opts('+RTS -N -DS -RTS') + , req_ghc_with_threaded_rts + , req_target_smp + ], compile_and_run, ['-threaded -debug -rtsopts']) + test('decodeMyStack', [ omit_ghci, js_broken(22261) # cloneMyStack# not yet implemented ], compile_and_run, ['-finfo-table-map']) ===================================== testsuite/tests/rts/cloneThreadStackMigrating.hs ===================================== @@ -0,0 +1,37 @@ +module Main where + +import Control.Concurrent +import Control.Monad +import GHC.Exts.Stack +import GHC.Stack.CloneStack + +numWorkers :: Int +numWorkers = 100 + +startN :: Int +startN = 10 + +runForMicros :: Int +runForMicros = 1000000 + +fib :: Int -> Int +fib 0 = 1 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) + +workerThread :: Int -> IO () +workerThread n = do + fib n `seq` pure () + workerThread (n + 1) + +cloneThread :: ThreadId -> IO () +cloneThread tid = forever $ do + snapshot <- cloneThreadStack tid + stack <- decodeStack snapshot + stack `seq` pure () + +main :: IO () +main = do + tids <- replicateM numWorkers (forkIO $ workerThread startN) + mapM_ (forkIO . cloneThread) tids + threadDelay runForMicros View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0b9c16240dd96548f319c8b2376e3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0b9c16240dd96548f319c8b2376e3… You're receiving this email because of your account on gitlab.haskell.org.

1 0