- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/sjakobi/T27528] FastString: Drop mkFastStringWith's constructor callback
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27528 at Glasgow Haskell Compiler / GHC Commits: 6450f1fa by Simon Jakobi at 2026-08-16T00:44:26+02:00 FastString: Drop mkFastStringWith's constructor callback All three callers passed the same callback, a partial application of mkNewFastStringShortByteString to the string being interned. That partial application is allocated as a closure before the table lookup, on the common hit path too, although the callback is needed only after a miss. Drop the parameter and call mkNewFastStringShortByteString directly after a miss. Since nothing is passed "with" anymore, rename the function to intern. Suggested by Simon PJ in #27528: https://gitlab.haskell.org/ghc/ghc/-/work_items/27528#note_687031 Assisted-by: Claude Fable 5 - - - - - 1 changed file: - compiler/GHC/Data/FastString.hs Changes: ===================================== compiler/GHC/Data/FastString.hs ===================================== @@ -320,7 +320,7 @@ data FastStringTable = FastStringTable -- ^ Number of computed z-encodings for all buckets. -- -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk - -- in 'mkFastStringWith' and needs to be boxed any way. + -- in 'intern' and needs to be boxed any way. -- If this is unpacked, then we box this single 'FastMutInt' once for each -- allocated FastString. (Array# (IORef FastStringTableSegment)) -- ^ concurrent segments @@ -474,9 +474,10 @@ The procedure goes like this: * Otherwise, insert and return the string we created. -} -mkFastStringWith - :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString -mkFastStringWith mk_fs sbs = do +-- | Return the interned 'FastString' for the given bytes, creating and +-- inserting one on a table miss. +intern :: ShortByteString -> IO FastString +intern sbs = do FastStringTableSegment lock _ buckets# <- readIORef segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# @@ -487,7 +488,7 @@ mkFastStringWith mk_fs sbs = do -- only run partially and putMVar is not called after takeMVar. noDuplicate n <- get_uid - new_fs <- mk_fs n n_zencs + new_fs <- mkNewFastStringShortByteString sbs n n_zencs withMVar lock $ \_ -> insert new_fs where !(FastStringTable uid n_zencs segments#) = stringTable @@ -523,11 +524,11 @@ bucket_match fs sbs = go fs mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len = - -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- NB: Might as well use unsafeDupablePerformIO, since intern is -- idempotent. unsafeDupablePerformIO $ do sbs <- newSBSFromPtr ptr len - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + intern sbs newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString newSBSFromPtr (Ptr src#) (I# len#) = @@ -541,14 +542,13 @@ newSBSFromPtr (Ptr src#) (I# len#) = mkFastStringByteString :: ByteString -> FastString mkFastStringByteString bs = let sbs = SBS.toShort bs in - inlinePerformIO $ - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + inlinePerformIO $ intern sbs -- | Create a 'FastString' from an existing 'ShortByteString' without -- copying. mkFastStringShortByteString :: ShortByteString -> FastString mkFastStringShortByteString sbs = - inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + inlinePerformIO $ intern sbs -- | Create a 'FastString' from an 'HText' mkFastStringShortText :: ShortText -> FastString @@ -560,7 +560,7 @@ mkFastString :: String -> FastString mkFastString str = inlinePerformIO $ do let !sbs = utf8EncodeShortByteString str - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + intern sbs -- The following rule is used to avoid polluting the non-reclaimable FastString -- table with transient strings when we only want their encoding. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6450f1fa223158460531e9937082bea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6450f1fa223158460531e9937082bea… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27619-liveness-fixpoint-formats] NCG: iterate the liveness fixpoint until register formats converge
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC Commits: 6adeca12 by Simon Jakobi at 2026-08-16T00:25:54+02:00 NCG: iterate the liveness fixpoint until register formats converge The convergence test of the per-SCC liveness fixpoint in GHC.CmmToAsm.Reg.Liveness compared BlockMap Regs values with the key-only Eq of UniqSet, which ignores the Format attached to each register. Formats grow across iterations (one control-flow edge per iteration), so the fixpoint could stop while formats were still growing, recording a vector register live at a too-narrow format and handing the register allocator an under-sized spill/reload width — the silent-corruption class of #26411. The test also compared the entire accumulated block map on every iteration, although only the current SCC's entries can change, making it quadratic in procedure size and a dominant cost on control-flow-heavy code. Compare only the SCC's own entries, using the new format-aware equalRegs. See the new Note [Convergence of the liveness fixpoint]. Also remove the Eq instance of Regs: inherited from UniqSet, it compared the register uniques only, silently ignoring the formats — the mistake behind #27619 — and the convergence test was its sole user. The instance on UniqSet itself deserves the same scrutiny, but that is a compiler-wide audit left for separate work. Fixes #27619. Fixes #27437. Assisted-by: Claude Fable 5 - - - - - 5 changed files: - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Reg/Regs.hs - compiler/GHC/Types/Unique/FM.hs - + testsuite/tests/regalloc/T27619.hs - testsuite/tests/regalloc/all.T Changes: ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -879,7 +879,7 @@ computeLiveness platform sccs , ppr sccs']) livenessSCCs - :: Instruction instr + :: forall instr. Instruction instr => Platform -> BlockMap Regs -> [SCC (LiveBasicBlock instr)] -- accum @@ -897,36 +897,49 @@ livenessSCCs platform blockmap done (AcyclicSCC block : sccs) livenessSCCs platform blockmap done (CyclicSCC blocks : sccs) = livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs - where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks + where (blockmap', blocks') = fixpoint blockmap - iterateUntilUnchanged - :: (a -> b -> (a,c)) -> (a -> a -> Bool) - -> a -> b - -> (a,c) - - iterateUntilUnchanged f eq aa b = go aa + -- See Note [Convergence of the liveness fixpoint] + fixpoint :: BlockMap Regs -> (BlockMap Regs, [LiveBasicBlock instr]) + fixpoint bm + | all unchanged blocks = (bm', blocks'') + | otherwise = fixpoint bm' where - go a = if eq a a' then ac else go a' - where - ac@(a', _) = f a b - - linearLiveness - :: Instruction instr - => BlockMap Regs -> [LiveBasicBlock instr] - -> (BlockMap Regs, [LiveBasicBlock instr]) - - linearLiveness = mapAccumL (livenessBlock platform) - - -- probably the least efficient way to compare two - -- BlockMaps for equality. - equalBlockMaps :: BlockMap Regs -> BlockMap Regs -> Bool - equalBlockMaps a b - = a' == b' - where a' = mapToList a - b' = mapToList b - -- See Note [Unique Determinism and code generation] + (bm', blocks'') = mapAccumL (livenessBlock platform) bm blocks + + unchanged :: LiveBasicBlock instr -> Bool + unchanged block = + case (mapLookup bid bm, mapLookup bid bm') of + (Just old, Just new) -> old `equalRegs` new + (Nothing, _ ) -> False -- first iteration + (Just _, Nothing ) -> False -- cannot happen + where bid = blockId block + +{- Note [Convergence of the liveness fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a cyclic SCC, we iterate 'livenessBlock' over the SCC's blocks until the +recorded entry liveness stops changing. Two subtleties in the convergence +test: + +* It must compare register formats, not just the sets of live registers + (hence the format-aware 'equalRegs'). A block's + live-in set joins the successors' entries with 'unionRegsMaxFmt', so a wide + format needs one iteration per control-flow edge to propagate backwards + around a loop, while the register *sets* are typically already complete + after the first iteration. Stopping when the sets stabilise can record a + register at a format narrower than the reads it flows into, violating + (FmtBwd1) of Note [Register formats in liveness analysis] — which the + register allocator relies on for spill/reload widths (#27619). + +* Only the entries of the SCC's own blocks can change between iterations: + 'livenessBlock' inserts only the block it processes, and successor SCCs are + already final since SCCs are processed in reverse dependency order. + Comparing the whole accumulated block map made the fixpoint quadratic in + procedure size (#27437). + +Termination: entries only grow — registers are only added, and formats only +increase via 'maxRegWithFormat' joins — and both lattices are finite. +-} ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -13,6 +13,7 @@ module GHC.CmmToAsm.Reg.Regs ( shrinkingRegs, mapRegs, elemRegs, lookupReg, + equalRegs, ) where @@ -23,6 +24,7 @@ import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) import GHC.Utils.Outputable ( Outputable ) import GHC.Types.Unique ( Uniquable(..) ) +import GHC.Types.Unique.FM ( equalUFMBy ) import GHC.Types.Unique.Set import Data.Coerce ( coerce ) @@ -33,7 +35,7 @@ import Data.Coerce ( coerce ) -- register liveness analysis. See Note [Register formats in liveness analysis] -- in GHC.CmmToAsm.Reg.Liveness. newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } - deriving newtype (Eq, Outputable) + deriving newtype (Outputable) maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) @@ -117,3 +119,10 @@ elemRegs r (Regs live) = elemUniqSet_Directly (getUnique r) live lookupReg :: Reg -> Regs -> Maybe Format lookupReg r (Regs live) = regWithFormat_format <$> lookupUniqSet_Directly live (getUnique r) + +-- | Do the two sets contain the same registers, at the same formats? +equalRegs :: Regs -> Regs -> Bool +equalRegs (Regs a) (Regs b) = equalUFMBy sameFormat (getUniqSet a) (getUniqSet b) + where + -- Registers with equal uniques are equal, so only compare the formats. + sameFormat (RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = fmt1 == fmt2 ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -67,6 +67,7 @@ module GHC.Types.Unique.FM ( strictIntersectUFM_C, disjointUFM, equalKeysUFM, + equalUFMBy, diffUFM, nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM, nonDetFoldWithKeyUFM, @@ -590,7 +591,12 @@ unsafeCastUFMKey (UFM m) = UFM m -- Determines whether two 'UniqFM's contain the same keys. equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool -equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 +equalKeysUFM = equalUFMBy (\_ _ -> True) + +-- | Determines whether two 'UniqFM's contain the same keys, with values +-- that agree according to the given predicate. +equalUFMBy :: (a -> b -> Bool) -> UniqFM key a -> UniqFM key b -> Bool +equalUFMBy eq (UFM m1) (UFM m2) = liftEq eq m1 m2 -- | An edit on type @a@, relating an element of a container (like an entry in a -- map or a line in a file) before and after. ===================================== testsuite/tests/regalloc/T27619.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +-- The native code for this loop is a three-block cycle H -> X -> W -> H: +-- +-- H (loop head): reads v at FF64 (movsd lane-0 extract for the guard) +-- X: reads v at FF64 (another movsd lane-0 extract) +-- W: reads v at F64x2 (movhlps from the full unpack) +-- +-- v is loop-invariant, so its live format on entry to every block in the +-- cycle must be F64x2. -fno-cse only keeps the two syntactically identical +-- lane-0 extracts from being merged. +-- +-- The test greps -ddump-asm-liveness for a 128-bit vector register recorded +-- at FF64, which the too-early convergence of the liveness fixpoint produced. +module T27619 where + +import GHC.Exts + +loop :: Int# -> DoubleX2# -> Double# -> Double# +loop i v acc = + case unpackDoubleX2# v of + (# a1, _ #) -> + if isTrue# (a1 <## int2Double# i) + then acc + else case unpackDoubleX2# v of + (# a2, _ #) -> + if isTrue# (a2 *## 2.0## <## int2Double# i) + then acc *## 2.0## + else case unpackDoubleX2# v of + (# x, y #) -> loop (i -# 1#) v (acc +## (x *## y)) +{-# NOINLINE loop #-} ===================================== testsuite/tests/regalloc/all.T ===================================== @@ -6,3 +6,14 @@ test('regalloc_unit_tests', [ignore_stderr, only_ways(['normal'])], extra_run_opts('"' + config.libdir + '"') ], compile_and_run, ['-package ghc']) + +# The liveness fixpoint must iterate until the register formats converge, not +# just the sets of live registers (#27619). A vector register live at +# VecFormat 2 FmtDouble around the loop must not be recorded at FF64. +test('T27619', + [ unless(arch('x86_64'), skip), + when(not have_ncg(), skip), + only_ways(['normal']), + grep_errmsg(r'%vV128_\S+ :: FF64') ], + compile, + ['-O -fno-cse -ddump-asm-liveness']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6adeca12421e4444e261268251892ac… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6adeca12421e4444e261268251892ac… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27619-liveness-fixpoint-formats] NCG: iterate the liveness fixpoint until register formats converge
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC Commits: ef975d68 by Simon Jakobi at 2026-08-16T00:10:30+02:00 NCG: iterate the liveness fixpoint until register formats converge The convergence test of the per-SCC liveness fixpoint in GHC.CmmToAsm.Reg.Liveness compared BlockMap Regs values with the key-only Eq of UniqSet, which ignores the Format attached to each register. Formats grow across iterations (one control-flow edge per iteration), so the fixpoint could stop while formats were still growing, recording a vector register live at a too-narrow format and handing the register allocator an under-sized spill/reload width — the silent-corruption class of #26411. The test also compared the entire accumulated block map on every iteration, although only the current SCC's entries can change, making it quadratic in procedure size and a dominant cost on control-flow-heavy code. Compare only the SCC's own entries, using the new format-aware equalRegs. See the new Note [Convergence of the liveness fixpoint]. Also remove the Eq instance of Regs: inherited from UniqSet, it compared the register uniques only, silently ignoring the formats — the mistake behind #27619 — and the convergence test was its sole user. The instance on UniqSet itself deserves the same scrutiny, but that is a compiler-wide audit left for separate work. Fixes #27619. Fixes #27437. Assisted-by: Claude Fable 5 - - - - - 5 changed files: - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Reg/Regs.hs - compiler/GHC/Types/Unique/FM.hs - + testsuite/tests/regalloc/T27619.hs - testsuite/tests/regalloc/all.T Changes: ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -879,7 +879,7 @@ computeLiveness platform sccs , ppr sccs']) livenessSCCs - :: Instruction instr + :: forall instr. Instruction instr => Platform -> BlockMap Regs -> [SCC (LiveBasicBlock instr)] -- accum @@ -897,36 +897,49 @@ livenessSCCs platform blockmap done (AcyclicSCC block : sccs) livenessSCCs platform blockmap done (CyclicSCC blocks : sccs) = livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs - where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks + where (blockmap', blocks') = fixpoint blockmap - iterateUntilUnchanged - :: (a -> b -> (a,c)) -> (a -> a -> Bool) - -> a -> b - -> (a,c) - - iterateUntilUnchanged f eq aa b = go aa + -- See Note [Convergence of the liveness fixpoint] + fixpoint :: BlockMap Regs -> (BlockMap Regs, [LiveBasicBlock instr]) + fixpoint bm + | all unchanged blocks = (bm', blocks'') + | otherwise = fixpoint bm' where - go a = if eq a a' then ac else go a' - where - ac@(a', _) = f a b - - linearLiveness - :: Instruction instr - => BlockMap Regs -> [LiveBasicBlock instr] - -> (BlockMap Regs, [LiveBasicBlock instr]) - - linearLiveness = mapAccumL (livenessBlock platform) - - -- probably the least efficient way to compare two - -- BlockMaps for equality. - equalBlockMaps :: BlockMap Regs -> BlockMap Regs -> Bool - equalBlockMaps a b - = a' == b' - where a' = mapToList a - b' = mapToList b - -- See Note [Unique Determinism and code generation] + (bm', blocks'') = mapAccumL (livenessBlock platform) bm blocks + + unchanged :: LiveBasicBlock instr -> Bool + unchanged block = + case (mapLookup bid bm, mapLookup bid bm') of + (Just old, Just new) -> old `equalRegs` new + (Nothing, _ ) -> False -- first iteration + (Just _, Nothing ) -> False -- cannot happen + where bid = blockId block + +{- Note [Convergence of the liveness fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a cyclic SCC, we iterate 'livenessBlock' over the SCC's blocks until the +recorded entry liveness stops changing. Two subtleties in the convergence +test: + +* It must compare register formats, not just the sets of live registers + (hence 'equalRegs' rather than the key-only 'Eq' of 'UniqSet'). A block's + live-in set joins the successors' entries with 'unionRegsMaxFmt', so a wide + format needs one iteration per control-flow edge to propagate backwards + around a loop, while the register *sets* are typically already complete + after the first iteration. Stopping when the sets stabilise can record a + register at a format narrower than the reads it flows into, violating + (FmtBwd1) of Note [Register formats in liveness analysis] — which the + register allocator relies on for spill/reload widths (#27619). + +* Only the entries of the SCC's own blocks can change between iterations: + 'livenessBlock' inserts only the block it processes, and successor SCCs are + already final since SCCs are processed in reverse dependency order. + Comparing the whole accumulated block map made the fixpoint quadratic in + procedure size (#27437). + +Termination: entries only grow — registers are only added, and formats only +increase via 'maxRegWithFormat' joins — and both lattices are finite. +-} ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -13,6 +13,7 @@ module GHC.CmmToAsm.Reg.Regs ( shrinkingRegs, mapRegs, elemRegs, lookupReg, + equalRegs, ) where @@ -23,6 +24,7 @@ import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) import GHC.Utils.Outputable ( Outputable ) import GHC.Types.Unique ( Uniquable(..) ) +import GHC.Types.Unique.FM ( equalUFMBy ) import GHC.Types.Unique.Set import Data.Coerce ( coerce ) @@ -33,7 +35,7 @@ import Data.Coerce ( coerce ) -- register liveness analysis. See Note [Register formats in liveness analysis] -- in GHC.CmmToAsm.Reg.Liveness. newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } - deriving newtype (Eq, Outputable) + deriving newtype (Outputable) maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) @@ -117,3 +119,10 @@ elemRegs r (Regs live) = elemUniqSet_Directly (getUnique r) live lookupReg :: Reg -> Regs -> Maybe Format lookupReg r (Regs live) = regWithFormat_format <$> lookupUniqSet_Directly live (getUnique r) + +-- | Do the two sets contain the same registers, at the same formats? +equalRegs :: Regs -> Regs -> Bool +equalRegs (Regs a) (Regs b) = equalUFMBy sameFormat (getUniqSet a) (getUniqSet b) + where + -- Registers with equal uniques are equal, so only compare the formats. + sameFormat (RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = fmt1 == fmt2 ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -67,6 +67,7 @@ module GHC.Types.Unique.FM ( strictIntersectUFM_C, disjointUFM, equalKeysUFM, + equalUFMBy, diffUFM, nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM, nonDetFoldWithKeyUFM, @@ -590,7 +591,12 @@ unsafeCastUFMKey (UFM m) = UFM m -- Determines whether two 'UniqFM's contain the same keys. equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool -equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 +equalKeysUFM = equalUFMBy (\_ _ -> True) + +-- | Determines whether two 'UniqFM's contain the same keys, with values +-- that agree according to the given predicate. +equalUFMBy :: (a -> b -> Bool) -> UniqFM key a -> UniqFM key b -> Bool +equalUFMBy eq (UFM m1) (UFM m2) = liftEq eq m1 m2 -- | An edit on type @a@, relating an element of a container (like an entry in a -- map or a line in a file) before and after. ===================================== testsuite/tests/regalloc/T27619.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +-- The native code for this loop is a three-block cycle H -> X -> W -> H: +-- +-- H (loop head): reads v at FF64 (movsd lane-0 extract for the guard) +-- X: reads v at FF64 (another movsd lane-0 extract) +-- W: reads v at F64x2 (movhlps from the full unpack) +-- +-- v is loop-invariant, so its live format on entry to every block in the +-- cycle must be F64x2. -fno-cse only keeps the two syntactically identical +-- lane-0 extracts from being merged. +-- +-- The test greps -ddump-asm-liveness for a 128-bit vector register recorded +-- at FF64, which the too-early convergence of the liveness fixpoint produced. +module T27619 where + +import GHC.Exts + +loop :: Int# -> DoubleX2# -> Double# -> Double# +loop i v acc = + case unpackDoubleX2# v of + (# a1, _ #) -> + if isTrue# (a1 <## int2Double# i) + then acc + else case unpackDoubleX2# v of + (# a2, _ #) -> + if isTrue# (a2 *## 2.0## <## int2Double# i) + then acc *## 2.0## + else case unpackDoubleX2# v of + (# x, y #) -> loop (i -# 1#) v (acc +## (x *## y)) +{-# NOINLINE loop #-} ===================================== testsuite/tests/regalloc/all.T ===================================== @@ -6,3 +6,14 @@ test('regalloc_unit_tests', [ignore_stderr, only_ways(['normal'])], extra_run_opts('"' + config.libdir + '"') ], compile_and_run, ['-package ghc']) + +# The liveness fixpoint must iterate until the register formats converge, not +# just the sets of live registers (#27619). A vector register live at +# VecFormat 2 FmtDouble around the loop must not be recorded at FF64. +test('T27619', + [ unless(arch('x86_64'), skip), + when(not have_ncg(), skip), + only_ways(['normal']), + grep_errmsg(r'%vV128_\S+ :: FF64') ], + compile, + ['-O -fno-cse -ddump-asm-liveness']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef975d68f3720238a10ee7848a37b34… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef975d68f3720238a10ee7848a37b34… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T27619-liveness-fixpoint-formats
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed new branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27619-liveness-fixpo… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T27528
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed new branch wip/sjakobi/T27528 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27528 You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/cfg-fix
by Andreas Klebinger (＠AndreasK) 16 Aug '26

