Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

12 changed files:

Changes:

  • changelog.d/elem-via-foldr-27096
    1 
    +section: base
    2 
    +synopsis: Reimplement ``Data.List.elem`` and ``notElem`` using ``foldr`` to enable better specialization.
    3 
    +issues: #27096
    4 
    +mrs: !15793

  • compiler/GHC/Parser/Lexer.x
    ... ... @@ -2274,8 +2274,9 @@ tok_quoted_label span buf len _buf2 = do
    2274 2274 
     tok_qstrings :: Action -> Action
    2275 2275 
     tok_qstrings lex_str span0 buf0 len0 endBuf0 = do
    2276 2276 
       let modName = ModuleName $ lexemeToFastString buf0 modNameLen
    2277 
    -  (src, meta, s) <- unITstring <$> lex_str strSpan strBuf strLen endBuf0
    2278 
    -  pure $ L span0 $ ITstring src meta{strMetaQualified = Just modName} s
    2277 
    +  (span1, src, meta, s) <- unITstring <$> lex_str strSpan strBuf strLen endBuf0
    2278 
    +  let span2 = mkPsSpan (psSpanStart span0) (psSpanEnd span1)
    2279 
    +  pure $ L span2 $ ITstring src meta{strMetaQualified = Just modName} s
    2279 2280 
       where
    2280 2281 
         -- The buffer/span starting at the string literal
    2281 2282 
         (strBuf, strSpanStart) =
    ... ... @@ -2298,7 +2299,7 @@ tok_qstrings lex_str span0 buf0 len0 endBuf0 = do
    2298 2299 
         strSpan = mkPsSpan strSpanStart (psSpanEnd span0)
    2299 2300
    2300 2301 
         unITstring = \case
    2301 
    -      L _ (ITstring src meta s) -> (src, meta, s)
    2302 
    +      L span1 (ITstring src meta s) -> (span1, src, meta, s)
    2302 2303 
           tok -> panic $ "tok_qstrings got unexpected token: " ++ show tok
    2303 2304
    2304 2305 
     tok_char :: Action

  • docs/users_guide/exts/stolen_syntax.rst
    ... ... @@ -50,7 +50,7 @@ The following syntax is stolen:
    50 50
    51 51 
         Stolen by: :extension:`Arrows`
    52 52
    53 
    -``?varid``
    53 
    +``?⟨varid⟩``
    54 54 
         .. index::
    55 55 
            single: implicit parameters
    56 56
    ... ... @@ -77,17 +77,20 @@ The following syntax is stolen:
    77 77
    78 78 
         Stolen by: :extension:`QuasiQuotes`
    79 79
    80 
    -⟨varid⟩``#``, ⟨char⟩``#``, ⟨string⟩``#``, ⟨integer⟩``#``, ⟨float⟩``#``, ⟨float⟩``##``
    80 
    +``⟨varid⟩#``, ``⟨char⟩#``, ``⟨string⟩#``, ``⟨integer⟩#``, ``⟨float⟩#``, ``⟨float⟩##``
    81 81 
         Stolen by: :extension:`MagicHash`
    82 82
    83 
    -⟨integer⟩, ``#(Int|Word)(8|16|32|64)?``
    83 
    +``⟨integer⟩#(Int|Word)(8|16|32|64)?``
    84 84 
         Stolen by: :extension:`ExtendedLiterals`
    85 85
    86 86 
     ``(#``, ``#)``
    87 87 
         Stolen by: :extension:`UnboxedTuples`
    88 88
    89 
    -⟨varid⟩, ``!``, ⟨varid⟩
    90 
    -    Stolen by: :extension:`BangPatterns`
    89 
    +``⟨varid⟩ !⟨varid⟩``
    90 
    +    Stolen by: :extension:`BangPatterns`. Only when there are whitespaces before
    91 
    +    ``!`` and no whitespace after ``!``, it is interpreted as :extension:`BangPatterns`. Other
    92 
    +    cases such as ``⟨varid⟩!⟨varid⟩``, ``⟨varid⟩ ! ⟨varid⟩``, and ``⟨varid⟩! ⟨varid⟩``, are
    93 
    +    interpreted as infix operators.
    91 94
    92 95 
     ``pattern``
    93 96 
         Stolen by: :extension:`PatternSynonyms`

  • libraries/base/changelog.md
    ... ... @@ -2,6 +2,7 @@
    2 2
    3 3 
     ## 4.24.0.0 *TBA*
    4 4 
       * Add `Bounded` instances for `Double`, `Float`, `CDouble` and `CFloat`. ([CLC proposal #402](https://github.com/haskell/core-libraries-committee/issues/402))
    5 
    +  * Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412))
    5 6
    6 7 
     ## 4.23.0.0 *TBA*
    7 8 
       * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370))

  • libraries/base/tests/perf/ElemNoFusion_O1.stderr
    1 
    -noFusionElemSort = \ x x1 -> elem $fEqInt x (actualSort gtInt x1)
    1 
    +noFusionElemSort
    2 
    +  = \ x x1 ->
    3 
    +      joinrec {
    4 
    +        go1 ds
    5 
    +          = case ds of {
    6 
    +              [] -> False;
    7 
    +              : y ys ->
    8 
    +                case x of { I# x2 ->
    9 
    +                case y of { I# y1 ->
    10 
    +                case ==# x2 y1 of {
    11 
    +                  __DEFAULT -> jump go1 ys;
    12 
    +                  1# -> True
    13 
    +                }
    14 
    +                }
    15 
    +                }
    16 
    +            }; } in
    17 
    +      jump go1 (actualSort gtInt x1)
    2 18
    3 19 
     noFusionElemNonEmptyToList
    4 
    -  = \ x x1 -> case x1 of { :| a1 as -> elem $fEqInt x (: a1 as) }
    20 
    +  = \ x x1 ->
    21 
    +      case x1 of { :| a1 as ->
    22 
    +      joinrec {
    23 
    +        go1 ds
    24 
    +          = case ds of {
    25 
    +              [] -> False;
    26 
    +              : y ys ->
    27 
    +                case x of { I# x2 ->
    28 
    +                case y of { I# y1 ->
    29 
    +                case ==# x2 y1 of {
    30 
    +                  __DEFAULT -> jump go1 ys;
    31 
    +                  1# -> True
    32 
    +                }
    33 
    +                }
    34 
    +                }
    35 
    +            }; } in
    36 
    +      jump go1 (: a1 as)
    37 
    +      }
    5 38

  • libraries/base/tests/perf/ElemNoFusion_O2.stderr
    1 
    -noFusionElemSort = \ x x1 -> elem $fEqInt x (actualSort gtInt x1)
    1 
    +noFusionElemSort
    2 
    +  = \ x x1 ->
    3 
    +      case actualSort gtInt x1 of {
    4 
    +        [] -> False;
    5 
    +        : y ys ->
    6 
    +          case x of { I# x2 ->
    7 
    +          case y of { I# y1 ->
    8 
    +          case ==# x2 y1 of {
    9 
    +            __DEFAULT ->
    10 
    +              joinrec {
    11 
    +                go1 ds
    12 
    +                  = case ds of {
    13 
    +                      [] -> False;
    14 
    +                      : y2 ys1 ->
    15 
    +                        case y2 of { I# y3 ->
    16 
    +                        case ==# x2 y3 of {
    17 
    +                          __DEFAULT -> jump go1 ys1;
    18 
    +                          1# -> True
    19 
    +                        }
    20 
    +                        }
    21 
    +                    }; } in
    22 
    +              jump go1 ys;
    23 
    +            1# -> True
    24 
    +          }
    25 
    +          }
    26 
    +          }
    27 
    +      }
    2 28
    3 29 
     noFusionElemNonEmptyToList
    4 
    -  = \ x x1 -> case x1 of { :| a1 as -> elem $fEqInt x (: a1 as) }
    30 
    +  = \ x x1 ->
    31 
    +      case x1 of { :| a1 as ->
    32 
    +      case x of { I# x2 ->
    33 
    +      case a1 of { I# y ->
    34 
    +      case ==# x2 y of {
    35 
    +        __DEFAULT ->
    36 
    +          joinrec {
    37 
    +            go1 ds
    38 
    +              = case ds of {
    39 
    +                  [] -> False;
    40 
    +                  : y1 ys ->
    41 
    +                    case y1 of { I# y2 ->
    42 
    +                    case ==# x2 y2 of {
    43 
    +                      __DEFAULT -> jump go1 ys;
    44 
    +                      1# -> True
    45 
    +                    }
    46 
    +                    }
    47 
    +                }; } in
    48 
    +          jump go1 as;
    49 
    +        1# -> True
    50 
    +      }
    51 
    +      }
    52 
    +      }
    53 
    +      }
    5 54

  • libraries/ghc-internal/src/GHC/Internal/List.hs
    ... ... @@ -1517,14 +1517,9 @@ all p (x:xs) = p x && all p xs
    1517 1517 
     --
    1518 1518 
     -- >>> 3 `elem` [4..]
    1519 1519 
     -- * Hangs forever *
    1520 
    -elem                    :: (Eq a) => a -> [a] -> Bool
    1521 
    -elem _ []       = False
    1522 
    -elem x (y:ys)   = x==y || elem x ys
    1523 
    -{-# NOINLINE [1] elem #-}
    1524 
    -{-# RULES
    1525 
    -"elem/build"    forall x (g :: forall b . (a -> b -> b) -> b -> b)
    1526 
    -   . elem x (build g) = g (\ y r -> (x == y) || r) False
    1527 
    - #-}
    1520 
    +elem :: Eq a => a -> [a] -> Bool
    1521 
    +elem x = foldr (\y r -> x == y || r) False
    1522 
    +{-# INLINE elem #-}
    1528 1523
    1529 1524 
     -- | 'notElem' is the negation of 'elem'.
    1530 1525 
     --
    ... ... @@ -1544,14 +1539,9 @@ elem x (y:ys) = x==y || elem x ys
    1544 1539 
     --
    1545 1540 
     -- >>> 3 `notElem` [4..]
    1546 1541 
     -- * Hangs forever *
    1547 
    -notElem                 :: (Eq a) => a -> [a] -> Bool
    1548 
    -notElem _ []    =  True
    1549 
    -notElem x (y:ys)=  x /= y && notElem x ys
    1550 
    -{-# NOINLINE [1] notElem #-}
    1551 
    -{-# RULES
    1552 
    -"notElem/build" forall x (g :: forall b . (a -> b -> b) -> b -> b)
    1553 
    -   . notElem x (build g) = g (\ y r -> (x /= y) && r) True
    1554 
    - #-}
    1542 
    +notElem :: Eq a => a -> [a] -> Bool
    1543 
    +notElem x = foldr (\y r -> x /= y && r) True
    1544 
    +{-# INLINE notElem #-}
    1555 1545
    1556 1546 
     -- | \(\mathcal{O}(n)\). 'lookup' @key assocs@ looks up a key in an association
    1557 1547 
     -- list.

  • testsuite/tests/printer/Makefile
    ... ... @@ -907,6 +907,11 @@ Test25885:
    907 907 
     	$(CHECK_PPR)   $(LIBDIR) Test25885.hs
    908 908 
     	$(CHECK_EXACT) $(LIBDIR) Test25885.hs
    909 909
    910 
    +.PHONY: Test27291
    911 
    +Test27291:
    912 
    +	$(CHECK_PPR)   $(LIBDIR) Test27291.hs
    913 
    +	$(CHECK_EXACT) $(LIBDIR) Test27291.hs
    914 
    +
    910 915 
     .PHONY: TestLevelImports
    911 916 
     TestLevelImports:
    912 917 
     	$(CHECK_PPR)   $(LIBDIR) TestLevelImports.hs
    ... ... @@ -922,3 +927,8 @@ TestNamedDefaults:
    922 927 
     PprModifiers:
    923 928 
     	$(CHECK_PPR)   $(LIBDIR) PprModifiers.hs
    924 929 
     	$(CHECK_EXACT) $(LIBDIR) PprModifiers.hs
    930 
    +
    931 
    +.PHONY: PprQualifiedStrings
    932 
    +PprQualifiedStrings:
    933 
    +	$(CHECK_PPR)   $(LIBDIR) PprQualifiedStrings.hs
    934 
    +	$(CHECK_EXACT) $(LIBDIR) PprQualifiedStrings.hs

  • testsuite/tests/printer/PprQualifiedStrings.hs
    1 
    +{-# LANGUAGE MultilineStrings #-}
    2 
    +{-# LANGUAGE QualifiedStrings #-}
    3 
    +{-# LANGUAGE TemplateHaskell #-}
    4 
    +
    5 
    +-- These are harvested from ../qualified-strings
    6 
    +
    7 
    +module PprQualifiedStrings where
    8 
    +
    9 
    +import Data.Typeable (Typeable, typeOf)
    10 
    +import qualified Example.ByteStringAscii as Ascii
    11 
    +import qualified Example.ByteStringUtf8 as Utf8
    12 
    +import qualified Example.Text as Text
    13 
    +
    14 
    +exprs :: IO ()
    15 
    +exprs = do
    16 
    +  inspect "I'm a String" -- would be an ambiguous type error with OverloadedStrings
    17 
    +  inspect Text."I'm a Text"
    18 
    +  inspect Ascii."I'm an ASCII bytestring: 語"
    19 
    +  inspect Utf8."I'm a UTF8 bytestring: 語"
    20 
    +
    21 
    +  inspect """
    22 
    +    I'm a multiline
    23 
    +    String value
    24 
    +    !
    25 
    +  """
    26 
    +
    27 
    +  inspect Text."""
    28 
    +    I'm a multiline
    29 
    +    Text value
    30 
    +    !
    31 
    +  """
    32 
    +
    33 
    +  inspect Text .  """
    34 
    +    I'm a multiline
    35 
    +    Text value
    36 
    +  """
    37 
    +
    38 
    +    inspect Text .
    39 
    +      """
    40 
    +      I'm a multiline
    41 
    +      Text value
    42 
    +      """
    43 
    +
    44 
    +pats :: IO ()
    45 
    +pats = do
    46 
    +  let text = Text."foo" :: Text
    47 
    +  case text of
    48 
    +    Text."foo" -> putStrLn "Text.\"foo\" matched"
    49 
    +    _ -> putStrLn "Text.\"foo\" did not match"
    50 
    +
    51 
    +  let ascii = Ascii."語" :: ByteString
    52 
    +  case ascii of
    53 
    +    Ascii."語" -> putStrLn "Ascii.\"語\" matched"
    54 
    +    _ -> putStrLn "Ascii.\"語\" did not match"
    55 
    +
    56 
    +  let utf = Utf8."語" :: ByteString
    57 
    +  case utf of
    58 
    +    Utf8."語" -> putStrLn "Utf8.\"語\" matched"
    59 
    +    _ -> putStrLn "Utf8.\"語\" did not match"
    60 
    +
    61 
    +th :: IO ()
    62 
    +th =
    63 
    +  $(do
    64 
    +      foldr (\stmt acc -> [| $stmt >> $acc |]) [| pure () |] $
    65 
    +        [ [| inspect Text."I'm a Text" |]
    66 
    +        , [| inspect Ascii."I'm an ASCII bytestring: 語" |]
    67 
    +        , [| inspect Utf8."I'm a Utf8 bytestring: 語" |]
    68 
    +        , [|
    69 
    +            inspect Text."""
    70 
    +              I'm a multiline
    71 
    +              Text string
    72 
    +            """
    73 
    +          |]
    74 
    +        ]
    75 
    +   )

  • testsuite/tests/printer/Test27291.hs
    1 
    +{-# LANGUAGE ExplicitNamespaces #-}
    2 
    +
    3 
    +module Test27291
    4 
    +    ( C(type ..)       -- exports class C and data family D
    5 
    +    , C(data ..)       -- exports class C and method m
    6 
    +    , D(type ..)       -- exports data family D
    7 
    +    , type T (..)      -- exports type T and all its data constructors D, D2
    8 
    +    , type T (type ..) -- exports type T
    9 
    +    , type K (type ..) -- exports type K and its constructor K1
    10 
    +    ) where
    11 
    +
    12 
    +import Control.Applicative qualified as A (type Applicative (data ..))
    13 
    +import Data.Either qualified as E (type Either (data ..))
    14 
    +
    15 
    +import Data.Bool (data True (..))
    16 
    +import Data.Bool (data True( data .. ) )
    17 
    +import Data.Bool (data True( type ..))
    18 
    +
    19 
    +import DodgyImports03_helper (C(  .. ))
    20 
    +import DodgyImports03_helper (C  (data .. ))
    21 
    +import DodgyImports03_helper (C(  type ..) )
    22 
    +
    23 
    +import DodgyImports03_helper (T ( .. ) )
    24 
    +import DodgyImports03_helper (T(data ..))
    25 
    +import DodgyImports03_helper (T(type ..))
    26 
    +
    27 
    +import Control.Applicative (type Applicative (type ..))  -- dodgy: no associated types
    28 
    +import Data.Either (type Either (type ..))               -- dodgy: not a class
    29 
    +
    30 
    +import Data.Proxy (type Proxy(data ..))                  -- ok
    31 
    +import Data.Proxy (type Proxy(type ..))                  -- dodgy: not a class
    32 
    +
    33 
    +import T25901_sub_g_helper qualified as T1 (T (data ..)) -- T and MkT
    34 
    +import T25901_sub_g_helper qualified as T2 (T (type ..)) -- T only
    35 
    +import T25901_sub_g_helper qualified as T3 (type T (..)) -- T and MkT

  • testsuite/tests/printer/all.T
    ... ... @@ -217,7 +217,9 @@ test('T24237', normal, compile_fail, [''])
    217 217
    218 218 
     test('Test25454', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25454'])
    219 219 
     test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885'])
    220 
    +test('Test27291', [ignore_stderr, req_ppr_deps], makefile_test, ['Test27291'])
    220 221
    221 222 
     test('TestLevelImports', [ignore_stderr, req_ppr_deps], makefile_test, ['TestLevelImports'])
    222 223 
     test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults'])
    223 224 
     test('PprModifiers', [ignore_stderr,req_ppr_deps], makefile_test, ['PprModifiers'])
    225 
    +test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings'])

  • utils/check-exact/ExactPrint.hs
    ... ... @@ -3145,6 +3145,12 @@ instance ExactPrint (HsExpr GhcPs) where
    3145 3145 
         body' <- markAnnotated body
    3146 3146 
         return (HsQual noExtField ctxt' body')
    3147 3147
    3148 
    +  exact (HsQualLit _ (QualLit _ modu (HsQualString src fs))) = do
    3149 
    +    modu' <- markAnnotated modu
    3150 
    +    printStringAdvanceA "."
    3151 
    +    printSourceTextAA src (show (unpackFS fs))
    3152 
    +    return (HsQualLit noExtField (QualLit noExtField modu' (HsQualString src fs)))
    3153 
    +
    3148 3154 
       exact x = error $ "exact HsExpr for:" ++ showAst x
    3149 3155
    3150 3156 
     -- ---------------------------------------------------------------------
    ... ... @@ -4581,9 +4587,9 @@ instance ExactPrint (IE GhcPs) where
    4581 4587 
         return (IEThingAbs depr' thing' doc')
    4582 4588 
       exact (IEThingAll x ns_spec thing doc) = do
    4583 4589 
         depr' <- markAnnotated (ieta_warning x)
    4584 
    -    ns_spec' <- markAnnotated ns_spec
    4585 4590 
         thing' <- markAnnotated thing
    4586 4591 
         op' <- markEpToken (ieta_tok_lpar x)
    4592 
    +    ns_spec' <- markAnnotated ns_spec
    4587 4593 
         dd' <- markEpToken (ieta_tok_wc x)
    4588 4594 
         cp' <- markEpToken (ieta_tok_rpar x)
    4589 4595 
         doc' <- markAnnotated doc

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help