[Git][ghc/ghc][wip/faststring-no-z] fixes

[Zubin (@wz1000)]

Zubin pushed to branch wip/faststring-no-z at Glasgow Haskell Compiler / GHC


Commits:
7bf4bf0a by Zubin Duggal at 2024-06-10T10:01:46+02:00
fixes

- - - - -


5 changed files:

- compiler/GHC/Data/FastString.hs
- ghc/Main.hs
- rts/configure.ac
- testsuite/tests/th/T10279.hs
- testsuite/tests/th/T10279.stderr


Changes:

=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -94,6 +94,7 @@ module GHC.Data.FastString
 
         -- ** Internal
         getFastStringTable,
+        getFastZStringTable,
         getFastStringZEncCounter,
 
         -- * PtrStrings
@@ -358,6 +359,7 @@ hashToIndex# buckets# hash# =
     !(I# segmentBits#) = segmentBits
     size# = sizeofMutableArray# buckets#
 
+{-# INLINE maybeResizeSegment #-}
 maybeResizeSegment :: forall a. (a -> Int) -> IORef (TableSegment a) -> IO (TableSegment a)
 maybeResizeSegment hashElem segmentRef = do
   segment@(TableSegment lock counter old#) <- readIORef segmentRef
@@ -564,6 +566,9 @@ bucket_match fs sbs = go fs
 -- Non-inlining causes a small, but measurable performance regression, so let's force it.
 {-# INLINE bucket_match #-}
 
+
+{-# INLINE mkNewFastZString #-}
+
 mkNewFastZString :: FastString -> IO FastZString
 mkNewFastZString (FastString uniq _ sbs) = do
   TableSegment lock _ buckets# <- readIORef segmentRef
@@ -575,9 +580,9 @@ mkNewFastZString (FastString uniq _ sbs) = do
       -- The withMVar below is not dupable. It can lead to deadlock if it is
       -- only run partially and putMVar is not called after takeMVar.
       noDuplicate
-      n <- get_uid
+      _ <- get_uid
       let !new_fs = mkZFastString sbs
-      withMVar lock $ \_ -> insert n new_fs
+      withMVar lock $ \_ -> insert (I# hash#) new_fs
   where
     !(FastZStringTable uid segments#) = zstringTable
     get_uid = atomicFetchAddFastMut uid 1
@@ -706,6 +711,8 @@ unpackFS fs = utf8DecodeShortByteString $ fs_sbs fs
 zEncodeFS :: FastString -> FastZString
 zEncodeFS fs = inlinePerformIO $ mkNewFastZString fs
 
+{-# INLINE zEncodeFS #-}
+
 appendFS :: FastString -> FastString -> FastString
 appendFS fs1 fs2 = mkFastStringShortByteString
                  $ (Semi.<>) (fs_sbs fs1) (fs_sbs fs2)
@@ -742,6 +749,17 @@ getFastStringTable =
   where
     !(FastStringTable _ segments#) = stringTable
 
+getFastZStringTable :: IO [[[FastZString]]]
+getFastZStringTable =
+  forM [0 .. numSegments - 1] $ \(I# i#) -> do
+    let (# segmentRef #) = indexArray# segments# i#
+    TableSegment _ _ buckets# <- readIORef segmentRef
+    let bucketSize = I# (sizeofMutableArray# buckets#)
+    forM [0 .. bucketSize - 1] $ \(I# j#) ->
+      fmap (map (\(HashedFastZString _ s) -> s)) $ IO $ readArray# buckets# j#
+  where
+    !(FastZStringTable _ segments#) = zstringTable
+
 getFastStringZEncCounter :: IO Int
 getFastStringZEncCounter = readFastMutInt counter
   where (FastZStringTable counter _) = zstringTable


=====================================
ghc/Main.hs
=====================================
@@ -1032,10 +1032,15 @@ dumpFinalStats logger = do
 
   when (logHasDumpFlag logger Opt_D_dump_faststrings) $ do
     fss <- getFastStringTable
+    fzss <- getFastZStringTable
     let ppr_table         = fmap ppr_segment (fss `zip` [0..])
         ppr_segment (s,n) = hang (text "Segment" <+> int n) 2 (vcat (fmap ppr_bucket (s `zip` [0..])))
         ppr_bucket  (b,n) = hang (text "Bucket" <+> int n) 2 (vcat (fmap ftext b))
     putDumpFileMaybe logger Opt_D_dump_faststrings "FastStrings" FormatText (vcat ppr_table)
+    let ppr_table'         = fmap ppr_segment' (fzss `zip` [0..])
+        ppr_segment' (s,n) = hang (text "Segment" <+> int n) 2 (vcat (fmap ppr_bucket' (s `zip` [0..])))
+        ppr_bucket'  (b,n) = hang (text "Bucket" <+> int n) 2 (vcat (fmap (text . zString) b))
+    putDumpFileMaybe logger Opt_D_dump_faststrings "FastZStrings" FormatText (vcat ppr_table')
 
 dumpFastStringStats :: Logger -> IO ()
 dumpFastStringStats logger = do
@@ -1053,6 +1058,7 @@ dumpFastStringStats logger = do
         , text "smallest segment: " <+> int (minimum bucketsPerSegment)
         , text "longest bucket:   " <+> int (maximum entriesPerBucket)
         , text "has z-encoding:   " <+> (hasZ `pcntOf` entries)
+        , text "z-encodings:      " <+> int (hasZ)
         ])
         -- we usually get more "has z-encoding" than "z-encoded", because
         -- when we z-encode a string it might hash to the exact same string,


=====================================
rts/configure.ac
=====================================
@@ -6,7 +6,7 @@
 # see what flags are available. (Better yet, read the documentation!)
 #
 
-AC_INIT([GHC run-time system], [1.0.2], [libraries at haskell.org], [rts])
+AC_INIT([GHC run-time system], [1.0.3], [libraries at haskell.org], [rts])
 
 AC_CONFIG_MACRO_DIRS([../m4])
 


=====================================
testsuite/tests/th/T10279.hs
=====================================
@@ -7,4 +7,4 @@ import Language.Haskell.TH.Syntax
 -- error message doesn't recognize it as a source package ID,
 -- (This is OK,  since it will look obviously wrong when they
 -- try to find the package in their package database.)
-blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0.2") (mkModName "A"))))
+blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0.3") (mkModName "A"))))


=====================================
testsuite/tests/th/T10279.stderr
=====================================
@@ -1,11 +1,11 @@
 
 T10279.hs:10:9: error: [GHC-51294]
     • Failed to load interface for ‘A’.
-      no unit id matching ‘rts-1.0.2’ was found
+      no unit id matching ‘rts-1.0.3’ was found
       (This unit ID looks like the source package ID;
        the real unit ID is ‘rts’)
     • In the untyped splice:
         $(conE
             (Name
                (mkOccName "Foo")
-               (NameG VarName (mkPkgName "rts-1.0.2") (mkModName "A"))))
+               (NameG VarName (mkPkgName "rts-1.0.3") (mkModName "A"))))



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bf4bf0ad072cd24b78930f494b889ce50e117b1

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bf4bf0ad072cd24b78930f494b889ce50e117b1
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240610/72fbc688/attachment-0001.html>