16 Aug '26

Andreas Klebinger pushed new branch wip/andreask/cfg-fix at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/cfg-fix You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add law in qualified strings doc
by Marge Bot (＠marge-bot) 16 Aug '26

16 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a737df91 by Brandon Chinn at 2026-08-15T12:40:25-04:00 Add law in qualified strings doc - - - - - e3188581 by Zubin Duggal at 2026-08-15T12:41:06-04:00 DmdAnal: Fix maxDmdType We need to eta expand the smaller DmdType using defaultArgDmd, like in lubDmdType. Introduce zipDmdType as a common combinator to implement both maxDmdType and lubDmdType uniformly. fixes #27626 - - - - - ca9b0b22 by mangoiv at 2026-08-15T12:41:47-04:00 hadrian: set the executable bit for hie-bios.bat - - - - - 95d19638 by sheaf at 2026-08-15T13:14:05-04:00 Avoid wasteful allocations in mkTyConAppCo The idiom "traverse isReflCo_maybe" followed by "map fst" used in 'GHC.Core.Coercion.mkTyConAppCo' was allocating a lot of waste. This commit uses 'GHC.Data.Unboxed.traverseMaybeUB' to avoid all these unnecessary intermediate allocations. In a quick microbenchmark for 'mkTyConAppCo', this change resulted in: - refl case (all argument coercions are reflexive): - -60% runtime - -80% allocations - non-refl case: - from 0% to -12% runtime (depending on which argument is non-refl) - from 0% to -70% allocations ( -- '' -- ) Fixes #27648 ------------------------- Metric Decrease: FamAppCachePerf SimplCastPerf T12425 T15703 T26426 T3064 T9872a T9872b T9872b_defer T9872c T9872d T5321Fun T9020 T9630 Metric Increase: LinkableUsage02 ------------------------- - - - - - 8dd06495 by Alan Zimmerman at 2026-08-15T13:14:05-04:00 EPA: Remove al_trailing from AnnList It was not being used - - - - - 30 changed files: - + changelog.d/27626 - compiler/GHC/Core/Coercion.hs - compiler/GHC/Data/Unboxed.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Types/Demand.hs - docs/users_guide/exts/qualified_strings.rst - hadrian/hie-bios.bat - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/dmdanal/should_run/M2.hs - + testsuite/tests/dmdanal/should_run/T27626.hs - + testsuite/tests/dmdanal/should_run/T27626.stdout - testsuite/tests/dmdanal/should_run/all.T - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs Changes: ===================================== changelog.d/27626 ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Fix a bug where an argument used only by a function's stable unfolding + could still be marked absent, resulting in a runtime crash. +mrs: !16503 +issues: #27626 ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -147,6 +147,7 @@ import GHC.Types.Basic import GHC.Types.Unique import GHC.Data.FastString import GHC.Data.Pair +import GHC.Data.Unboxed (traverseMaybeUB) import GHC.Types.SrcLoc import GHC.Builtin.KnownKeys import GHC.Builtin.WiredIn.Prim @@ -166,6 +167,7 @@ import Data.Char( isDigit ) import qualified Data.Monoid as Monoid import Data.List.NonEmpty ( NonEmpty (..) ) import Control.DeepSeq +import GHC.Exts (inline) {- %************************************************************************ @@ -722,6 +724,19 @@ isReflexiveCo_maybe co = Nothing where (Pair ty1 ty2, r) = coercionKindRole co +-- | Like @\\ cos -> map fst <$> traverse isReflCo_maybe cos@, +-- but avoiding wasteful allocations (see #27648). +reflCos_maybe :: [Coercion] -> Maybe [Type] +reflCos_maybe = + traverseMaybeUB + ( fmap fst + . inline isReflCo_maybe + -- isReflCo_maybe must inline so that 'fmap fst' fuses and the whole + -- function inlines into 'traverseMaybeUB' + ) +{-# INLINE reflCos_maybe #-} + -- to avoid allocating the result's 'Just' constructor application + forAllCoKindCo :: TyCoVar -> KindMCoercion -> KindCoercion -- Get the kind coercion from a ForAllCo forAllCoKindCo _ (MCo co) = co @@ -811,8 +826,8 @@ mkTyConAppCo r tc cos | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos - | Just tys_roles <- traverse isReflCo_maybe cos - = mkReflCo r (mkTyConApp tc (map fst tys_roles)) + | Just tys <- reflCos_maybe cos + = mkReflCo r $! mkTyConApp tc tys -- See Note [Refl invariant] | otherwise = TyConAppCo r tc cos ===================================== compiler/GHC/Data/Unboxed.hs ===================================== @@ -13,10 +13,11 @@ module GHC.Data.Unboxed ( MaybeUB(JustUB, NothingUB), - fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB + fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB, + traverseMaybeUB ) where -import GHC.Prelude hiding (Maybe(..), Either(..)) +import GHC.Prelude -- | Like Maybe, but using unboxed sums. -- @@ -54,3 +55,28 @@ fmapMaybeUB f (JustUB x) = JustUB $ f x maybeUB :: b -> (a -> b) -> MaybeUB a -> b maybeUB _def f (JustUB x) = f x maybeUB def _f NothingUB = def + +toMaybe :: MaybeUB a -> Maybe a +toMaybe NothingUB = Nothing +toMaybe (JustUB a) = Just a + +-- | Like 'traverse' for the 'Maybe' applicative, but avoiding intermediate +-- allocations. +-- +-- The passed-in function must inline for this to help at all. +traverseMaybeUB + :: forall a b + . (a -> Maybe b) -- ^ @INLINE@ function to map over the list + -> [a] -> Maybe [b] +{-# INLINE traverseMaybeUB #-} + -- 'traverseMaybeUB' must inline so that the function it is passed can inline +traverseMaybeUB f = \ xs -> toMaybe $ go xs + where + go :: [a] -> MaybeUB [b] + go [] = JustUB [] + go (a:as) + | Just b <- f a -- f is assumed to inline + , JustUB bs <- go as + = JustUB (b:bs) + | otherwise + = NothingUB ===================================== compiler/GHC/Parser.y ===================================== @@ -1796,10 +1796,10 @@ cvars1 :: { [RecordPatSynField GhcPs] } where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList) } : 'where' '{' decls '}' {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3, epTok $1, - AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) [])) } + AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) } | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3, epTok $1, - AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) [])) } + AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3))) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -1935,9 +1935,9 @@ decls :: { Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs)) } | {- empty -} { noLoc (noAnn, [],nilOL) } decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } - : '{' decls '}' { sLL $1 $> (AnnList (Just (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) [] + : '{' decls '}' { sLL $1 $> (AnnList (Just (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } - | vocurly decls close { sL1 $2 (AnnList (Just (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2) [] + | vocurly decls close { sL1 $2 (AnnList (Just (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } -- Binding groups other than those of class and instance declarations @@ -1945,16 +1945,16 @@ decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } binds :: { Located (HsLocalBinds GhcPs) } -- May have implicit parameters -- No type declarations - : decllist {% do { let { (AnnList anc p s t, decls) = unLoc $1 } + : decllist {% do { let { (AnnList anc p s, decls) = unLoc $1 } ; val_binds <- cvBindGroup (unLoc $ decls) ; !cs <- getCommentsFor (gl $1) - ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList anc p s t) cs, NoEpTok) val_binds)} } + ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList anc p s) cs, NoEpTok) val_binds)} } | '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (ListBraces (epTok $1) (epTok $3)) [] []) cs, NoEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (ListBraces (epTok $1) (epTok $3)) []) cs, NoEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } | vocurly dbinds close {% acs (gl $2) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) ListNone [] []) cs, NoEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) ListNone []) cs, NoEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) } @@ -3282,7 +3282,7 @@ aexp2 :: { ECP } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromCmd $ - amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) [] []) $2 Prefix + amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) []) $2 Prefix (reverse $3)) } projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) } @@ -3414,9 +3414,9 @@ tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] } -- Never empty. list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b) } : texp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> - mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] []) } + mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } | lexps { \loc (ao,ac) -> $1 >>= \ $1 -> - mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] []) } + mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok $2) (EpTok ac)) Nothing (From $1)) >>= ecpFromExp' } @@ -3440,7 +3440,7 @@ list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV ( { \loc (ao,ac) -> checkMonadComp >>= \ ctxt -> unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (epTok $2) - ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] [], noAnn)) + ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [], noAnn)) >>= ecpFromExp' } } lexps :: { forall b. DisambECP b => PV [LocatedA b] } @@ -3546,11 +3546,11 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList)) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsA' (sLL $1 $> (reverse (snd $ unLoc $2), - (AnnList (Just $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2) []))) } + (AnnList (Just $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) } | vocurly alts(PATS) close { $2 >>= \ $2 -> amsA' (L (getLoc $2) (reverse (snd $ unLoc $2), - (AnnList (Just $ glR $2) ListNone (fst $ unLoc $2) []))) } - | '{' '}' { amsA' (sLL $1 $> ([], (AnnList Nothing (ListBraces (epTok $1) (epTok $2)) [] []))) } + (AnnList (Just $ glR $2) ListNone (fst $ unLoc $2)))) } + | '{' '}' { amsA' (sLL $1 $> ([], (AnnList Nothing (ListBraces (epTok $1) (epTok $2)) []))) } | vocurly close { return $ noLocA ([], noAnn) } alts(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) } @@ -4727,7 +4727,7 @@ commentsPA la@(L l a) = do hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> (AnnList, EpToken "rec") hsDoAnn rec (ob, semis, cb) (L ll _) - = (AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis [], rec) + = (AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis, rec) listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation listAsAnchorM [] = Nothing ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -43,7 +43,7 @@ module GHC.Parser.Annotation ( -- ** Trailing annotations in lists TrailingAnn(..), ta_location, - addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN, + addTrailingAnnToA, addTrailingCommaToN, addTrailingAnnToBF, noTrailingN, @@ -529,10 +529,7 @@ data AnnList = AnnList { al_anchor :: !(Maybe EpaLocation), -- ^ start point of a list having layout al_brackets :: !AnnListBrackets, - al_semis :: [EpToken ";"], -- decls - al_trailing :: ![TrailingAnn] -- ^ items appearing after the - -- list, such as '=>' for a - -- context + al_semis :: [EpToken ";"] -- decls } deriving (Data,Eq) data AnnListBrackets @@ -672,16 +669,6 @@ data AnnPragSCC -- --------------------------------------------------------------------- --- | Helper function used in the parser to add a 'TrailingAnn' items --- to an existing annotation. -addTrailingAnnToL :: TrailingAnn -> EpAnnComments - -> EpAnn AnnList -> EpAnn AnnList -addTrailingAnnToL t cs n = n { anns = addTrailing (anns n) - , comments = comments n <> cs } - where - -- See Note [list append in addTrailing*] - addTrailing n = n { al_trailing = al_trailing n ++ [t]} - addTrailingAnnToBF :: TrailingAnn -> EpAnnComments -> EpAnn AnnBooleanFormula -> EpAnn AnnBooleanFormula addTrailingAnnToBF t cs n = n { anns = addTrailing (anns n) @@ -714,7 +701,7 @@ noTrailingN s = s { anns = (anns s) { nann_trailing = [] } } {- Note [list append in addTrailing*] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN +The addTrailingAnnToA and addTrailingCommaToN functions are used to add a separator for an item when it occurs in a list. So they are used to capture a comma, vbar, semicolon and similar. @@ -1047,7 +1034,7 @@ instance NoAnn AnnBooleanFormula where noAnn = AnnBooleanFormula noAnn noAnn [] instance NoAnn AnnList where - noAnn = AnnList Nothing ListNone noAnn [] + noAnn = AnnList Nothing ListNone noAnn instance NoAnn NameAnn where noAnn = NameAnnTrailing [] @@ -1141,8 +1128,8 @@ instance Outputable NameAnn where = text "NameAnnTrailing" <+> ppr t instance Outputable AnnList where - ppr (AnnList anc p s t) - = text "AnnList" <+> ppr anc <+> ppr p <+> ppr s <+> ppr t + ppr (AnnList l p s) + = text "AnnList" <+> ppr l <+> ppr p <+> ppr s instance Outputable AnnListBrackets where ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -437,7 +437,7 @@ mkRoleAnnotDecl loc tycon roles anns mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs mkMDo (ob, semis, cb) ctxt stmts tok loc - = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis [], tok) + = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis, tok) -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if @@ -1963,7 +1963,7 @@ instance DisambECP (HsCmd GhcPs) where return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis [], tok_loc) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis, tok_loc) stmts) mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do !cs <- getCommentsFor l @@ -2062,7 +2062,7 @@ instance DisambECP (HsExpr GhcPs) where return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis [], loc_tok) (DoExpr mod) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis, loc_tok) (DoExpr mod) stmts) mkHsParPV l lpar e rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -1849,12 +1849,14 @@ botDmdEnv = mkEmptyDmdEnv botDiv exnDmdEnv :: DmdEnv exnDmdEnv = mkEmptyDmdEnv exnDiv +combineDmdEnv :: (Demand -> Demand -> Demand) -> DmdEnv -> DmdEnv -> DmdEnv +combineDmdEnv f (DE fv1 d1) (DE fv2 d2) + -- See Note [Demand env Equality] + = DE (plusVarEnv_CD f fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)) + (lubDivergence d1 d2) + lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div - where - -- See Note [Demand env Equality] - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) - lub_div = lubDivergence d1 d2 +lubDmdEnv = combineDmdEnv lubDmd addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv addVarDmdEnv env@(DE fvs div) id dmd @@ -1908,36 +1910,31 @@ instance Eq DmdType where = ds1 == ds2 -- cheap checks first && env1 == env2 +-- | The smaller 'DmdType' is eta expanded using its 'defaultArgDmd'. +-- See Note [Default demand on free variables and arguments]. +zipDmdType :: (Demand -> Demand -> Demand) -> DmdType -> DmdType -> DmdType +zipDmdType f (DmdType fv1 ds1) (DmdType fv2 ds2) + = DmdType (combineDmdEnv f fv1 fv2) (go ds1 ds2) + where + def1, def2 :: Demand -- Default argument demands for eta expansion + def1 = defaultArgDmd (de_div fv1) + def2 = defaultArgDmd (de_div fv2) + + -- If `ds1` is shorter than `ds2`, extend `ds1` with the appropriate + -- default demand `def1`; and similarly if `ds2` is shorter + go (d1:ds1') (d2:ds2') = f d1 d2 : go ds1' ds2' + go [] ds2' = map (def1 `f`) ds2' + go ds1' [] = map (`f` def2) ds1' + -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 = DmdType lub_fv lub_ds - where - n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1) = etaExpandDmdType n d1 - (DmdType fv2 ds2) = etaExpandDmdType n d2 - lub_ds = zipWithEqual lubDmd ds1 ds2 - lub_fv = lubDmdEnv fv1 fv2 +lubDmdType = zipDmdType lubDmd -- | Combine two 'DmdType's for stable unfolding analysis. -- See Note [Combining demands for stable unfoldings]. maxDmdType :: DmdType -> DmdType -> DmdType -maxDmdType (DmdType fv1 ds1) (DmdType fv2 ds2) - = DmdType combined_fv combined_ds - where - combined_fv = maxDmdEnv fv1 fv2 - combined_ds = go ds1 ds2 - -- If lists have different lengths, keep remaining ds1 (from RHS) - go rhs [] = rhs - go [] _ = [] - go (r:rhs) (u:unfs) = maxDmd r u : go rhs unfs - --- | See Note [Combining demands for stable unfoldings]. -maxDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -maxDmdEnv (DE fv1 d1) (DE fv2 d2) = DE combined_fv combined_div - where - combined_fv = plusVarEnv_CD maxDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) - combined_div = lubDivergence d1 d2 +maxDmdType = zipDmdType maxDmd discardArgDmds :: DmdType -> DmdEnv discardArgDmds (DmdType fv _) = fv ===================================== docs/users_guide/exts/qualified_strings.rst ===================================== @@ -15,3 +15,10 @@ The ``-XQualifiedStrings`` extension allows string literals to be qualified usin This allows more precise control over the ``fromString`` function than :extension:`OverloadedStrings`, which overloads all string literals for an entire module. If :extension:`MultilineStrings` is also enabled, ``M."""test"""`` will also work, desugaring the multiline string first, then the qualified string literal. + +Laws +~~~~ + +If the following expression typechecks, it should hold: + +* ``Data.String.fromString "str" == M."str"`` ===================================== hadrian/hie-bios.bat ===================================== ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -86,6 +86,7 @@ GHC.Data.Pair GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap +GHC.Data.Unboxed GHC.Data.Word64Map GHC.Data.Word64Map.Internal GHC.Data.Word64Map.Lazy ===================================== testsuite/tests/dmdanal/should_run/M2.hs ===================================== @@ -0,0 +1,28 @@ +module M2 where + +-- f's stable unfolding template is the PAP `mk g`, which is not +-- eta-expanded, so its DmdType has depth 0. The big lambda keeps the +-- template large enough that f does not certainlyWillInline, so it is +-- worker/wrappered. +{-# INLINABLE [1] f #-} +f :: Int -> Int -> Float +f = mk (\y -> succ . succ . succ . succ . succ . succ . succ . succ . succ $ y) + +-- Arity 1: the `let` does real work, so mk is not eta-expanded past it. +-- The returned function really forces x. +{-# NOINLINE mk #-} +mk :: (Int -> Int) -> Int -> Int -> Float +mk t = let s = t 1 in \dummy x -> x `seq` fromIntegral (t (dummy + s)) + +{-# INLINE mkFast #-} +mkFast :: (Int -> Int) -> Int -> Int -> Float +mkFast t = \dummy x -> fromIntegral (t dummy) + +-- Active only before phase 1: rewrites f's RHS early, but is dead by +-- the time f's stable unfolding (activation [1]) is inlined at call +-- sites. +{-# RULES "mk" [~1] forall t. mk t = mkFast t #-} + +{-# NOINLINE g #-} +g :: Int -> Int +g x = x + 1 ===================================== testsuite/tests/dmdanal/should_run/T27626.hs ===================================== @@ -0,0 +1,6 @@ +-- The raised threshold persuades GHC to inline the worker's stable +-- unfolding in this small program; a larger program does that naturally. +{-# OPTIONS_GHC -funfolding-use-threshold=400 #-} +module Main where +import M2 ( f ) +main = print (f 19 12) ===================================== testsuite/tests/dmdanal/should_run/T27626.stdout ===================================== @@ -0,0 +1 @@ +38.0 ===================================== testsuite/tests/dmdanal/should_run/all.T ===================================== @@ -36,3 +36,4 @@ test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208']) test('T25439', normal, compile_and_run, ['']) test('T26748', normal, compile_and_run, ['']) test('T26416', [extra_files(['M1.hs'])], multimod_compile_and_run, ['T26416','M1.hs']) +test('T27626', [extra_files(['M2.hs'])], multimod_compile_and_run, ['T27626','M2.hs']) ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -71,7 +71,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -83,7 +83,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/module/mod185.stderr ===================================== @@ -95,7 +95,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -2124,7 +2124,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -91,7 +91,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -214,7 +213,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -294,7 +292,6 @@ (ListBraces (NoEpTok) (NoEpTok)) - [] []) (EpaSpan { DumpParsedAstComments.hs:14:7-8 })) (DoExpr @@ -364,7 +361,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -32,7 +32,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -259,7 +259,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -333,7 +332,6 @@ (ListBraces (NoEpTok) (NoEpTok)) - [] []) (EpaSpan { DumpSemis.hs:10:7-8 })) (DoExpr @@ -373,8 +371,7 @@ ,(EpTok (EpaSpan { DumpSemis.hs:11:10 })) ,(EpTok - (EpaSpan { DumpSemis.hs:11:11 }))] - []) + (EpaSpan { DumpSemis.hs:11:11 }))]) (EpaSpan { DumpSemis.hs:11:3-4 })) (DoExpr (Nothing)) @@ -554,7 +551,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -631,8 +627,7 @@ [(EpTok (EpaSpan { DumpSemis.hs:16:5 })) ,(EpTok - (EpaSpan { DumpSemis.hs:16:8 }))] - []) + (EpaSpan { DumpSemis.hs:16:8 }))]) (EpaSpan { DumpSemis.hs:15:7-8 })) (DoExpr (Nothing)) @@ -806,7 +801,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -883,8 +877,7 @@ [(EpTok (EpaSpan { DumpSemis.hs:22:12 })) ,(EpTok - (EpaSpan { DumpSemis.hs:22:13 }))] - []) + (EpaSpan { DumpSemis.hs:22:13 }))]) (EpaSpan { DumpSemis.hs:22:7-8 })) (DoExpr (Nothing)) @@ -1015,7 +1008,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1120,7 +1112,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1227,7 +1218,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1718,7 +1708,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1844,7 +1833,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1935,8 +1923,7 @@ ,(EpTok (EpaSpan { DumpSemis.hs:34:17 })) ,(EpTok - (EpaSpan { DumpSemis.hs:34:18 }))] - []) + (EpaSpan { DumpSemis.hs:34:18 }))]) (EpaComments [])) (NoEpTok)) @@ -1971,7 +1958,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -2084,7 +2070,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -2209,7 +2194,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -2328,8 +2312,7 @@ ,(EpTok (EpaSpan { DumpSemis.hs:38:7 })) ,(EpTok - (EpaSpan { DumpSemis.hs:38:8 }))] - [])) + (EpaSpan { DumpSemis.hs:38:8 }))])) (L (EpAnn (EpaSpan { DumpSemis.hs:(38,4)-(44,4) }) ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -964,7 +964,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1664,7 +1663,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T15279.stderr ===================================== @@ -154,7 +154,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -105,7 +105,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -95,7 +95,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -71,7 +71,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -163,7 +162,6 @@ (Just (EpaSpan { Test20297.hs:7:3-7 })) (ListNone) - [] []) (EpaComments [])) @@ -203,7 +201,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -289,7 +286,6 @@ (Just (EpaSpan { Test20297.hs:11:9-26 })) (ListNone) - [] []) (EpaComments [(L @@ -327,7 +323,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -401,7 +396,6 @@ (ListBraces (NoEpTok) (NoEpTok)) - [] []) (EpaSpan { Test20297.hs:11:19-20 })) (DoExpr @@ -517,7 +511,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -603,7 +596,6 @@ (Just (EpaSpan { Test20297.ppr.hs:5:3-7 })) (ListNone) - [] []) (EpaComments [])) @@ -637,7 +629,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -723,7 +714,6 @@ (Just (EpaSpan { Test20297.ppr.hs:9:7-24 })) (ListNone) - [] []) (EpaComments [])) @@ -755,7 +745,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -829,7 +818,6 @@ (ListBraces (NoEpTok) (NoEpTok)) - [] []) (EpaSpan { Test20297.ppr.hs:9:17-18 })) (DoExpr ===================================== testsuite/tests/printer/Test24533.stdout ===================================== @@ -521,7 +521,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1093,7 +1092,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -281,8 +281,8 @@ instance HasTrailing EpAnnSumPat where setTrailing a _ = a instance HasTrailing AnnList where - trailing a = al_trailing a - setTrailing a ts = a { al_trailing = ts } + trailing _ = [] + setTrailing a _ = a instance HasTrailing [TrailingAnn] where trailing a = a ===================================== utils/check-exact/Main.hs ===================================== @@ -524,8 +524,8 @@ changeLocalDecls libdir (L l p) = do let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) - let (EpAnn anc (AnnList (Just _) a b dd) cs) = van - let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b dd) cs) + let (EpAnn anc (AnnList (Just _) a b) cs) = van + let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b) cs) let binds' = (HsValBinds (van',w) (ValBinds noExtField (VbSig sig':VbBind decl':VbSig o':oldBinds))) return (L lm (Match an mln pats (GRHSs emptyComments rhs binds'))) @@ -552,7 +552,6 @@ changeLocalDecls2 libdir (L l p) = do let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 4) []) let an = (EpAnn anc (AnnList (Just anc2) ListNone - [] []) emptyComments, EpTok (EpaDelta noSrcSpan (SameLine 0) [])) let decls = [VbSig sig', VbBind decl'] ===================================== utils/check-exact/Transform.hs ===================================== @@ -1096,7 +1096,7 @@ oldWhereAnnotation (EpAnn anc an cs, _w) ww _oldSpan = an' -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, -- change the AnnList anchor to have the correct DP too where - (AnnList ancl p s t) = an + (AnnList ancl p s) = an w = case ww of WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) WithoutWhere -> NoEpTok @@ -1105,7 +1105,7 @@ oldWhereAnnotation (EpAnn anc an cs, _w) ww _oldSpan = an' WithWhere -> (anc, ancl) WithoutWhere -> (anc, ancl) an' = (EpAnn anc' - (AnnList ancl' p s t) + (AnnList ancl' p s) cs, w) newWhereAnnotation :: WithWhere -> (EpAnn AnnList, EpToken "where") @@ -1117,7 +1117,7 @@ newWhereAnnotation ww = (an, w) WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) WithoutWhere -> NoEpTok an = EpAnn anc - (AnnList (Just anc2) ListNone [] []) + (AnnList (Just anc2) ListNone []) emptyComments -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/58e926238f79e66e48ffbde83bd347… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/58e926238f79e66e48ffbde83bd347… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] hadrian: set the executable bit for hie-bios.bat
by Marge Bot (＠marge-bot) 16 Aug '26

