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

Commits:

10 changed files:

Changes:

  • compiler/GHC/Iface/Binary.hs
    ... ... @@ -620,27 +620,24 @@ initNameReaderTable cache = do
    620 620 
     data BinSymbolTable = BinSymbolTable {
    621 621 
             bin_symtab_next :: !FastMutInt,
    622 622 
                             -- ^ The next index to use
    623 
    -        bin_symtab_map  :: !(IORef (NameEnv Int)),
    623 
    +        bin_symtab_map  :: !(IORef (NameEnv Int, ModuleEnv [(Int,Name)]))
    624 624 
                             -- ^ Deduplication indexed by Name
    625 
    -        bin_symtab_tbl  :: !(IORef (ModuleEnv [(Int,Name)]))
    626 
    -                        -- ^ Group table data by module for serialization
    625 
    +                        -- ; Group table data by module for serialization
    627 626 
       }
    628 627
    629 628 
     initNameWriterTable :: IO (WriterTable, BinaryWriter Name)
    630 629 
     initNameWriterTable = do
    631 630 
       symtab_next <- newFastMutInt 0
    632 
    -  symtab_tbl <- newIORef emptyModuleEnv
    633 
    -  symtab_map <- newIORef emptyNameEnv
    631 
    +  symtab_map <- newIORef (emptyNameEnv, emptyModuleEnv)
    634 632 
       let bin_symtab =
    635 633 
             BinSymbolTable
    636 634 
               { bin_symtab_next = symtab_next
    637 635 
               , bin_symtab_map  = symtab_map
    638 
    -          , bin_symtab_tbl  = symtab_tbl
    639 636 
               }
    640 637
    641 638 
       let put_symtab bh = do
    642 639 
             name_count <- readFastMutInt symtab_next
    643 
    -        symtab_tbl <- readIORef symtab_tbl
    640 
    +        (_, symtab_tbl) <- readIORef symtab_map
    644 641 
             putSymbolTable bh name_count symtab_tbl
    645 642 
             pure name_count
    646 643
    ... ... @@ -670,7 +667,7 @@ putSymbolTable bh name_count symtab = do
    670 667 
         put_ bh (sizeModuleEnv symtab)
    671 668 
         forM_ (moduleEnvToList symtab) $ \(mod,names) -> do
    672 669 
           put_ bh mod
    673 
    -      put_ bh (length names) -- todo: don't use length?
    670 
    +      put_ bh (length names)
    674 671 
           forM_ names $ \(table_ix, name) -> do
    675 672 
             let occ = assertPpr (isExternalName name) (ppr name) (nameOccName name)
    676 673 
             put_ bh table_ix
    ... ... @@ -695,7 +692,7 @@ getSymbolTable bh name_cache = do
    695 692 
                     uniq <- takeUniqFromNameCache name_cache
    696 693 
                     let name   = mkExternalName uniq mod occ noSrcSpan
    697 694 
                         cache3 = extendOrigNameCache cache2 mod occ name
    698 
    -                writeArray mut_arr table_ix name -- todo: are these being forced? experiment and measure
    695 
    +                writeArray mut_arr table_ix name
    699 696 
                     return cache3
    700 697 
           arr <- unsafeFreeze mut_arr
    701 698 
           return (cache, arr)
    ... ... @@ -722,7 +719,6 @@ getSymbolTable bh name_cache = do
    722 719 
     putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
    723 720 
     putName BinSymbolTable{
    724 721 
                    bin_symtab_map = symtab_map_ref,
    725 
    -               bin_symtab_tbl = symtab_tbl_ref,
    726 722 
                    bin_symtab_next = symtab_next }
    727 723 
             bh name
    728 724 
       | isKnownKeyName name
    ... ... @@ -733,20 +729,18 @@ putName BinSymbolTable{
    733 729 
                  .|. (fromIntegral u :: Word32))
    734 730
    735 731 
       | otherwise
    736 
    -  = do symtab_map <- readIORef symtab_map_ref
    732 
    +  = do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
    737 733 
            case lookupNameEnv symtab_map name of
    738 734 
              Just off -> put_ bh (fromIntegral off :: Word32)
    739 735 
              Nothing -> do
    740 736 
               off <- freshIndex
    741 737 
               let mod = nameModule name
    742 
    -          symtab_tbl <- readIORef symtab_tbl_ref
    743 738 
               let mod_nms = fromMaybe [] (lookupModuleEnv symtab_tbl mod)
    744 739
    745 
    -          writeIORef symtab_tbl_ref $!
    746 
    -            extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
    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' )
    747 743
    748 
    -          writeIORef symtab_map_ref
    749 
    -              $! extendNameEnv symtab_map name off
    750 744 
               put_ bh (fromIntegral off :: Word32)
    751 745 
       where
    752 746 
         freshIndex :: IO Int

  • 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/InterfaceFile.hs
    ... ... @@ -173,13 +173,11 @@ writeInterfaceFile filename iface = do
    173 173
    174 174 
       -- Make some intial state
    175 175 
       symtab_next <- newFastMutInt 0
    176 
    -  symtab_tbl <- newIORef emptyModuleEnv
    177 
    -  symtab_map <- newIORef emptyNameEnv
    176 
    +  symtab_map <- newIORef (emptyNameEnv, emptyModuleEnv)
    178 177 
       let bin_symtab =
    179 178 
             BinSymbolTable
    180 179 
               { bin_symtab_next = symtab_next
    181 180 
               , bin_symtab_map = symtab_map
    182 
    -          , bin_symtab_tbl = symtab_tbl
    183 181 
               }
    184 182 
       dict_next_ref <- newFastMutInt 0
    185 183 
       dict_map_ref <- newIORef emptyUFM
    ... ... @@ -215,7 +213,7 @@ writeInterfaceFile filename iface = do
    215 213
    216 214 
       -- write the symbol table itself
    217 215 
       symtab_next' <- readFastMutInt symtab_next
    218 
    -  symtab_tbl' <- readIORef symtab_tbl
    216 
    +  (_, symtab_tbl') <- readIORef symtab_map
    219 217 
       putSymbolTable bh symtab_next' symtab_tbl'
    220 218
    221 219 
       -- write the dictionary pointer at the fornt of the file
    ... ... @@ -268,26 +266,22 @@ putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
    268 266 
     putName
    269 267 
       BinSymbolTable
    270 268 
         { bin_symtab_map = symtab_map_ref
    271 
    -    , bin_symtab_tbl = symtab_tbl_ref
    272 269 
         , bin_symtab_next = symtab_next
    273 270 
         }
    274 271 
       bh
    275 272 
       name =
    276 273 
         do
    277 
    -      symtab_map <- readIORef symtab_map_ref
    274 
    +      (symtab_map, symtab_tbl) <- readIORef symtab_map_ref
    278 275 
           case lookupNameEnv symtab_map name of
    279 276 
             Just off -> put_ bh (fromIntegral off :: Word32)
    280 277 
             Nothing -> do
    281 278 
               off <- freshIndex
    282 279 
               let mod' = nameModule name
    283 
    -          symtab_tbl <- readIORef symtab_tbl_ref
    284 280 
               let mod_nms = fromMaybe [] (lookupModuleEnv symtab_tbl mod')
    285 281
    286 
    -          writeIORef symtab_tbl_ref $!
    287 
    -            extendModuleEnv symtab_tbl mod' ((off, name) : mod_nms)
    288 
    -
    289 
    -          writeIORef symtab_map_ref $!
    290 
    -            extendNameEnv symtab_map name off
    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')
    291 285 
               put_ bh (fromIntegral off :: Word32)
    292 286 
       where
    293 287 
         freshIndex :: IO Int
    ... ... @@ -298,10 +292,9 @@ putName
    298 292
    299 293 
     data BinSymbolTable = BinSymbolTable
    300 294 
       { bin_symtab_next :: !FastMutInt -- The next index to use
    301 
    -  , bin_symtab_map :: !(IORef (NameEnv Int))
    295 
    +  , bin_symtab_map :: !(IORef (NameEnv Int, ModuleEnv [(Int, Name)]))
    302 296 
       -- ^ Deduplication indexed by Name
    303 
    -  , bin_symtab_tbl :: !(IORef (ModuleEnv [(Int, Name)]))
    304 
    -  -- ^ Group table data by module for serialization
    297 
    +  -- ; Group table data by module for serialization
    305 298 
       }
    306 299
    307 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