[Git][ghc/ghc][wip/ghc-9.10] Fix tuple puns renaming (24702)
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Thu May 9 15:51:25 UTC 2024
Ben Gamari pushed to branch wip/ghc-9.10 at Glasgow Haskell Compiler / GHC
Commits:
2cc6968a by Andrei Borzenkov at 2024-05-09T11:51:06-04:00
Fix tuple puns renaming (24702)
Move tuple renaming short cutter from `isBuiltInOcc_maybe` to `isPunOcc_maybe`, so we consider incoming module.
I also fixed some hidden bugs that raised after the change was done.
(cherry picked from commit 94da936507c685aa8101a714e7619b4d428d0187)
- - - - -
7 changed files:
- compiler/GHC/Builtin/Types.hs
- libraries/ghc-boot/GHC/Utils/Encoding.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- + testsuite/tests/th/T24702a.hs
- + testsuite/tests/th/T24702b.hs
- testsuite/tests/th/TH_tuple1.stdout
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -795,7 +795,7 @@ We make boxed one-tuple names have known keys so that `data Solo a = MkSolo a`,
defined in GHC.Tuple, will be used when one-tuples are spliced in through
Template Haskell. This program (from #18097) crucially relies on this:
- case $( tupE [ [| "ok" |] ] ) of Solo x -> putStrLn x
+ case $( tupE [ [| "ok" |] ] ) of MkSolo x -> putStrLn x
Unless Solo has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an
ExplicitTuple of length 1) will not match the type of Solo (an ordinary
@@ -838,26 +838,10 @@ isBuiltInOcc_maybe occ =
, (commas, rest') <- BS.span (==',') rest
, ")" <- rest'
-> Just $ tup_name Boxed (1+BS.length commas)
- _ | Just rest <- "Tuple" `BS.stripPrefix` name
- , Just (num, trailing) <- BS.readInt rest
- , num >= 2 && num <= 64
- -> if
- | BS.null trailing -> Just $ tup_name Boxed num
- | "#" == trailing -> Just $ tup_name Unboxed num
- | otherwise -> Nothing
-
- "CUnit" -> Just $ choose_ns (cTupleTyConName 0) (cTupleDataConName 0)
- "CSolo" -> Just $ choose_ns (cTupleTyConName 1) (cTupleDataConName 1)
- _ | Just rest <- "CTuple" `BS.stripPrefix` name
- , Just (num, trailing) <- BS.readInt rest
- , BS.null trailing
- , num >= 2 && num <= 64
- -> Just $ choose_ns (cTupleTyConName num) (cTupleDataConName num)
-- unboxed tuple data/tycon
"(##)" -> Just $ tup_name Unboxed 0
- "Unit#" -> Just $ tup_name Unboxed 0
- "Solo#" -> Just $ tup_name Unboxed 1
+ "(# #)" -> Just $ tup_name Unboxed 1
_ | Just rest <- "(#" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
, "#)" <- rest'
@@ -878,11 +862,6 @@ isBuiltInOcc_maybe occ =
-> let arity = nb_pipes1 + nb_pipes2 + 1
alt = nb_pipes1 + 1
in Just $ dataConName $ sumDataCon alt arity
- _ | Just rest <- "Sum" `BS.stripPrefix` name
- , Just (num, trailing) <- BS.readInt rest
- , num >= 2 && num <= 64
- , trailing == "#"
- -> Just $ tyConName $ sumTyCon num
_ -> Nothing
where
@@ -920,6 +899,21 @@ isTupleTyOcc_maybe mod occ
| otherwise = isTupleNTyOcc_maybe occ
isTupleTyOcc_maybe _ _ = Nothing
+isCTupleOcc_maybe :: Module -> OccName -> Maybe Name
+isCTupleOcc_maybe mod occ
+ | mod == gHC_CLASSES
+ = match_occ
+ where
+ match_occ
+ | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0)
+ | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1)
+ | 'C':'T':'u':'p':'l':'e' : rest <- occNameString occ
+ , Just (BoxedTuple, num) <- arity_and_boxity rest
+ , num >= 2 && num <= 64
+ = Just $ cTupleTyConName num
+ | otherwise = Nothing
+
+isCTupleOcc_maybe _ _ = Nothing
-- | This is only for Tuple<n>, not for Unit or Solo
isTupleNTyOcc_maybe :: OccName -> Maybe Name
@@ -985,13 +979,12 @@ isPunOcc_maybe :: Module -> OccName -> Maybe Name
isPunOcc_maybe mod occ
| mod == gHC_TYPES, occ == occName listTyConName
= Just listTyConName
- | mod == gHC_INTERNAL_TUPLE, occ == occName unitTyConName
- = Just unitTyConName
- | mod == gHC_TYPES, occ == occName unboxedUnitTyConName
- = Just unboxedUnitTyConName
- | mod == gHC_INTERNAL_TUPLE || mod == gHC_TYPES
- = isTupleNTyOcc_maybe occ <|> isSumNTyOcc_maybe occ
-isPunOcc_maybe _ _ = Nothing
+ | mod == gHC_TYPES, occ == occName unboxedSoloDataConName
+ = Just unboxedSoloDataConName
+ | otherwise
+ = isTupleTyOcc_maybe mod occ <|>
+ isCTupleOcc_maybe mod occ <|>
+ isSumTyOcc_maybe mod occ
mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
-- No need to cache these, the caching is done in mk_tuple
@@ -1304,6 +1297,8 @@ unboxedSoloTyCon = tupleTyCon Unboxed 1
unboxedSoloTyConName :: Name
unboxedSoloTyConName = tyConName unboxedSoloTyCon
+unboxedSoloDataConName :: Name
+unboxedSoloDataConName = tupleDataConName Unboxed 1
{- *********************************************************************
* *
=====================================
libraries/ghc-boot/GHC/Utils/Encoding.hs
=====================================
@@ -236,7 +236,6 @@ maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
(n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
_ -> Nothing
maybe_tuple "()" = Just("Z0T")
-maybe_tuple "MkSolo" = Just("Z1T")
maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
(n, ')' : _) -> Just ('Z' : shows (n+1) "T")
_ -> Nothing
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -1924,15 +1924,19 @@ mk_tup_name n space boxed
| boxed = "(" ++ thing ++ ")"
| otherwise = "(#" ++ thing ++ "#)"
tup_occ | n == 0, space == TcClsName = if boxed then "Unit" else "Unit#"
- | n == 1 = if boxed then solo else "Solo#"
+ | n == 1 = if boxed then solo else unboxed_solo
| space == TcClsName = "Tuple" ++ show n ++ if boxed then "" else "#"
| otherwise = withParens (replicate n_commas ',')
n_commas = n - 1
- tup_mod = mkModName (if boxed then "GHC.Tuple" else "GHC.Prim")
+ tup_mod = mkModName (if boxed then "GHC.Tuple" else "GHC.Types")
solo
| space == DataName = "MkSolo"
| otherwise = "Solo"
+ unboxed_solo
+ | space == DataName = "(# #)"
+ | otherwise = "Solo#"
+
-- Unboxed sum data and type constructors
-- | Unboxed sum data constructor
unboxedSumDataName :: SumAlt -> SumArity -> Name
=====================================
testsuite/tests/th/T24702a.hs
=====================================
@@ -0,0 +1,55 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedTuples #-}
+module T24702a where
+
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
+
+$(do
+ let
+ step = \acc n -> acc `appT` n
+ args n = replicate n (conT ''Int)
+
+ mkTupleTest mkTupTy mkTupCon boxity n = do
+ let
+ nil = conT (mkTupTy n)
+ tup = foldl step nil (args n)
+ f <- newName (boxity <> show n)
+
+ -- f<n> :: (,,..n..,,) t1 t2 .. tn -> ()
+ -- f<n> = \ (_, _, ...n..., _) -> ()
+ sequence $
+ sigD f [t|$(tup) -> ()|] :
+ valD (varP f) (normalB [e| \ $(conP (mkTupCon n) (replicate n wildP)) -> ()|]) [] :
+ []
+
+ mkSumTest n = do
+ let
+ nil = conT (unboxedSumTypeName n)
+ sumTy = foldl step nil (args n)
+ mkSumAlt altN =
+ let sumDataCon = unboxedSumDataName altN n
+ varName = mkName "x" in
+ clause [conP sumDataCon [varP varName]]
+ (normalB (conE sumDataCon `appE` varE varName)) []
+ f <- newName ("sum" <> show n)
+
+ -- f<n> :: (#||...n...||#) -> (#||...n...||#)
+ -- f<n> (x||...n...||) = (x||...n...||)
+ -- f<n> (|x||...n...||) = (|x||...n...||)
+ -- ...n...
+ -- f<n> (||...n...||x) = (||...n...||x)
+ sequence $
+ sigD f [t|$(sumTy) -> $(sumTy)|] :
+ funD f (map mkSumAlt [1 .. n]) :
+ []
+
+ newDeclarationGroup <>
+ mkTupleTest
+ unboxedTupleTypeName unboxedTupleDataName "unboxed"
+ `foldMap` (64 : [0 .. 8]) <>
+ mkTupleTest
+ tupleTypeName tupleDataName "boxed"
+ `foldMap` (64 : [0 .. 8]) <>
+ mkSumTest
+ `foldMap` (63 : [2 .. 8]) )
=====================================
testsuite/tests/th/T24702b.hs
=====================================
@@ -0,0 +1,44 @@
+{-# LANGUAGE TemplateHaskell, MagicHash #-}
+module T24702b where
+
+import Language.Haskell.TH
+
+data Unit = MkUnit
+tup0 :: $(conT (mkName "Unit"))
+tup0 = MkUnit
+
+data Solo = MkSolo
+tup1 :: $(conT (mkName "Solo"))
+tup1 = MkSolo
+
+data Tuple2 = MkTuple2
+tup2 :: $(conT (mkName "Tuple2"))
+tup2 = MkTuple2
+
+data CUnit = MkCUnit
+ctup0 :: $(conT (mkName "CUnit"))
+ctup0 = MkCUnit
+
+data CSolo = MkCSolo
+ctup1 :: $(conT (mkName "CSolo"))
+ctup1 = MkCSolo
+
+data CTuple2 = MkCTuple2
+ctup2 :: $(conT (mkName "CTuple2"))
+ctup2 = MkCTuple2
+
+data Unit# = MkUnit#
+utup0 :: $(conT (mkName "Unit#"))
+utup0 = MkUnit#
+
+data Solo# = MkSolo#
+utup1 :: $(conT (mkName "Solo#"))
+utup1 = MkSolo#
+
+data Tuple2# = MkTuple2#
+utup2 :: $(conT (mkName "Tuple2#"))
+utup2 = MkTuple2#
+
+data Sum2# = MkSum2#
+sum2 :: $(conT (mkName "Sum2#"))
+sum2 = MkSum2#
=====================================
testsuite/tests/th/TH_tuple1.stdout
=====================================
@@ -3,8 +3,8 @@ GHC.Tuple.(,) 1 2 :: GHC.Tuple.Tuple2 GHC.Num.Integer.Integer
GHC.Num.Integer.Integer
SigE (AppE (ConE GHC.Tuple.MkSolo) (LitE (IntegerL 1))) (AppT (ConT GHC.Tuple.Solo) (ConT GHC.Num.Integer.Integer))
GHC.Tuple.MkSolo 1 :: GHC.Tuple.Solo GHC.Num.Integer.Integer
-SigE (AppE (AppE (ConE GHC.Prim.(#,#)) (LitE (IntegerL 1))) (LitE (IntegerL 2))) (AppT (AppT (ConT GHC.Prim.Tuple2#) (ConT GHC.Num.Integer.Integer)) (ConT GHC.Num.Integer.Integer))
-GHC.Prim.(#,#) 1 2 :: GHC.Prim.Tuple2# GHC.Num.Integer.Integer
- GHC.Num.Integer.Integer
-SigE (AppE (ConE GHC.Prim.Solo#) (LitE (IntegerL 1))) (AppT (ConT GHC.Prim.Solo#) (ConT GHC.Num.Integer.Integer))
-GHC.Prim.Solo# 1 :: GHC.Prim.Solo# GHC.Num.Integer.Integer
+SigE (AppE (AppE (ConE GHC.Types.(#,#)) (LitE (IntegerL 1))) (LitE (IntegerL 2))) (AppT (AppT (ConT GHC.Types.Tuple2#) (ConT GHC.Num.Integer.Integer)) (ConT GHC.Num.Integer.Integer))
+GHC.Types.(#,#) 1 2 :: GHC.Types.Tuple2# GHC.Num.Integer.Integer
+ GHC.Num.Integer.Integer
+SigE (AppE (ConE GHC.Types.(# #)) (LitE (IntegerL 1))) (AppT (ConT GHC.Types.Solo#) (ConT GHC.Num.Integer.Integer))
+GHC.Types.(# #) 1 :: GHC.Types.Solo# GHC.Num.Integer.Integer
=====================================
testsuite/tests/th/all.T
=====================================
@@ -611,3 +611,5 @@ test('T24557b', normal, compile_fail, [''])
test('T24557c', normal, compile_fail, [''])
test('T24557d', normal, compile_fail, [''])
test('T24557e', normal, compile, [''])
+test('T24702a', normal, compile, [''])
+test('T24702b', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2cc6968a0e70967a0fe906ff27957030eab40889
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2cc6968a0e70967a0fe906ff27957030eab40889
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/20240509/b1a26208/attachment-0001.html>
More information about the ghc-commits
mailing list