16 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ca9b0b22 by mangoiv at 2026-08-15T12:41:47-04:00 hadrian: set the executable bit for hie-bios.bat - - - - - 1 changed file: - hadrian/hie-bios.bat Changes: ===================================== hadrian/hie-bios.bat ===================================== View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca9b0b22afa2e4b73e3c755823e2601… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca9b0b22afa2e4b73e3c755823e2601… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] DmdAnal: Fix maxDmdType
by Marge Bot (＠marge-bot) 16 Aug '26

16 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e3188581 by Zubin Duggal at 2026-08-15T12:41:06-04:00 DmdAnal: Fix maxDmdType We need to eta expand the smaller DmdType using defaultArgDmd, like in lubDmdType. Introduce zipDmdType as a common combinator to implement both maxDmdType and lubDmdType uniformly. fixes #27626 - - - - - 6 changed files: - + changelog.d/27626 - compiler/GHC/Types/Demand.hs - + testsuite/tests/dmdanal/should_run/M2.hs - + testsuite/tests/dmdanal/should_run/T27626.hs - + testsuite/tests/dmdanal/should_run/T27626.stdout - testsuite/tests/dmdanal/should_run/all.T Changes: ===================================== changelog.d/27626 ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Fix a bug where an argument used only by a function's stable unfolding + could still be marked absent, resulting in a runtime crash. +mrs: !16503 +issues: #27626 ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -1849,12 +1849,14 @@ botDmdEnv = mkEmptyDmdEnv botDiv exnDmdEnv :: DmdEnv exnDmdEnv = mkEmptyDmdEnv exnDiv +combineDmdEnv :: (Demand -> Demand -> Demand) -> DmdEnv -> DmdEnv -> DmdEnv +combineDmdEnv f (DE fv1 d1) (DE fv2 d2) + -- See Note [Demand env Equality] + = DE (plusVarEnv_CD f fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)) + (lubDivergence d1 d2) + lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div - where - -- See Note [Demand env Equality] - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) - lub_div = lubDivergence d1 d2 +lubDmdEnv = combineDmdEnv lubDmd addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv addVarDmdEnv env@(DE fvs div) id dmd @@ -1908,36 +1910,31 @@ instance Eq DmdType where = ds1 == ds2 -- cheap checks first && env1 == env2 +-- | The smaller 'DmdType' is eta expanded using its 'defaultArgDmd'. +-- See Note [Default demand on free variables and arguments]. +zipDmdType :: (Demand -> Demand -> Demand) -> DmdType -> DmdType -> DmdType +zipDmdType f (DmdType fv1 ds1) (DmdType fv2 ds2) + = DmdType (combineDmdEnv f fv1 fv2) (go ds1 ds2) + where + def1, def2 :: Demand -- Default argument demands for eta expansion + def1 = defaultArgDmd (de_div fv1) + def2 = defaultArgDmd (de_div fv2) + + -- If `ds1` is shorter than `ds2`, extend `ds1` with the appropriate + -- default demand `def1`; and similarly if `ds2` is shorter + go (d1:ds1') (d2:ds2') = f d1 d2 : go ds1' ds2' + go [] ds2' = map (def1 `f`) ds2' + go ds1' [] = map (`f` def2) ds1' + -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 = DmdType lub_fv lub_ds - where - n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1) = etaExpandDmdType n d1 - (DmdType fv2 ds2) = etaExpandDmdType n d2 - lub_ds = zipWithEqual lubDmd ds1 ds2 - lub_fv = lubDmdEnv fv1 fv2 +lubDmdType = zipDmdType lubDmd -- | Combine two 'DmdType's for stable unfolding analysis. -- See Note [Combining demands for stable unfoldings]. maxDmdType :: DmdType -> DmdType -> DmdType -maxDmdType (DmdType fv1 ds1) (DmdType fv2 ds2) - = DmdType combined_fv combined_ds - where - combined_fv = maxDmdEnv fv1 fv2 - combined_ds = go ds1 ds2 - -- If lists have different lengths, keep remaining ds1 (from RHS) - go rhs [] = rhs - go [] _ = [] - go (r:rhs) (u:unfs) = maxDmd r u : go rhs unfs - --- | See Note [Combining demands for stable unfoldings]. -maxDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -maxDmdEnv (DE fv1 d1) (DE fv2 d2) = DE combined_fv combined_div - where - combined_fv = plusVarEnv_CD maxDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) - combined_div = lubDivergence d1 d2 +maxDmdType = zipDmdType maxDmd discardArgDmds :: DmdType -> DmdEnv discardArgDmds (DmdType fv _) = fv ===================================== testsuite/tests/dmdanal/should_run/M2.hs ===================================== @@ -0,0 +1,28 @@ +module M2 where + +-- f's stable unfolding template is the PAP `mk g`, which is not +-- eta-expanded, so its DmdType has depth 0. The big lambda keeps the +-- template large enough that f does not certainlyWillInline, so it is +-- worker/wrappered. +{-# INLINABLE [1] f #-} +f :: Int -> Int -> Float +f = mk (\y -> succ . succ . succ . succ . succ . succ . succ . succ . succ $ y) + +-- Arity 1: the `let` does real work, so mk is not eta-expanded past it. +-- The returned function really forces x. +{-# NOINLINE mk #-} +mk :: (Int -> Int) -> Int -> Int -> Float +mk t = let s = t 1 in \dummy x -> x `seq` fromIntegral (t (dummy + s)) + +{-# INLINE mkFast #-} +mkFast :: (Int -> Int) -> Int -> Int -> Float +mkFast t = \dummy x -> fromIntegral (t dummy) + +-- Active only before phase 1: rewrites f's RHS early, but is dead by +-- the time f's stable unfolding (activation [1]) is inlined at call +-- sites. +{-# RULES "mk" [~1] forall t. mk t = mkFast t #-} + +{-# NOINLINE g #-} +g :: Int -> Int +g x = x + 1 ===================================== testsuite/tests/dmdanal/should_run/T27626.hs ===================================== @@ -0,0 +1,6 @@ +-- The raised threshold persuades GHC to inline the worker's stable +-- unfolding in this small program; a larger program does that naturally. +{-# OPTIONS_GHC -funfolding-use-threshold=400 #-} +module Main where +import M2 ( f ) +main = print (f 19 12) ===================================== testsuite/tests/dmdanal/should_run/T27626.stdout ===================================== @@ -0,0 +1 @@ +38.0 ===================================== testsuite/tests/dmdanal/should_run/all.T ===================================== @@ -36,3 +36,4 @@ test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208']) test('T25439', normal, compile_and_run, ['']) test('T26748', normal, compile_and_run, ['']) test('T26416', [extra_files(['M1.hs'])], multimod_compile_and_run, ['T26416','M1.hs']) +test('T27626', [extra_files(['M2.hs'])], multimod_compile_and_run, ['T27626','M2.hs']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e31885816b7c597ad89b05da64b21c5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e31885816b7c597ad89b05da64b21c5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] Add law in qualified strings doc
by Marge Bot (＠marge-bot) 16 Aug '26

16 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a737df91 by Brandon Chinn at 2026-08-15T12:40:25-04:00 Add law in qualified strings doc - - - - - 1 changed file: - docs/users_guide/exts/qualified_strings.rst Changes: ===================================== docs/users_guide/exts/qualified_strings.rst ===================================== @@ -15,3 +15,10 @@ The ``-XQualifiedStrings`` extension allows string literals to be qualified usin This allows more precise control over the ``fromString`` function than :extension:`OverloadedStrings`, which overloads all string literals for an entire module. If :extension:`MultilineStrings` is also enabled, ``M."""test"""`` will also work, desugaring the multiline string first, then the qualified string literal. + +Laws +~~~~ + +If the following expression typechecks, it should hold: + +* ``Data.String.fromString "str" == M."str"`` View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a737df9167b5869b8943063b9a06e95… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a737df9167b5869b8943063b9a06e95… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0