[Git][ghc/ghc][ghc-9.10] 4 commits: Revert "ghcup-metadata: Drop output_name field"

Ben Gamari (@bgamari) gitlab at gitlab.haskell.org
Thu May 9 19:37:13 UTC 2024



Ben Gamari pushed to branch ghc-9.10 at Glasgow Haskell Compiler / GHC


Commits:
c192d254 by Ben Gamari at 2024-05-09T11:49:25-04:00
Revert "ghcup-metadata: Drop output_name field"

This reverts commit 250c5df7875658f172804f511cd7eb325392f347.

- - - - -
923e21bc by Ben Gamari at 2024-05-09T11:49:26-04:00
ghcup-metadata: Drop output_name

This is entirely redundant to the filename of the URL. There is no
compelling reason to name the downloaded file differently from its
source.

- - - - -
78092043 by Ryan Scott at 2024-05-09T11:49:26-04:00
unboxedSum{Type,Data}Name: Use GHC.Types as the module

Unboxed sum constructors are now defined in the `GHC.Types` module, so if you
manually quote an unboxed sum (e.g., `''Sum2#`), you will get a `Name` like:

```hs
GHC.Types.Sum2#
```

The `unboxedSumTypeName` function in `template-haskell`, however, mistakenly
believes that unboxed sum constructors are defined in `GHC.Prim`, so
`unboxedSumTypeName 2` would return an entirely different `Name`:

```hs
GHC.Prim.(#|#)
```

This is a problem for Template Haskell users, as it means that they can't be
sure which `Name` is the correct one. (Similarly for `unboxedSumDataName`.)

This patch fixes the implementations of `unboxedSum{Type,Data}Name` to use
`GHC.Types` as the module. For consistency with `unboxedTupleTypeName`, the
`unboxedSumTypeName` function now uses the non-punned syntax for unboxed sums
(`Sum<N>#`) as the `OccName`.

Fixes #24750.

- - - - -
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)

- - - - -


8 changed files:

- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- 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:

=====================================
.gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
=====================================
@@ -65,6 +65,7 @@ eprint(f"Supported platforms: {job_mapping.keys()}")
 class Artifact(NamedTuple):
     job_name: str
     download_name: str
+    output_name: Optional[str]
     subdir: str
 
 # Platform spec provides a specification which is agnostic to Job
@@ -75,9 +76,11 @@ class PlatformSpec(NamedTuple):
 
 source_artifact = Artifact('source-tarball'
                           , 'ghc-{version}-src.tar.xz'
+                          , None
                           , 'ghc-{version}' )
 test_artifact = Artifact('source-tarball'
                         , 'ghc-{version}-testsuite.tar.xz'
+                        , None
                         , 'ghc-{version}/testsuite' )
 
 def debian(arch, n):
@@ -111,8 +114,7 @@ def linux_platform(arch, opsys):
 
 base_url = 'https://gitlab.haskell.org/api/v4/projects/1/jobs/{job_id}/artifacts/{artifact_name}'
 
-
-hash_cache = {}
+hash_cache = {} # type: Dict[str, str]
 
 # Download a URL and return its hash
 def download_and_hash(url):
@@ -166,12 +168,15 @@ def mk_one_metadata(release_mode, version, job_map, artifact):
 
 # Turns a platform into an Artifact respecting pipeline_type
 # Looks up the right job to use from the .gitlab/jobs-metadata.json file
-def mk_from_platform(pipeline_type, platform):
+def mk_from_platform(release_mode, pipeline_type, platform):
     info = job_mapping[platform.name][pipeline_type]
     eprint(f"From {platform.name} / {pipeline_type} selecting {info['name']}")
+    output_name = None
+    if not release_mode:
+        output_name = "ghc-{version}-{pn}.tar.xz".format(version="{version}", pn=platform.name)
     return Artifact(info['name']
                    , f"{info['jobInfo']['bindistName']}.tar.xz"
-                   , "ghc-{version}-{pn}.tar.xz".format(version="{version}", pn=platform.name)
+                   , output_name
                    , platform.subdir)
 
 
@@ -179,7 +184,7 @@ def mk_from_platform(pipeline_type, platform):
 def mk_new_yaml(release_mode, version, date, pipeline_type, job_map):
     def mk(platform):
         eprint("\n=== " + platform.name + " " + ('=' * (75 - len(platform.name))))
-        return mk_one_metadata(release_mode, version, job_map, mk_from_platform(pipeline_type, platform))
+        return mk_one_metadata(release_mode, version, job_map, mk_from_platform(release_mode, pipeline_type, platform))
 
     ubuntu1804 = mk(ubuntu("18_04"))
     ubuntu2004 = mk(ubuntu("20_04"))


=====================================
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
@@ -1951,7 +1955,7 @@ unboxedSumDataName alt arity
 
   | otherwise
   = Name (mkOccName sum_occ)
-         (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))
+         (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))
 
   where
     prefix     = "unboxedSumDataName: "
@@ -1970,11 +1974,11 @@ unboxedSumTypeName arity
 
   | otherwise
   = Name (mkOccName sum_occ)
-         (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))
+         (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))
 
   where
     -- Synced with the definition of mkSumTyConOcc in GHC.Builtin.Types
-    sum_occ = '(' : '#' : replicate (arity - 1) '|' ++ "#)"
+    sum_occ = "Sum" ++ show arity ++ "#"
 
 -----------------------------------------------------
 --              Locations


=====================================
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/-/compare/776fa6e1722bf1f084ae7cff7ef99c8d10b2ea74...2cc6968a0e70967a0fe906ff27957030eab40889

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/776fa6e1722bf1f084ae7cff7ef99c8d10b2ea74...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/ddc527ed/attachment-0001.html>


More information about the ghc-commits mailing list