GitLab

Matthew Pickering pushed to branch wip/fix-tylit-determ at Glasgow Haskell Compiler / GHC

Commits:

3f4a4296

by Matthew Pickering at 2026-01-29T10:59:05+00:00

determinism: Use deterministic map for Strings in TyLitMap

When generating typeable evidence the types we need evidence for all
cached in a TypeMap, the order terms are retrieved from a type map
determines the order the bindings appear in the program.

A TypeMap is quite diligent to use deterministic maps, apart from in the
TyLitMap, which uses a UniqFM for storing strings, whose ordering
depends on the Unique of the FastString.

This can cause non-deterministic .hi and .o files.

An unexpected side-effect is the error message but RecordDotSyntaxFail8
changing. I looked into this with Sam and this change caused the
constraints to be solved in a different order which results in a
slightly different error message. I have accepted the new test, since
the output before was non-deterministic and the new output is consistent
with the other messages in that file.

Fixes #26846

4 changed files:

compiler/GHC/Core/Map/Type.hs
+ testsuite/tests/ghc-api/TypeMapStringLiteral.hs
testsuite/tests/ghc-api/all.T
testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr

Changes:

compiler/GHC/Core/Map/Type.hs

@@ -45,7 +45,7 @@ import GHC.Types.Name
  import GHC.Types.Name.Env
  import GHC.Types.Var
  import GHC.Types.Var.Env
 -import GHC.Types.Unique.FM
 +import GHC.Types.Unique.DFM
  import GHC.Utils.Outputable
  import GHC.Utils.Panic
@@ -365,14 +365,14 @@ filterT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon
  ------------------------
  data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
 -                      , tlm_string :: UniqFM  FastString a
 +                      , tlm_string :: UniqDFM  FastString a
                        , tlm_char   :: Map.Map Char a
+                       }
  -- TODO(22292): derive
  instance Functor TyLitMap where
      fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM
 -      { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }
 +      { tlm_number = Map.map f tn, tlm_string = mapUDFM f ts, tlm_char = Map.map f tc }
  instance TrieMap TyLitMap where
     type Key TyLitMap = TyLit
@@ -384,34 +384,34 @@ instance TrieMap TyLitMap where
     mapMaybeTM = mpTyLit
  emptyTyLitMap :: TyLitMap a
 -emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty }
 +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUDFM, tlm_char = Map.empty }
  lkTyLit :: TyLit -> TyLitMap a -> Maybe a
  lkTyLit l =
    case l of
      NumTyLit n -> tlm_number >.> Map.lookup n
 -    StrTyLit n -> tlm_string >.> (`lookupUFM` n)
 +    StrTyLit n -> tlm_string >.> (`lookupUDFM` n)
      CharTyLit n -> tlm_char >.> Map.lookup n
  xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a
  xtTyLit l f m =
    case l of
      NumTyLit n ->  m { tlm_number = Map.alter f n (tlm_number m) }
 -    StrTyLit n ->  m { tlm_string = alterUFM  f (tlm_string m) n }
 +    StrTyLit n ->  m { tlm_string = alterUDFM  f (tlm_string m) n }
      CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) }
  foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
 -foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m)
 +foldTyLit l m = flip (foldUDFM l)  (tlm_string m)
                . flip (Map.foldr l) (tlm_number m)
                . flip (Map.foldr l) (tlm_char m)
  filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a
  filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
 -  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc }
 +  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUDFM f ts, tlm_char = Map.filter f tc }
  mpTyLit :: (a -> Maybe b) -> TyLitMap a -> TyLitMap b
  mpTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
 -  = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUFM f ts, tlm_char = Map.mapMaybe f tc }
 +  = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUDFM f ts, tlm_char = Map.mapMaybe f tc }
  -------------------------------------------------
  -- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this

testsuite/tests/ghc-api/TypeMapStringLiteral.hs

 +{-# LANGUAGE OverloadedStrings #-}
 +module Main (main) where
++
 +import Control.Monad (unless)
 +import qualified Data.ByteString.Char8 as BSC
 +import qualified Data.ByteString.Short as SBS
 +import Data.Char (ord)
 +import Data.List (foldl')
 +import GHC.Core.Map.Type (TypeMap, emptyTypeMap, extendTypeMap, foldTypeMap)
 +import GHC.Core.Type (Type, mkStrLitTy)
 +import GHC.Data.FastString (FastString (..), FastZString (..))
 +import GHC.Utils.Encoding (zEncodeString)
++
 +main :: IO ()
 +main = do
 +  let logicalEntries =
 +        [ ("alpha", "payload-alpha")
 +        , ("beta",  "payload-beta")
 +        , ("gamma", "payload-gamma")
 +        ]
 +      uniquesOne = [1, 2, 3]
 +      uniquesTwo = [200, 100, 500]
++
 +      tmOne = buildMap logicalEntries uniquesOne
 +      tmTwo = buildMap logicalEntries uniquesTwo
++
 +      foldedOne = foldValues tmOne
 +      foldedTwo = foldValues tmTwo
++
 +  assert "foldTypeMap order independent of FastString uniques" $
 +    foldedOne == foldedTwo
++
++
 +buildMap :: [(String, a)] -> [Int] -> TypeMap a
 +buildMap entries uniques =
 +  foldl' insertEntry emptyTypeMap (zip uniques entries)
 +  where
 +    insertEntry :: TypeMap a -> (Int, (String, a)) -> TypeMap a
 +    insertEntry tm (u, (txt, payload)) =
 +      extendTypeMap tm (strLiteralWithUnique u txt) payload
++
 +foldValues :: TypeMap a -> [a]
 +foldValues tm = foldTypeMap (:) [] tm
++
 +strLiteralWithUnique :: Int -> String -> Type
 +strLiteralWithUnique u = mkStrLitTy . fakeFastString u
++
 +fakeFastString :: Int -> String -> FastString
 +fakeFastString u s = FastString
 +  { uniq = u
 +  , n_chars = length s
 +  , fs_sbs = SBS.pack (map (fromIntegral . ord) s)
 +  , fs_zenc = error "unused"
 +  }
++
 +assert :: String -> Bool -> IO ()
 +assert label condition = unless condition $
 +  error ("TypeMap string literal test failed: " ++ label)

testsuite/tests/ghc-api/all.T

@@ -74,3 +74,4 @@ test('T25577', [ extra_run_opts(f'"{config.libdir}"')
  test('T26120', [], compile_and_run, ['-package ghc'])
  test('T26264', normal, compile_and_run, ['-package ghc'])
 +test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])

testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr

@@ -30,7 +30,13 @@ RecordDotSyntaxFail8.hs:53:17: error: [GHC-39999]
      • No instance for ‘HasField "quux3" Quux r0’
          arising from selecting the field ‘quux3’
        NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class.
 -    • In the expression: ....bar.baz.quux3
 -      In the second argument of ‘($)’, namely ‘....baz.quux3.wob’
 +    • In the second argument of ‘($)’, namely ‘....baz.quux3.wob’
        In a stmt of a 'do' block: print @Bool $ ....quux3.wob
 +      In the expression:
 +        do let a = Foo {foo = ...}
 +           print @Quux $ ....quux1
 +           let b = myQuux
 +           print @Quux $ b.quux2
 +           let c = Foo {foo = ...}
 +           ...