Bodigrim pushed to branch wip/nubOrd at Glasgow Haskell Compiler / GHC Commits: c12fa73e by Simon Peyton Jones at 2025-11-19T02:55:01-05:00 Make PmLit be in Ord, and use it in Map This MR addresses #26514, by changing from data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] to data PmAltConSet = PACS !(UniqDSet ConLike) !(Map PmLit PmLit) This matters when doing pattern-match overlap checking, when there is a very large set of patterns. For most programs it makes no difference at all. For the N=5000 case of the repro case in #26514, compiler mutator time (with `-fno-code`) goes from 1.9s to 0.43s. All for the price for an Ord instance for PmLit - - - - - 41b84f40 by sheaf at 2025-11-19T02:55:52-05:00 Add passing tests for #26311 and #26072 This commit adds two tests cases that now pass since landing the changes to typechecking of data constructors in b33284c7. Fixes #26072 #26311 - - - - - 1faa758a by sheaf at 2025-11-19T02:55:52-05:00 mkCast: weaken bad cast warning for multiplicity This commit weakens the warning message emitted when constructing a bad cast in mkCast to ignore multiplicity. Justification: since b33284c7, GHC uses sub-multiplicity coercions to typecheck data constructors. The coercion optimiser is free to discard these coercions, both for performance reasons, and because GHC's Core simplifier does not (yet) preserve linearity. We thus weaken 'mkCast' to use 'eqTypeIgnoringMultiplicity' instead of 'eqType', to avoid getting many spurious warnings about mismatched multiplicities. - - - - - bddcf63d by Andrew Lelechenko at 2025-11-19T22:28:46+00:00 Add nubOrd / nubOrdBy to Data.List and Data.List.NonEmpty As per https://github.com/haskell/core-libraries-committee/issues/336 - - - - - 19 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Types/SourceText.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NonEmpty.hs - + libraries/base/src/Data/List/NubOrdSet.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - + testsuite/tests/linear/should_run/T26311.hs - + testsuite/tests/linear/should_run/T26311.stdout - testsuite/tests/linear/should_run/all.T - testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr - + testsuite/tests/rep-poly/T26072b.hs - testsuite/tests/rep-poly/all.T Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -78,7 +78,7 @@ import GHC.Core.Type as Type import GHC.Core.Predicate( isEqPred ) import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.FamInstEnv -import GHC.Core.TyCo.Compare( eqType, eqTypeX ) +import GHC.Core.TyCo.Compare( eqType, eqTypeX, eqTypeIgnoringMultiplicity ) import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.TyCon @@ -275,7 +275,7 @@ mkCast expr co = assertPpr (coercionRole co == Representational) (text "coercion" <+> ppr co <+> text "passed to mkCast" <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $ - warnPprTrace (not (coercionLKind co `eqType` exprType expr)) "Bad cast" + warnPprTrace (not (coercionLKind co `eqTypeIgnoringMultiplicity` exprType expr)) "Bad cast" (vcat [ text "Coercion LHS kind does not match enclosed expression type" , text "co:" <+> ppr co , text "coercionLKind:" <+> ppr (coercionLKind co) ===================================== compiler/GHC/HsToCore/Pmc/Solver/Types.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} -- | Domain types used in "GHC.HsToCore.Pmc.Solver". -- The ultimate goal is to define 'Nabla', which models normalised refinement @@ -32,7 +33,7 @@ module GHC.HsToCore.Pmc.Solver.Types ( PmEquality(..), eqPmAltCon, -- *** Operations on 'PmLit' - literalToPmLit, negatePmLit, overloadPmLit, + literalToPmLit, negatePmLit, pmLitAsStringLit, coreExprAsPmLit ) where @@ -51,13 +52,12 @@ import GHC.Core.ConLike import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import GHC.Utils.Misc (lastMaybe) -import GHC.Data.List.SetOps (unionLists) import GHC.Data.Maybe import GHC.Core.Type import GHC.Core.TyCon import GHC.Types.Literal import GHC.Core -import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCo.Compare( eqType, nonDetCmpType ) import GHC.Core.Map.Expr import GHC.Core.Utils (exprType) import GHC.Builtin.Names @@ -69,15 +69,14 @@ import GHC.Types.CompleteMatch import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit , fractionalLitFromRational , FractionalExponentBase(..)) + import Numeric (fromRat) -import Data.Foldable (find) import Data.Ratio +import Data.List( find ) +import qualified Data.Map as FM import GHC.Real (Ratio(..)) -import qualified Data.Semigroup as Semi - --- import GHC.Driver.Ppr +import qualified Data.Semigroup as S --- -- * Normalised refinement types -- @@ -358,6 +357,13 @@ lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of | Just sol <- find isDataConSolution pos -> Just sol | otherwise -> Just x + +{- ********************************************************************* +* * + PmLit and PmLitValue +* * +********************************************************************* -} + -------------------------------------------------------------------------------- -- The rest is just providing an IR for (overloaded!) literals and AltCons that -- sits between Hs and Core. We need a reliable way to detect and determine @@ -376,13 +382,64 @@ data PmLitValue = PmLitInt Integer | PmLitRat Rational | PmLitChar Char - -- We won't actually see PmLitString in the oracle since we desugar strings to - -- lists | PmLitString FastString + -- We won't actually see PmLitString in the oracle + -- since we desugar strings to lists + + -- Overloaded literals | PmLitOverInt Int {- How often Negated? -} Integer | PmLitOverRat Int {- How often Negated? -} FractionalLit | PmLitOverString FastString +-- | Syntactic equality. +-- We want (Ord PmLit) so that we can use (Map PmLit x) in `PmAltConSet` +instance Eq PmLit where + a == b = (a `compare` b) == EQ +instance Ord PmLit where + compare = cmpPmLit + +cmpPmLit :: PmLit -> PmLit -> Ordering +-- This function does "syntactic comparison": +-- For overloaded literals, compare the type and value +-- For non-overloaded literals, just compare the values +-- But it treats (say) +-- (PmLit Bool (PmLitOverInt 1)) +-- (PmLit Bool (PmLitOverInt 2)) +-- as un-equal, even through (fromInteger @Bool 1) +-- could be the same as (fromInteger @Bool 2) +cmpPmLit (PmLit { pm_lit_ty = t1, pm_lit_val = val1 }) + (PmLit { pm_lit_ty = t2, pm_lit_val = val2 }) + = case (val1,val2) of + (PmLitInt i1, PmLitInt i2) -> i1 `compare` i2 + (PmLitRat r1, PmLitRat r2) -> r1 `compare` r2 + (PmLitChar c1, PmLitChar c2) -> c1 `compare` c2 + (PmLitString s1, PmLitString s2) -> s1 `uniqCompareFS` s2 + (PmLitOverInt n1 i1, PmLitOverInt n2 i2) -> (n1 `compare` n2) S.<> + (i1 `compare` i2) S.<> + (t1 `nonDetCmpType` t2) + (PmLitOverRat n1 r1, PmLitOverRat n2 r2) -> (n1 `compare` n2) S.<> + (r1 `compare` r2) S.<> + (t1 `nonDetCmpType` t2) + (PmLitOverString s1, PmLitOverString s2) -> (s1 `uniqCompareFS` s2) S.<> + (t1 `nonDetCmpType` t2) + (PmLitInt {}, _) -> LT + (PmLitRat {}, PmLitInt {}) -> GT + (PmLitRat {}, _) -> LT + (PmLitChar {}, PmLitInt {}) -> GT + (PmLitChar {}, PmLitRat {}) -> GT + (PmLitChar {}, _) -> LT + (PmLitString {}, PmLitInt {}) -> GT + (PmLitString {}, PmLitRat {}) -> GT + (PmLitString {}, PmLitChar {}) -> GT + (PmLitString {}, _) -> LT + + (PmLitOverString {}, _) -> GT + (PmLitOverRat {}, PmLitOverString{}) -> LT + (PmLitOverRat {}, _) -> GT + (PmLitOverInt {}, PmLitOverString{}) -> LT + (PmLitOverInt {}, PmLitOverRat{}) -> LT + (PmLitOverInt {}, _) -> GT + -- | Undecidable semantic equality result. -- See Note [Undecidable Equality for PmAltCons] data PmEquality @@ -406,7 +463,10 @@ eqPmLit :: PmLit -> PmLit -> PmEquality eqPmLit (PmLit t1 v1) (PmLit t2 v2) -- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined | not (t1 `eqType` t2) = Disjoint - | otherwise = go v1 v2 + | otherwise = eqPmLitValue v1 v2 + +eqPmLitValue :: PmLitValue -> PmLitValue -> PmEquality +eqPmLitValue v1 v2 = go v1 v2 where go (PmLitInt i1) (PmLitInt i2) = decEquality (i1 == i2) go (PmLitRat r1) (PmLitRat r2) = decEquality (r1 == r2) @@ -420,10 +480,6 @@ eqPmLit (PmLit t1 v1) (PmLit t2 v2) | s1 == s2 = Equal go _ _ = PossiblyOverlap --- | Syntactic equality. -instance Eq PmLit where - a == b = eqPmLit a b == Equal - -- | Type of a 'PmLit' pmLitType :: PmLit -> Type pmLitType (PmLit ty _) = ty @@ -445,34 +501,47 @@ eqConLike (PatSynCon psc1) (PatSynCon psc2) = Equal eqConLike _ _ = PossiblyOverlap + +{- ********************************************************************* +* * + PmAltCon and PmAltConSet +* * +********************************************************************* -} + -- | Represents the head of a match against a 'ConLike' or literal. -- Really similar to 'GHC.Core.AltCon'. data PmAltCon = PmAltConLike ConLike | PmAltLit PmLit -data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] +data PmAltConSet = PACS !(UniqDSet ConLike) + !(FM.Map PmLit PmLit) +-- We use a (FM.Map PmLit PmLit) here, at the cost of requiring an Ord +-- instance for PmLit, because in extreme cases the set of PmLits can be +-- very large. See #26514. emptyPmAltConSet :: PmAltConSet -emptyPmAltConSet = PACS emptyUniqDSet [] +emptyPmAltConSet = PACS emptyUniqDSet FM.empty isEmptyPmAltConSet :: PmAltConSet -> Bool -isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits +isEmptyPmAltConSet (PACS cls lits) + = isEmptyUniqDSet cls && FM.null lits -- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to -- the given 'PmAltCon' according to 'eqPmAltCon'. elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls -elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits +elemPmAltConSet (PmAltLit lit) (PACS _ lits) = isJust (FM.lookup lit lits) extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet extendPmAltConSet (PACS cls lits) (PmAltConLike cl) = PACS (addOneToUniqDSet cls cl) lits extendPmAltConSet (PACS cls lits) (PmAltLit lit) - = PACS cls (unionLists lits [lit]) + = PACS cls (FM.insert lit lit lits) pmAltConSetElems :: PmAltConSet -> [PmAltCon] pmAltConSetElems (PACS cls lits) - = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits + = map PmAltConLike (uniqDSetToList cls) ++ + FM.foldr ((:) . PmAltLit) [] lits instance Outputable PmAltConSet where ppr = ppr . pmAltConSetElems ===================================== compiler/GHC/Types/SourceText.hs ===================================== @@ -188,6 +188,7 @@ data FractionalLit = FL } deriving (Data, Show) -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on + -- Eq and Ord instances are done explicitly -- See Note [FractionalLit representation] in GHC.HsToCore.Match.Literal data FractionalExponentBase ===================================== libraries/base/base.cabal.in ===================================== @@ -303,6 +303,7 @@ Library , GHC.JS.Foreign.Callback other-modules: + Data.List.NubOrdSet System.CPUTime.Unsupported System.CPUTime.Utils if os(windows) ===================================== libraries/base/changelog.md ===================================== @@ -10,6 +10,7 @@ * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) * Remove extra laziness from `Data.Bifunctor.Bifunctor` instances for all tuples to have the same laziness as their `Data.Functor.Functor` counterparts (i.e. they became more strict than before) ([CLC proposal #339](https://github.com/haskell/core-libraries-committee/issues/339)) * Adjust the strictness of `Data.List.iterate'` to be more reasonable: every element of the output list is forced to WHNF when the `(:)` containing it is forced. ([CLC proposal #335)](https://github.com/haskell/core-libraries-committee/issues/335) + * Add `nubOrd` / `nubOrdBy` to `Data.List` and `Data.List.NonEmpty`. ([CLC proposal #336](https://github.com/haskell/core-libraries-committee/issues/336)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/src/Data/List.hs ===================================== @@ -137,6 +137,7 @@ module Data.List unwords, -- ** \"Set\" operations nub, + nubOrd, delete, (\\), union, @@ -157,6 +158,7 @@ module Data.List -- *** User-supplied equality (replacing an @Eq@ context) -- | The predicate is assumed to define an equivalence. nubBy, + nubOrdBy, deleteBy, deleteFirstsBy, unionBy, @@ -180,12 +182,14 @@ module Data.List ) where import GHC.Internal.Data.Bool (otherwise) +import GHC.Internal.Data.Function (const) import GHC.Internal.Data.List import GHC.Internal.Data.List.NonEmpty (NonEmpty(..)) -import GHC.Internal.Data.Ord (Ordering(..), (<), (>)) +import GHC.Internal.Data.Ord (Ord, compare, Ordering(..), (<), (>)) import GHC.Internal.Int (Int) import GHC.Internal.Num ((-)) import GHC.List (build) +import qualified Data.List.NubOrdSet as NubOrdSet inits1, tails1 :: [a] -> [NonEmpty a] @@ -282,3 +286,24 @@ compareLength xs n (\m -> if m > 0 then LT else EQ) xs n + +-- | Same as 'nub', but asymptotically faster, taking only /O/(/n/ log /n/) time. +-- +-- @since 4.23.0.0 +nubOrd :: Ord a => [a] -> [a] +nubOrd = nubOrdBy compare +{-# INLINE nubOrd #-} + +-- | Overloaded version of 'Data.List.nubOrd'. +-- +-- The supplied comparison relation is supposed to be reflexive, transitive +-- and antisymmetric, same as for 'sortBy'. +-- +-- @since 4.23.0.0 +nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a] +nubOrdBy cmp xs = foldr + (\x acc seen -> if NubOrdSet.member cmp x seen then acc seen else x : acc (NubOrdSet.insert cmp x seen)) + (const []) + xs + NubOrdSet.empty +{-# INLINE nubOrdBy #-} ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -94,7 +94,9 @@ module Data.List.NonEmpty ( , isPrefixOf -- :: Eq a => [a] -> NonEmpty a -> Bool -- * \"Set\" operations , nub -- :: Eq a => NonEmpty a -> NonEmpty a + , nubOrd -- :: Ord a => NonEmpty a -> NonEmpty a , nubBy -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a + , nubOrdBy -- :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a -- * Indexing streams , (!!) -- :: NonEmpty a -> Int -> a -- * Zipping and unzipping streams @@ -119,6 +121,7 @@ import qualified Prelude import Control.Applicative (Applicative (..), Alternative (many)) import qualified Data.List as List +import qualified Data.List.NubOrdSet as NubOrdSet import qualified Data.Maybe as List (mapMaybe) import GHC.Internal.Data.Foldable hiding (length, toList) import qualified GHC.Internal.Data.Foldable as Foldable @@ -577,6 +580,24 @@ nub = nubBy (==) nubBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a nubBy eq (a :| as) = a :| List.nubBy eq (List.filter (\b -> not (eq a b)) as) +-- | Same as 'nub', but asymptotically faster, taking only /O/(/n/ log /n/) time. +-- +-- @since 4.23.0.0 +nubOrd :: Ord a => NonEmpty a -> NonEmpty a +nubOrd = nubOrdBy compare +{-# INLINE nubOrd #-} + +-- | Overloaded version of 'Data.List.NonEmpty.nubOrd'. +-- +-- @since 4.23.0.0 +nubOrdBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a +nubOrdBy cmp (y :| ys) = y :| foldr + (\x acc seen -> if NubOrdSet.member cmp x seen then acc seen else x : acc (NubOrdSet.insert cmp x seen)) + (const []) + ys + (NubOrdSet.insert cmp y NubOrdSet.empty) +{-# INLINE nubOrdBy #-} + -- | 'transpose' for 'NonEmpty', behaves the same as 'GHC.Internal.Data.List.transpose' -- The rows/columns need not be the same length, in which case -- > transpose . transpose /= id ===================================== libraries/base/src/Data/List/NubOrdSet.hs ===================================== @@ -0,0 +1,81 @@ +-- This is an internal module with a naive set implementation, +-- solely for the purposes of `Data.List.{,NonEmpty.}nubOrd{,By}`. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Data.List.NubOrdSet ( + NubOrdSet, + empty, + member, + insert, +) where + +import GHC.Internal.Data.Bool (Bool(..)) +import GHC.Internal.Data.Function ((.)) +import GHC.Internal.Data.Ord (Ordering(..)) + +-- | Implemented as a red-black tree, a la Okasaki. +data NubOrdSet a + = Empty + | NodeRed !(NubOrdSet a) !a !(NubOrdSet a) + | NodeBlack !(NubOrdSet a) !a !(NubOrdSet a) + +empty :: NubOrdSet a +empty = Empty + +member :: (a -> a -> Ordering) -> a -> NubOrdSet a -> Bool +member cmp = member' + where + member' !x = go + where + go = \case + Empty -> False + NodeRed left center right -> chooseWay left center right + NodeBlack left center right -> chooseWay left center right + + chooseWay left center right = case cmp x center of + LT -> go left + EQ -> True + GT -> go right +{-# INLINE member #-} + +insert :: (a -> a -> Ordering) -> a -> NubOrdSet a -> NubOrdSet a +insert cmp = insert' + where + insert' !x = blacken . go + where + go node = case node of + Empty -> NodeRed Empty x Empty + NodeRed left center right -> case cmp x center of + LT -> NodeRed (go left) center right + EQ -> node + GT -> NodeRed left center (go right) + NodeBlack left center right -> case cmp x center of + LT -> balanceBlackLeft (go left) center right + EQ -> node + GT -> balanceBlackRight left center (go right) + + blacken node = case node of + Empty -> Empty + NodeRed left center right -> NodeBlack left center right + NodeBlack{} -> node +{-# INLINE insert #-} + +balanceBlackLeft :: NubOrdSet a -> a -> NubOrdSet a -> NubOrdSet a +balanceBlackLeft (NodeRed (NodeRed a b c) d e) f g = + NodeRed (NodeBlack a b c) d (NodeBlack e f g) +balanceBlackLeft (NodeRed a b (NodeRed c d e)) f g = + NodeRed (NodeBlack a b c) d (NodeBlack e f g) +balanceBlackLeft left center right = + NodeBlack left center right +{-# INLINE balanceBlackLeft #-} + +balanceBlackRight :: NubOrdSet a -> a -> NubOrdSet a -> NubOrdSet a +balanceBlackRight a b (NodeRed (NodeRed c d e) f g) = + NodeRed (NodeBlack a b c) d (NodeBlack e f g) +balanceBlackRight a b (NodeRed c d (NodeRed e f g)) = + NodeRed (NodeBlack a b c) d (NodeBlack e f g) +balanceBlackRight left center right = + NodeBlack left center right +{-# INLINE balanceBlackRight #-} ===================================== libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs ===================================== @@ -499,16 +499,7 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- name 'nub' means \`essence\'.) It is a special case of 'nubBy', which allows -- the programmer to supply their own equality test. -- --- --- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package --- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtil...)), --- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of --- distinct elements in the list. --- --- Another approach to speed up 'nub' is to use --- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't --- preserve the order. +-- If there exists @instance Ord a@, it's faster to use 'Data.List.nubOrd'. -- -- ==== __Examples__ -- ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1379,6 +1379,8 @@ module Data.List where notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a] nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a] + nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a] + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a] null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a]) @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a + nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a]) permutations :: forall a. [a] -> NonEmpty [a] permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a) ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1379,6 +1379,8 @@ module Data.List where notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a] nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a] + nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a] + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a] null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a]) @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a + nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a]) permutations :: forall a. [a] -> NonEmpty [a] permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a) ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1379,6 +1379,8 @@ module Data.List where notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a] nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a] + nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a] + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a] null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a]) @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a + nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a]) permutations :: forall a. [a] -> NonEmpty [a] permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a) ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1379,6 +1379,8 @@ module Data.List where notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a] nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a] + nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a] + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a] null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a]) @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a + nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a]) permutations :: forall a. [a] -> NonEmpty [a] permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a) ===================================== testsuite/tests/linear/should_run/T26311.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts ( Int# ) + +expensive :: Int -> Int# +expensive 0 = 2# +expensive i = expensive (i-1) + +data D = MkD Int# Int + +f :: a -> Bool +f _ = False +{-# NOINLINE f #-} + +{-# RULES "f/MkD" forall x. f (MkD x) = True #-} + +bar :: Bool +bar = f (MkD (expensive 10)) + +main :: IO () +main = print bar ===================================== testsuite/tests/linear/should_run/T26311.stdout ===================================== @@ -0,0 +1 @@ +True ===================================== testsuite/tests/linear/should_run/all.T ===================================== @@ -1,2 +1,3 @@ test('LinearTypeable', normal, compile_and_run, ['']) +test('T26311', normal, compile_and_run, ['-O1']) test('LinearGhci', normal, ghci_script, ['LinearGhci.script']) ===================================== testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr ===================================== @@ -1,4 +1,3 @@ - pmcOrPats.hs:10:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘g’: Patterns of type ‘T’, ‘U’ not matched: A W @@ -18,7 +17,7 @@ pmcOrPats.hs:15:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] pmcOrPats.hs:17:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘z’: - Patterns of type ‘a’ not matched: p where p is not one of {3, 1, 2} + Patterns of type ‘a’ not matched: p where p is not one of {1, 2, 3} pmcOrPats.hs:19:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] Pattern match is redundant @@ -43,3 +42,4 @@ pmcOrPats.hs:21:1: warning: [GHC-61505] • Patterns reported as unmatched might actually be matched Suggested fix: Increase the limit or resolve the warnings to suppress this message. + ===================================== testsuite/tests/rep-poly/T26072b.hs ===================================== @@ -0,0 +1,78 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +module T26072b where + +-- base +import Data.Kind +import GHC.TypeNats +import GHC.Exts + ( TYPE, RuntimeRep(..), LiftedRep + , proxy# + ) + +-------------------------------------------------------------------------------- + +-- Stub for functions in 'primitive' (to avoid dependency) +type PrimArray :: Type -> Type +data PrimArray a = MkPrimArray + +indexPrimArray :: PrimArray a -> Int -> a +indexPrimArray _ _ = error "unimplemented" +{-# NOINLINE indexPrimArray #-} + +-------------------------------------------------------------------------------- + +int :: forall n. KnownNat n => Int +int = fromIntegral ( natVal' @n proxy# ) + +type Fin :: Nat -> Type +newtype Fin n = Fin { getFin :: Int } + +-- Vector +type V :: Nat -> Type -> Type +newtype V n a = V ( PrimArray a ) + +-- Matrix +type M :: Nat -> Type -> Type +newtype M n a = M ( PrimArray a ) + +type IndexRep :: (Type -> Type) -> RuntimeRep +type family IndexRep f +class Ix f where + type Index f :: TYPE (IndexRep f) + (!) :: f a -> Index f -> a + infixl 9 ! + +type instance IndexRep ( V n ) = LiftedRep +instance Ix ( V n ) where + type Index ( V n ) = Fin n + V v ! Fin !i = indexPrimArray v i + {-# INLINE (!) #-} + +type instance IndexRep ( M m ) = TupleRep [ LiftedRep, LiftedRep ] + +instance KnownNat n => Ix ( M n ) where + type Index ( M n ) = (# Fin n, Fin n #) + M m ! (# Fin !i, Fin !j #) = indexPrimArray m ( i + j * int @n ) + {-# INLINE (!) #-} + +rowCol :: forall n a. ( KnownNat n, Num a ) => Fin n -> M n a -> V n a -> a +rowCol i m v = go 0 ( Fin 0 ) + where + n = int @n + go :: a -> Fin n -> a + go !acc j@( Fin !j_ ) + | j_ >= n + = acc + | otherwise + = go ( acc + m ! (# i , j #) * v ! j ) ( Fin ( j_ + 1 ) ) ===================================== testsuite/tests/rep-poly/all.T ===================================== @@ -127,6 +127,7 @@ test('T17536b', normal, compile, ['']) ## test('T21650_a', js_broken(26578), compile, ['-Wno-deprecated-flags']) ## test('T21650_b', js_broken(26578), compile, ['-Wno-deprecated-flags']) ## test('T26072', js_broken(26578), compile, ['']) ## +test('T26072b', js_broken(26578), compile, ['']) ## test('RepPolyArgument2', normal, compile, ['']) ## test('RepPolyCase2', js_broken(26578), compile, ['']) ## test('RepPolyRule3', normal, compile, ['']) ## View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/de697b64482f93063f01b760ab898fb... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/de697b64482f93063f01b760ab898fb... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Bodigrim (＠Bodigrim)