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

Commits:

3 changed files:

Changes:

  • compiler/GHC/Core/Map/Type.hs
    ... ... @@ -45,7 +45,7 @@ import GHC.Types.Name
    45 45 
     import GHC.Types.Name.Env
    46 46 
     import GHC.Types.Var
    47 47 
     import GHC.Types.Var.Env
    48 
    -import GHC.Types.Unique.FM
    48 
    +import GHC.Types.Unique.DFM
    49 49 
     import GHC.Utils.Outputable
    50 50
    51 51 
     import GHC.Utils.Panic
    ... ... @@ -365,14 +365,14 @@ filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon
    365 365
    366 366 
     ------------------------
    367 367 
     data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
    368 
    -                      , tlm_string :: UniqFM  FastString a
    368 
    +                      , tlm_string :: UniqDFM  FastString a
    369 369 
                           , tlm_char   :: Map.Map Char a
    370 370 
                           }
    371 371
    372 372 
     -- TODO(22292): derive
    373 373 
     instance Functor TyLitMap where
    374 374 
         fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM
    375 
    -      { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }
    375 
    +      { tlm_number = Map.map f tn, tlm_string = mapUDFM f ts, tlm_char = Map.map f tc }
    376 376
    377 377 
     instance TrieMap TyLitMap where
    378 378 
        type Key TyLitMap = TyLit
    ... ... @@ -384,34 +384,34 @@ instance TrieMap TyLitMap where
    384 384 
        mapMaybeTM = mpTyLit
    385 385
    386 386 
     emptyTyLitMap :: TyLitMap a
    387 
    -emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty }
    387 
    +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUDFM, tlm_char = Map.empty }
    388 388
    389 389 
     lkTyLit :: TyLit -> TyLitMap a -> Maybe a
    390 390 
     lkTyLit l =
    391 391 
       case l of
    392 392 
         NumTyLit n -> tlm_number >.> Map.lookup n
    393 
    -    StrTyLit n -> tlm_string >.> (`lookupUFM` n)
    393 
    +    StrTyLit n -> tlm_string >.> (`lookupUDFM` n)
    394 394 
         CharTyLit n -> tlm_char >.> Map.lookup n
    395 395
    396 396 
     xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a
    397 397 
     xtTyLit l f m =
    398 398 
       case l of
    399 399 
         NumTyLit n ->  m { tlm_number = Map.alter f n (tlm_number m) }
    400 
    -    StrTyLit n ->  m { tlm_string = alterUFM  f (tlm_string m) n }
    400 
    +    StrTyLit n ->  m { tlm_string = alterUDFM  f (tlm_string m) n }
    401 401 
         CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) }
    402 402
    403 403 
     foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
    404 
    -foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m)
    404 
    +foldTyLit l m = flip (foldUDFM l)  (tlm_string m)
    405 405 
                   . flip (Map.foldr l) (tlm_number m)
    406 406 
                   . flip (Map.foldr l) (tlm_char m)
    407 407
    408 408 
     filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a
    409 409 
     filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
    410 
    -  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc }
    410 
    +  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUDFM f ts, tlm_char = Map.filter f tc }
    411 411
    412 412 
     mpTyLit :: (a -> Maybe b) -> TyLitMap a -> TyLitMap b
    413 413 
     mpTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
    414 
    -  = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUFM f ts, tlm_char = Map.mapMaybe f tc }
    414 
    +  = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUDFM f ts, tlm_char = Map.mapMaybe f tc }
    415 415
    416 416 
     -------------------------------------------------
    417 417 
     -- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this

  • testsuite/tests/ghc-api/TypeMapStringLiteral.hs
    1 
    +{-# LANGUAGE OverloadedStrings #-}
    2 
    +module Main (main) where
    3 
    +
    4 
    +import Control.Monad (unless)
    5 
    +import qualified Data.ByteString.Char8 as BSC
    6 
    +import qualified Data.ByteString.Short as SBS
    7 
    +import Data.Char (ord)
    8 
    +import Data.List (foldl')
    9 
    +import GHC.Core.Map.Type (TypeMap, emptyTypeMap, extendTypeMap, foldTypeMap)
    10 
    +import GHC.Core.Type (Type, mkStrLitTy)
    11 
    +import GHC.Data.FastString (FastString (..), FastZString (..))
    12 
    +import GHC.Utils.Encoding (zEncodeString)
    13 
    +
    14 
    +main :: IO ()
    15 
    +main = do
    16 
    +  let logicalEntries =
    17 
    +        [ ("alpha", "payload-alpha")
    18 
    +        , ("beta",  "payload-beta")
    19 
    +        , ("gamma", "payload-gamma")
    20 
    +        ]
    21 
    +      uniquesOne = [1, 2, 3]
    22 
    +      uniquesTwo = [200, 100, 500]
    23 
    +
    24 
    +      tmOne = buildMap logicalEntries uniquesOne
    25 
    +      tmTwo = buildMap logicalEntries uniquesTwo
    26 
    +
    27 
    +      foldedOne = foldValues tmOne
    28 
    +      foldedTwo = foldValues tmTwo
    29 
    +
    30 
    +  assert "foldTypeMap order independent of FastString uniques" $
    31 
    +    foldedOne == foldedTwo
    32 
    +
    33 
    +
    34 
    +buildMap :: [(String, a)] -> [Int] -> TypeMap a
    35 
    +buildMap entries uniques =
    36 
    +  foldl' insertEntry emptyTypeMap (zip uniques entries)
    37 
    +  where
    38 
    +    insertEntry :: TypeMap a -> (Int, (String, a)) -> TypeMap a
    39 
    +    insertEntry tm (u, (txt, payload)) =
    40 
    +      extendTypeMap tm (strLiteralWithUnique u txt) payload
    41 
    +
    42 
    +foldValues :: TypeMap a -> [a]
    43 
    +foldValues tm = foldTypeMap (:) [] tm
    44 
    +
    45 
    +strLiteralWithUnique :: Int -> String -> Type
    46 
    +strLiteralWithUnique u = mkStrLitTy . fakeFastString u
    47 
    +
    48 
    +fakeFastString :: Int -> String -> FastString
    49 
    +fakeFastString u s = FastString
    50 
    +  { uniq = u
    51 
    +  , n_chars = length s
    52 
    +  , fs_sbs = SBS.pack (map (fromIntegral . ord) s)
    53 
    +  , fs_zenc = error "unused"
    54 
    +  }
    55 
    +
    56 
    +assert :: String -> Bool -> IO ()
    57 
    +assert label condition = unless condition $
    58 
    +  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}"')
    74 74 
     test('T26120', [], compile_and_run, ['-package ghc'])
    75 75
    76 76 
     test('T26264', normal, compile_and_run, ['-package ghc'])
    77 
    +test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])

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