Rodrigo Mesquita pushed to branch wip/romes/27401-2 at Glasgow Haskell Compiler / GHC

Commits:

12 changed files:

Changes:

  • compiler/GHC/Iface/Binary.hs
    ... ... @@ -37,7 +37,6 @@ import GHC.Unit
    37 37 
     import GHC.Unit.Module.ModIface
    38 38 
     import GHC.Types.Name
    39 39 
     import GHC.Platform.Profile
    40 
    -import GHC.Types.Unique.FM
    41 40 
     import GHC.Utils.Panic
    42 41 
     import GHC.Utils.Binary as Binary
    43 42 
     import GHC.Data.FastMutInt
    ... ... @@ -61,7 +60,8 @@ import System.IO.Unsafe
    61 60 
     import Data.Typeable (Typeable)
    62 61 
     import qualified GHC.Data.Strict as Strict
    63 62 
     import Data.Function ((&))
    64 
    -
    63 
    +import GHC.Types.Name.Env
    64 
    +import Data.Maybe
    65 65
    66 66 
     -- ---------------------------------------------------------------------------
    67 67 
     -- Reading and writing binary interface files
    ... ... @@ -618,25 +618,27 @@ initNameReaderTable cache = do
    618 618 
           }
    619 619
    620 620 
     data BinSymbolTable = BinSymbolTable {
    621 
    -        bin_symtab_next :: !FastMutInt, -- The next index to use
    622 
    -        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
    623 
    -                                -- indexed by Name
    621 
    +        bin_symtab_next :: !FastMutInt,
    622 
    +                        -- ^ The next index to use
    623 
    +        bin_symtab_map  :: !(IORef (NameEnv Int, ModuleEnv [(Int,Name)]))
    624 
    +                        -- ^ Deduplication indexed by Name
    625 
    +                        -- ; Group table data by module for serialization
    624 626 
       }
    625 627
    626 628 
     initNameWriterTable :: IO (WriterTable, BinaryWriter Name)
    627 629 
     initNameWriterTable = do
    628 630 
       symtab_next <- newFastMutInt 0
    629 
    -  symtab_map <- newIORef emptyUFM
    631 
    +  symtab_map <- newIORef (emptyNameEnv, emptyModuleEnv)
    630 632 
       let bin_symtab =
    631 633 
             BinSymbolTable
    632 634 
               { bin_symtab_next = symtab_next
    633 
    -          , bin_symtab_map = symtab_map
    635 
    +          , bin_symtab_map  = symtab_map
    634 636 
               }
    635 637
    636 638 
       let put_symtab bh = do
    637 639 
             name_count <- readFastMutInt symtab_next
    638 
    -        symtab_map <- readIORef symtab_map
    639 
    -        putSymbolTable bh name_count symtab_map
    640 
    +        (_, symtab_tbl) <- readIORef symtab_map
    641 
    +        putSymbolTable bh name_count symtab_tbl
    640 642 
             pure name_count
    641 643
    642 644 
       return
    ... ... @@ -647,40 +649,53 @@ initNameWriterTable = do
    647 649 
         )
    648 650
    649 651
    650 
    -putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
    652 
    +{- |
    653 
    +The symbol table payload will look like:
    654 
    +
    655 
    +  <total name count>
    656 
    +  $modules.size
    657 
    +  for (mod, names) in $modules:
    658 
    +    $mod
    659 
    +    $names.size
    660 
    +    for table_ix, occ in $names
    661 
    +      $table_ix
    662 
    +      $occ
    663 
    +-}
    664 
    +putSymbolTable :: WriteBinHandle -> Int -> ModuleEnv [(Int, Name)] -> IO ()
    651 665 
     putSymbolTable bh name_count symtab = do
    652 666 
         put_ bh name_count
    653 
    -    let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab))
    654 
    -      -- It's OK to use nonDetEltsUFM here because the elements have
    655 
    -      -- indices that array uses to create order
    656 
    -    mapM_ (\n -> serialiseName bh n symtab) names
    657 
    -
    658 
    -
    667 
    +    put_ bh (sizeModuleEnv symtab)
    668 
    +    forM_ (moduleEnvToList symtab) $ \(mod,names) -> do
    669 
    +      put_ bh mod
    670 
    +      put_ bh (length names)
    671 
    +      forM_ names $ \(table_ix, name) -> do
    672 
    +        let occ = assertPpr (isExternalName name) (ppr name) (nameOccName name)
    673 
    +        put_ bh table_ix
    674 
    +        put_ bh occ
    675 
    +
    676 
    +-- | Decode the symbol table -- layout set by 'putSymbolTable'.
    659 677 
     getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
    660 678 
     getSymbolTable bh name_cache = do
    661 679 
         sz <- get bh :: IO Int
    662 680 
         -- create an array of Names for the symbols and add them to the NameCache
    663 681 
         updateNameCache' name_cache $ \cache0 -> do
    664 
    -        mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
    665 
    -        cache <- foldGet' (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do
    666 
    -          let mod = mkModule uid mod_name
    667 
    -          case lookupOrigNameCache cache mod occ of
    668 
    -            Just name -> do
    669 
    -              writeArray mut_arr (fromIntegral i) name
    670 
    -              return cache
    671 
    -            Nothing   -> do
    672 
    -              uniq <- takeUniqFromNameCache name_cache
    673 
    -              let name      = mkExternalName uniq mod occ noSrcSpan
    674 
    -                  new_cache = extendOrigNameCache cache mod occ name
    675 
    -              writeArray mut_arr (fromIntegral i) name
    676 
    -              return new_cache
    677 
    -        arr <- unsafeFreeze mut_arr
    678 
    -        return (cache, arr)
    679 
    -
    680 
    -serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
    681 
    -serialiseName bh name _ = do
    682 
    -    let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
    683 
    -    put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
    682 
    +      mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
    683 
    +      mods_sz <- get bh :: IO Int
    684 
    +      cache <-
    685 
    +        foldGet' (fromIntegral mods_sz) bh cache0 $ \_mod_ix (mod,mod_nms_sz) cache1 -> do
    686 
    +          foldGet' (fromIntegral (mod_nms_sz::Int)) bh cache1 $ \_mod_nms_ix (table_ix, occ) cache2 -> do
    687 
    +            case lookupOrigNameCache cache2 mod occ of
    688 
    +              Just name -> do
    689 
    +                writeArray mut_arr table_ix name
    690 
    +                return cache2
    691 
    +              Nothing   -> do
    692 
    +                uniq <- takeUniqFromNameCache name_cache
    693 
    +                let name   = mkExternalName uniq mod occ noSrcSpan
    694 
    +                    cache3 = extendOrigNameCache cache2 mod occ name
    695 
    +                writeArray mut_arr table_ix name
    696 
    +                return cache3
    697 
    +      arr <- unsafeFreeze mut_arr
    698 
    +      return (cache, arr)
    684 699
    685 700
    686 701 
     -- Note [Symbol table representation of names]
    ... ... @@ -714,16 +729,26 @@ putName BinSymbolTable{
    714 729 
                  .|. (fromIntegral u :: Word32))
    715 730
    716 731 
       | otherwise
    717 
    -  = do symtab_map <- readIORef symtab_map_ref
    718 
    -       case lookupUFM symtab_map name of
    719 
    -         Just (off,_) -> put_ bh (fromIntegral off :: Word32)
    732 
    +  = do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
    733 
    +       case lookupNameEnv symtab_map name of
    734 
    +         Just off -> put_ bh (fromIntegral off :: Word32)
    720 735 
              Nothing -> do
    721 
    -            off <- readFastMutInt symtab_next
    722 
    -            -- massert (off < 2^(30 :: Int))
    723 
    -            writeFastMutInt symtab_next (off+1)
    724 
    -            writeIORef symtab_map_ref
    725 
    -                $! addToUFM symtab_map name (off,name)
    726 
    -            put_ bh (fromIntegral off :: Word32)
    736 
    +          off <- freshIndex
    737 
    +          let mod = nameModule name
    738 
    +          let mod_nms = fromMaybe [] (lookupModuleEnv symtab_tbl mod)
    739 
    +
    740 
    +          let !symtab_map' = extendNameEnv symtab_map name off
    741 
    +          let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
    742 
    +          writeIORef symtab_map_ref $! ( symtab_map',  symtab_tbl' )
    743 
    +
    744 
    +          put_ bh (fromIntegral off :: Word32)
    745 
    +  where
    746 
    +    freshIndex :: IO Int
    747 
    +    freshIndex = do
    748 
    +      off <- readFastMutInt symtab_next
    749 
    +      -- massert (off < 2^(30 :: Int))
    750 
    +      writeFastMutInt symtab_next (off+1)
    751 
    +      return off
    727 752
    728 753 
     -- See Note [Symbol table representation of names]
    729 754 
     getSymtabName :: SymbolTable Name

  • compiler/GHC/Unit/Module/Env.hs
    ... ... @@ -9,7 +9,7 @@ module GHC.Unit.Module.Env
    9 9 
        , alterModuleEnv
    10 10 
        , partitionModuleEnv
    11 11 
        , moduleEnvKeys, moduleEnvElts, moduleEnvToList
    12 
    -   , unitModuleEnv, isEmptyModuleEnv
    12 
    +   , unitModuleEnv, isEmptyModuleEnv, sizeModuleEnv
    13 13 
        , extendModuleEnvWith, filterModuleEnv, mapMaybeModuleEnv
    14 14
    15 15 
          -- * ModuleName mappings
    ... ... @@ -176,6 +176,9 @@ unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x)
    176 176 
     isEmptyModuleEnv :: ModuleEnv a -> Bool
    177 177 
     isEmptyModuleEnv (ModuleEnv e) = Map.null e
    178 178
    179 
    +sizeModuleEnv :: ModuleEnv a -> Int
    180 
    +sizeModuleEnv (ModuleEnv e) = Map.size e
    181 
    +
    179 182 
     -- | A set of 'Module's
    180 183 
     type ModuleSet = Set NDModule
    181 184

  • testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout
    1 
    -import DRFPatSynExport_A ( MkT, m )
    1 
    +import DRFPatSynExport_A ( m, MkT )

  • testsuite/tests/rename/should_compile/T1792_imports.stdout
    1 
    -import qualified Data.ByteString as B ( putStr, readFile )
    1 
    +import qualified Data.ByteString as B ( readFile, putStr )

  • testsuite/tests/rename/should_compile/T18264.stdout
    1 1 
     import Data.Char ( isDigit, isLetter )
    2 2 
     import Data.List ( sortOn )
    3 
    -import Data.Maybe ( fromJust, isJust )
    3 
    +import Data.Maybe ( isJust, fromJust )
    4 4 
     import qualified Data.Char as C ( isLetter, isDigit )
    5 5 
     import qualified Data.List as S ( sort )
    6 6 
     import qualified Data.List as T ( nub )

  • testsuite/tests/rename/should_compile/T4239.stdout
    1 
    -import T4239A ( (·), type (:+++)((:---), (:+++), X) )
    1 
    +import T4239A ( type (:+++)((:---), (:+++), X), (·) )

  • testsuite/tests/showIface/DocsInHiFile1.stdout
    ... ... @@ -19,49 +19,53 @@ docs:
    19 19 
            export docs:
    20 20 
              []
    21 21 
            declaration docs:
    22 
    -         [elem -> [text:
    23 
    -                     -- | '()', 'elem'.
    24 
    -                   identifiers:
    25 
    -                     {DocsInHiFile.hs:14:13-16}
    26 
    -                     GHC.Internal.Data.Foldable.elem
    27 
    -                     {DocsInHiFile.hs:14:13-16}
    28 
    -                     elem],
    29 
    -          D -> [text:
    30 
    -                  -- | A datatype.
    22 
    +         [F -> [text:
    23 
    +                  -- | A type family
    31 24 
                     identifiers:],
    32 
    -          D0 -> [text:
    33 
    -                   -- ^ A constructor for 'D'. '
    34 
    -                 identifiers:
    35 
    -                   {DocsInHiFile.hs:20:32}
    36 
    -                   D],
    37 
    -          D1 -> [text:
    38 
    -                   -- ^ Another constructor
    25 
    +          D:R:FInt -> [text:
    26 
    +                         -- | A type family instance
    27 
    +                       identifiers:],
    28 
    +          D' -> [text:
    29 
    +                   -- | Another datatype...
    30 
    +                 identifiers:,
    31 
    +                 text:
    32 
    +                   -- ^ ...with two docstrings.
    39 33 
                      identifiers:],
    40 
    -          P -> [text:
    41 
    -                  -- | A class
    42 
    -                identifiers:],
    43 
    -          p -> [text:
    44 
    -                  -- | A class method
    45 
    -                identifiers:],
    46 34 
               $fShowD -> [text:
    47 35 
                             -- ^ 'Show' instance
    48 36 
                           identifiers:
    49 37 
                             {DocsInHiFile.hs:22:25-28}
    50 38 
                             GHC.Internal.Show.Show],
    51 
    -          D' -> [text:
    52 
    -                   -- | Another datatype...
    53 
    -                 identifiers:,
    54 
    -                 text:
    55 
    -                   -- ^ ...with two docstrings.
    39 
    +          p -> [text:
    40 
    +                  -- | A class method
    41 
    +                identifiers:],
    42 
    +          P -> [text:
    43 
    +                  -- | A class
    44 
    +                identifiers:],
    45 
    +          D1 -> [text:
    46 
    +                   -- ^ Another constructor
    56 47 
                      identifiers:],
    57 
    -          D:R:FInt -> [text:
    58 
    -                         -- | A type family instance
    59 
    -                       identifiers:],
    60 
    -          F -> [text:
    61 
    -                  -- | A type family
    62 
    -                identifiers:]]
    48 
    +          D0 -> [text:
    49 
    +                   -- ^ A constructor for 'D'. '
    50 
    +                 identifiers:
    51 
    +                   {DocsInHiFile.hs:20:32}
    52 
    +                   D],
    53 
    +          D -> [text:
    54 
    +                  -- | A datatype.
    55 
    +                identifiers:],
    56 
    +          elem -> [text:
    57 
    +                     -- | '()', 'elem'.
    58 
    +                   identifiers:
    59 
    +                     {DocsInHiFile.hs:14:13-16}
    60 
    +                     GHC.Internal.Data.Foldable.elem
    61 
    +                     {DocsInHiFile.hs:14:13-16}
    62 
    +                     elem]]
    63 63 
            arg docs:
    64 
    -         [add -> 0:
    64 
    +         [p -> 0:
    65 
    +                 text:
    66 
    +                   -- ^ An argument
    67 
    +                 identifiers:,
    68 
    +          add -> 0:
    65 69 
                        text:
    66 70 
                          -- ^ First summand for 'add'
    67 71 
                        identifiers:
    ... ... @@ -74,11 +78,7 @@ docs:
    74 78 
                      2:
    75 79 
                        text:
    76 80 
                          -- ^ Sum
    77 
    -                   identifiers:,
    78 
    -          p -> 0:
    79 
    -                 text:
    80 
    -                   -- ^ An argument
    81 
    -                 identifiers:]
    81 
    +                   identifiers:]
    82 82 
            documentation structure:
    83 83 
              avails:
    84 84 
                [elem]

  • testsuite/tests/showIface/DocsInHiFileTH.stdout
    ... ... @@ -6,137 +6,153 @@ docs:
    6 6 
            export docs:
    7 7 
              []
    8 8 
            declaration docs:
    9 
    -         [Tup2 -> [text:
    10 
    -                     -- |Matches a tuple of (a, a)
    11 
    -                   identifiers:],
    12 
    -          f -> [text:
    13 
    -                  -- |The meaning of life
    14 
    -                identifiers:],
    15 
    -          g -> [text:
    16 
    -                  -- |Some documentation
    17 
    -                identifiers:],
    18 
    -          qux -> [text:
    19 
    -                    -- |This is qux
    9 
    +         [D:R:WD13Foo -> [text:
    10 
    +                            -- |13
    11 
    +                          identifiers:],
    12 
    +          D:R:WD11Int0 -> [text:
    13 
    +                             -- |This is a data instance
    14 
    +                           identifiers:],
    15 
    +          D:R:WD11Foo0 -> [text:
    16 
    +                             -- |11
    17 
    +                           identifiers:],
    18 
    +          D:R:WD11Bool0 -> [text:
    19 
    +                              -- |This is a newtype instance
    20 
    +                            identifiers:],
    21 
    +          D:R:EBool -> [text:
    22 
    +                          -- |A type family instance
    23 
    +                        identifiers:],
    24 
    +          $fF -> [text:
    25 
    +                    -- |14
    20 26 
                       identifiers:],
    21 
    -          sin -> [text:
    22 
    -                    -- |15
    27 
    +          $fDka -> [text:
    28 
    +                      -- |Another new instance
    29 
    +                    identifiers:],
    30 
    +          $fCTYPEList -> [text:
    31 
    +                            -- |Another new instance
    32 
    +                          identifiers:],
    33 
    +          $fCTYPEInt -> [text:
    34 
    +                           -- |A new instance
    35 
    +                         identifiers:],
    36 
    +          $fCTYPEFoo -> [text:
    37 
    +                           -- |7
    38 
    +                         identifiers:],
    39 
    +          WD6 -> [text:
    40 
    +                    -- |6
    23 41 
                       identifiers:],
    24 
    -          wd1 -> [text:
    25 
    -                    -- |1
    42 
    +          WD5 -> [text:
    43 
    +                    -- |5
    26 44 
                       identifiers:],
    27 
    -          wd17 -> [text:
    28 
    -                     -- |17
    45 
    +          WD4 -> [text:
    46 
    +                    -- |4
    47 
    +                  identifiers:],
    48 
    +          WD3 -> [text:
    49 
    +                    -- |3
    50 
    +                  identifiers:],
    51 
    +          WD12 -> [text:
    52 
    +                     -- |12
    29 53 
                        identifiers:],
    30 
    -          wd18 -> [text:
    31 
    -                     -- |18
    54 
    +          WD11Int -> [text:
    55 
    +                        -- |This is a data instance constructor
    56 
    +                      identifiers:],
    57 
    +          WD11Bool -> [text:
    58 
    +                         -- |This is a newtype instance constructor
    59 
    +                       identifiers:],
    60 
    +          WD10 -> [text:
    61 
    +                     -- |10
    32 62 
                        identifiers:],
    33 
    -          wd2 -> [text:
    34 
    -                    -- |2
    35 
    -                  identifiers:],
    36 
    -          wd20 -> [text:
    37 
    -                     -- |20
    63 
    +          quuz1_a -> [text:
    64 
    +                        -- |This is the record constructor's argument
    65 
    +                      identifiers:],
    66 
    +          Quuz -> [text:
    67 
    +                     -- |This is a record constructor
    38 68 
                        identifiers:],
    39 
    -          wd8 -> [text:
    40 
    -                    -- |8
    69 
    +          Quux2 -> [text:
    70 
    +                      -- |This is Quux2
    71 
    +                    identifiers:],
    72 
    +          Quux1 -> [text:
    73 
    +                      -- |This is Quux1
    74 
    +                    identifiers:],
    75 
    +          Quux -> [text:
    76 
    +                     -- |This is Quux
    77 
    +                   identifiers:],
    78 
    +          prettyPrint -> [text:
    79 
    +                            -- |Prettily prints the object
    80 
    +                          identifiers:],
    81 
    +          Pretty -> [text:
    82 
    +                       -- |My cool class
    83 
    +                     identifiers:],
    84 
    +          Foo -> [text:
    85 
    +                    -- |A new constructor
    41 86 
                       identifiers:],
    42 
    -          C -> [text:
    43 
    -                  -- |A new class
    87 
    +          Foo -> [text:
    88 
    +                    -- |A new data type
    89 
    +                  identifiers:],
    90 
    +          E -> [text:
    91 
    +                  -- |A type family
    44 92 
                     identifiers:],
    45 
    -          Corge -> [text:
    46 
    -                      -- |This is a newtype record constructor
    47 
    -                    identifiers:],
    48 93 
               runCorge -> [text:
    49 94 
                              -- |This is the newtype record constructor's argument
    50 95 
                            identifiers:],
    51 
    -          E -> [text:
    52 
    -                  -- |A type family
    96 
    +          Corge -> [text:
    97 
    +                      -- |This is a newtype record constructor
    98 
    +                    identifiers:],
    99 
    +          C -> [text:
    100 
    +                  -- |A new class
    53 101 
                     identifiers:],
    54 
    -          Foo -> [text:
    55 
    -                    -- |A new data type
    56 
    -                  identifiers:],
    57 
    -          Foo -> [text:
    58 
    -                    -- |A new constructor
    102 
    +          wd8 -> [text:
    103 
    +                    -- |8
    59 104 
                       identifiers:],
    60 
    -          Pretty -> [text:
    61 
    -                       -- |My cool class
    62 
    -                     identifiers:],
    63 
    -          prettyPrint -> [text:
    64 
    -                            -- |Prettily prints the object
    65 
    -                          identifiers:],
    66 
    -          Quux -> [text:
    67 
    -                     -- |This is Quux
    68 
    -                   identifiers:],
    69 
    -          Quux1 -> [text:
    70 
    -                      -- |This is Quux1
    71 
    -                    identifiers:],
    72 
    -          Quux2 -> [text:
    73 
    -                      -- |This is Quux2
    74 
    -                    identifiers:],
    75 
    -          Quuz -> [text:
    76 
    -                     -- |This is a record constructor
    105 
    +          wd20 -> [text:
    106 
    +                     -- |20
    77 107 
                        identifiers:],
    78 
    -          quuz1_a -> [text:
    79 
    -                        -- |This is the record constructor's argument
    80 
    -                      identifiers:],
    81 
    -          WD10 -> [text:
    82 
    -                     -- |10
    108 
    +          wd2 -> [text:
    109 
    +                    -- |2
    110 
    +                  identifiers:],
    111 
    +          wd18 -> [text:
    112 
    +                     -- |18
    83 113 
                        identifiers:],
    84 
    -          WD11Bool -> [text:
    85 
    -                         -- |This is a newtype instance constructor
    86 
    -                       identifiers:],
    87 
    -          WD11Int -> [text:
    88 
    -                        -- |This is a data instance constructor
    89 
    -                      identifiers:],
    90 
    -          WD12 -> [text:
    91 
    -                     -- |12
    114 
    +          wd17 -> [text:
    115 
    +                     -- |17
    92 116 
                        identifiers:],
    93 
    -          WD3 -> [text:
    94 
    -                    -- |3
    95 
    -                  identifiers:],
    96 
    -          WD4 -> [text:
    97 
    -                    -- |4
    98 
    -                  identifiers:],
    99 
    -          WD5 -> [text:
    100 
    -                    -- |5
    117 
    +          wd1 -> [text:
    118 
    +                    -- |1
    101 119 
                       identifiers:],
    102 
    -          WD6 -> [text:
    103 
    -                    -- |6
    120 
    +          sin -> [text:
    121 
    +                    -- |15
    104 122 
                       identifiers:],
    105 
    -          $fCTYPEFoo -> [text:
    106 
    -                           -- |7
    107 
    -                         identifiers:],
    108 
    -          $fCTYPEInt -> [text:
    109 
    -                           -- |A new instance
    110 
    -                         identifiers:],
    111 
    -          $fCTYPEList -> [text:
    112 
    -                            -- |Another new instance
    113 
    -                          identifiers:],
    114 
    -          $fDka -> [text:
    115 
    -                      -- |Another new instance
    116 
    -                    identifiers:],
    117 
    -          $fF -> [text:
    118 
    -                    -- |14
    123 
    +          qux -> [text:
    124 
    +                    -- |This is qux
    119 125 
                       identifiers:],
    120 
    -          D:R:EBool -> [text:
    121 
    -                          -- |A type family instance
    122 
    -                        identifiers:],
    123 
    -          D:R:WD11Bool0 -> [text:
    124 
    -                              -- |This is a newtype instance
    125 
    -                            identifiers:],
    126 
    -          D:R:WD11Foo0 -> [text:
    127 
    -                             -- |11
    128 
    -                           identifiers:],
    129 
    -          D:R:WD11Int0 -> [text:
    130 
    -                             -- |This is a data instance
    131 
    -                           identifiers:],
    132 
    -          D:R:WD13Foo -> [text:
    133 
    -                            -- |13
    134 
    -                          identifiers:]]
    126 
    +          g -> [text:
    127 
    +                  -- |Some documentation
    128 
    +                identifiers:],
    129 
    +          f -> [text:
    130 
    +                  -- |The meaning of life
    131 
    +                identifiers:],
    132 
    +          Tup2 -> [text:
    133 
    +                     -- |Matches a tuple of (a, a)
    134 
    +                   identifiers:]]
    135 135 
            arg docs:
    136 
    -         [Tup2 -> 0:
    137 
    -                    text:
    138 
    -                      -- |The thing to match twice
    139 
    -                    identifiers:,
    136 
    +         [WD11Int -> 0:
    137 
    +                       text:
    138 
    +                         -- |This is a data instance constructor argument
    139 
    +                       identifiers:,
    140 
    +          WD11Bool -> 0:
    141 
    +                        text:
    142 
    +                          -- |This is a newtype instance constructor argument
    143 
    +                        identifiers:,
    144 
    +          Quux2 -> 1:
    145 
    +                     text:
    146 
    +                       -- |I am a bool
    147 
    +                     identifiers:,
    148 
    +          Quux1 -> 0:
    149 
    +                     text:
    150 
    +                       -- |I am an integer
    151 
    +                     identifiers:,
    152 
    +          qux -> 1:
    153 
    +                   text:
    154 
    +                     -- |Arg dos
    155 
    +                   identifiers:,
    140 156 
               h -> 0:
    141 157 
                      text:
    142 158 
                        -- ^Your favourite number
    ... ... @@ -149,26 +165,10 @@ docs:
    149 165 
                      text:
    150 166 
                        -- ^A return value
    151 167 
                      identifiers:,
    152 
    -          qux -> 1:
    153 
    -                   text:
    154 
    -                     -- |Arg dos
    155 
    -                   identifiers:,
    156 
    -          Quux1 -> 0:
    157 
    -                     text:
    158 
    -                       -- |I am an integer
    159 
    -                     identifiers:,
    160 
    -          Quux2 -> 1:
    161 
    -                     text:
    162 
    -                       -- |I am a bool
    163 
    -                     identifiers:,
    164 
    -          WD11Bool -> 0:
    165 
    -                        text:
    166 
    -                          -- |This is a newtype instance constructor argument
    167 
    -                        identifiers:,
    168 
    -          WD11Int -> 0:
    169 
    -                       text:
    170 
    -                         -- |This is a data instance constructor argument
    171 
    -                       identifiers:]
    168 
    +          Tup2 -> 0:
    169 
    +                    text:
    170 
    +                      -- |The thing to match twice
    171 
    +                    identifiers:]
    172 172 
            documentation structure:
    173 173 
              avails:
    174 174 
                [f]

  • testsuite/tests/showIface/NoExportList.stdout
    ... ... @@ -6,7 +6,10 @@ docs:
    6 6 
            export docs:
    7 7 
              []
    8 8 
            declaration docs:
    9 
    -         [fα -> [text:
    9 
    +         [$fEqR -> [text:
    10 
    +                      -- | A very lazy Eq instance
    11 
    +                    identifiers:],
    12 
    +          fα -> [text:
    10 13 
                        -- ^ Documentation for 'R'\'s 'fα' field.
    11 14 
                      identifiers:
    12 15 
                        {NoExportList.hs:14:38}
    ... ... @@ -14,10 +17,7 @@ docs:
    14 17 
                        {NoExportList.hs:14:38}
    15 18 
                        R
    16 19 
                        {NoExportList.hs:14:45-46}
    17 
    -                   fα],
    18 
    -          $fEqR -> [text:
    19 
    -                      -- | A very lazy Eq instance
    20 
    -                    identifiers:]]
    20 
    +                   fα]]
    21 21 
            arg docs:
    22 22 
              []
    23 23 
            documentation structure:
    ... ... @@ -99,3 +99,4 @@ docs:
    99 99 
              ListTuplePuns
    100 100 
              ImplicitStagePersistence
    101 101 
     extensible fields:
    102 
    +

  • testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
    ... ... @@ -5,10 +5,10 @@ subsumption_sort_hole_fits.hs:2:5: warning: [GHC-88464] [-Wtyped-holes (in -Wdef
    5 5 
         • Relevant bindings include
    6 6 
             f :: [String] (bound at subsumption_sort_hole_fits.hs:2:1)
    7 7 
           Valid hole fits include
    8 
    -        lines :: String -> [String]
    8 
    +        words :: String -> [String]
    9 9 
               (imported from ‘Prelude’
    10 10 
                (and originally defined in ‘GHC.Internal.Data.OldList’))
    11 
    -        words :: String -> [String]
    11 
    +        lines :: String -> [String]
    12 12 
               (imported from ‘Prelude’
    13 13 
                (and originally defined in ‘GHC.Internal.Data.OldList’))
    14 14 
             repeat :: forall a. a -> [a]

  • utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
    ... ... @@ -251,10 +251,12 @@ attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity getIns
    251 251 
                 }
    252 252 
             where
    253 253 
               fixities :: [(Name, Fixity)]
    254 
    -          !fixities = force . Map.toList $ List.foldl' f Map.empty all_names
    254 
    +          -- Use DNameEnv to guarantee a deterministic output regardless of the
    255 
    +          -- uniques assigned to each_name e.g. off of the interface file.
    256 
    +          !fixities = force . eltsDNameEnv $ List.foldl' f emptyDNameEnv all_names
    255 257
    256 
    -          f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity
    257 
    -          f !fs n = Map.alter (<|> getFixity n) n fs
    258 
    +          f :: DNameEnv (Name, Fixity) -> Name -> DNameEnv (Name, Fixity)
    259 
    +          f !fs n = alterDNameEnv (<|> ((,) n <$> getFixity n)) fs n
    258 260
    259 261 
               patsyn_names :: [Name]
    260 262 
               patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns

  • utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
    ... ... @@ -40,6 +40,7 @@ import Data.Coerce (coerce)
    40 40 
     import Data.Function ((&))
    41 41 
     import Data.IORef
    42 42 
     import Data.Map (Map)
    43 
    +import Data.Maybe (fromMaybe)
    43 44 
     import Data.Version
    44 45 
     import Data.Word
    45 46 
     import GHC hiding (NoLink)
    ... ... @@ -50,7 +51,9 @@ import GHC.Iface.Type (IfaceType, putIfaceType)
    50 51 
     import GHC.Types.Name.Cache
    51 52 
     import GHC.Types.Unique
    52 53 
     import GHC.Types.Unique.FM
    54 
    +import GHC.Types.Name.Env
    53 55 
     import GHC.Unit.State
    56 
    +import GHC.Unit.Module.Env
    54 57 
     import GHC.Utils.Binary
    55 58 
     import Haddock.Types
    56 59 
     import Text.ParserCombinators.ReadP (readP_to_S)
    ... ... @@ -139,7 +142,7 @@ binaryInterfaceMagic = 0xD0Cface
    139 142 
     --
    140 143 
     binaryInterfaceVersion :: Word16
    141 144 
     #if MIN_VERSION_ghc(9,11,0) && !MIN_VERSION_ghc(10,2,0)
    142 
    -binaryInterfaceVersion = 46
    145 
    +binaryInterfaceVersion = 47
    143 146
    144 147 
     binaryInterfaceVersionCompatibility :: [Word16]
    145 148 
     binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
    ... ... @@ -170,7 +173,7 @@ writeInterfaceFile filename iface = do
    170 173
    171 174 
       -- Make some intial state
    172 175 
       symtab_next <- newFastMutInt 0
    173 
    -  symtab_map <- newIORef emptyUFM
    176 
    +  symtab_map <- newIORef (emptyNameEnv, emptyModuleEnv)
    174 177 
       let bin_symtab =
    175 178 
             BinSymbolTable
    176 179 
               { bin_symtab_next = symtab_next
    ... ... @@ -210,8 +213,8 @@ writeInterfaceFile filename iface = do
    210 213
    211 214 
       -- write the symbol table itself
    212 215 
       symtab_next' <- readFastMutInt symtab_next
    213 
    -  symtab_map' <- readIORef symtab_map
    214 
    -  putSymbolTable bh symtab_next' symtab_map'
    216 
    +  (_, symtab_tbl') <- readIORef symtab_map
    217 
    +  putSymbolTable bh symtab_next' symtab_tbl'
    215 218
    216 219 
       -- write the dictionary pointer at the fornt of the file
    217 220 
       dict_p <- tellBinWriter bh
    ... ... @@ -268,20 +271,30 @@ putName
    268 271 
       bh
    269 272 
       name =
    270 273 
         do
    271 
    -      symtab_map <- readIORef symtab_map_ref
    272 
    -      case lookupUFM symtab_map name of
    273 
    -        Just (off, _) -> put_ bh (fromIntegral off :: Word32)
    274 
    +      (symtab_map, symtab_tbl) <- readIORef symtab_map_ref
    275 
    +      case lookupNameEnv symtab_map name of
    276 
    +        Just off -> put_ bh (fromIntegral off :: Word32)
    274 277 
             Nothing -> do
    275 
    -          off <- readFastMutInt symtab_next
    276 
    -          writeFastMutInt symtab_next (off + 1)
    277 
    -          writeIORef symtab_map_ref $!
    278 
    -            addToUFM symtab_map name (off, name)
    278 
    +          off <- freshIndex
    279 
    +          let mod' = nameModule name
    280 
    +          let mod_nms = fromMaybe [] (lookupModuleEnv symtab_tbl mod')
    281 
    +
    282 
    +          let !symtab_map' = extendNameEnv symtab_map name off
    283 
    +          let !symtab_tbl' = extendModuleEnv symtab_tbl mod' ((off, name):mod_nms)
    284 
    +          writeIORef symtab_map_ref $! (symtab_map', symtab_tbl')
    279 285 
               put_ bh (fromIntegral off :: Word32)
    286 
    +  where
    287 
    +    freshIndex :: IO Int
    288 
    +    freshIndex = do
    289 
    +      off <- readFastMutInt symtab_next
    290 
    +      writeFastMutInt symtab_next (off + 1)
    291 
    +      return off
    280 292
    281 293 
     data BinSymbolTable = BinSymbolTable
    282 294 
       { bin_symtab_next :: !FastMutInt -- The next index to use
    283 
    -  , bin_symtab_map :: !(IORef (UniqFM Name (Int, Name)))
    284 
    -  -- indexed by Name
    295 
    +  , bin_symtab_map :: !(IORef (NameEnv Int, ModuleEnv [(Int, Name)]))
    296 
    +  -- ^ Deduplication indexed by Name
    297 
    +  -- ; Group table data by module for serialization
    285 298 
       }
    286 299
    287 300 
     putFastString :: BinDictionary -> WriteBinHandle -> FastString -> IO ()

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