[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Hadrian: generalise &%> to avoid warnings
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jan 16 14:07:47 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
0d939e61 by sheaf at 2023-01-16T12:51:42+01:00
Hadrian: generalise &%> to avoid warnings
This patch introduces a more general version of &%> that works
with general traversable shapes, instead of lists. This allows us
to pass along the information that the length of the list of filepaths
passed to the function exactly matches the length of the input list
of filepath patterns, avoiding pattern match warnings.
Fixes #22430
- - - - -
c99de7db by Andreas Klebinger at 2023-01-16T09:07:36-05:00
Add regression test for #22611.
A case were a function used to fail to specialize, but now does.
- - - - -
bc1b0530 by Bodigrim at 2023-01-16T09:07:37-05:00
Bump submodule parsec to 3.1.16.1
- - - - -
11 changed files:
- hadrian/src/Base.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Rules/Compile.hs
- hadrian/src/Rules/Dependencies.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Gmp.hs
- hadrian/src/Rules/Libffi.hs
- libraries/parsec
- + testsuite/tests/simplCore/should_compile/T22611.hs
- + testsuite/tests/simplCore/should_compile/T22611.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
hadrian/src/Base.hs
=====================================
@@ -1,4 +1,10 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
module Base (
-- * General utilities
@@ -15,6 +21,8 @@ module Base (
module Development.Shake.FilePath,
module Development.Shake.Util,
+ Vec(..), (&%>),
+
-- * Basic data types
module Hadrian.Package,
module Stage,
@@ -36,14 +44,19 @@ module Base (
import Control.Applicative
import Control.Monad.Extra
import Control.Monad.Reader
+import Control.Monad.State ( State )
+import qualified Control.Monad.State as State
+import Data.Foldable (toList)
+import Data.Kind
import Data.List.Extra
import Data.Maybe
import Data.Semigroup
#if MIN_VERSION_shake(0,19,0)
-import Development.Shake hiding (unit, Normal)
+import Development.Shake hiding (unit, (&%>), Normal)
#else
-import Development.Shake hiding (unit, (*>), Normal)
+import Development.Shake hiding (unit, (&%>), (*>), Normal)
#endif
+import qualified Development.Shake as Shake
import Development.Shake.Classes
import Development.Shake.FilePath
import Development.Shake.Util
@@ -51,6 +64,8 @@ import Hadrian.Oracles.DirectoryContents
import Hadrian.Utilities
import Hadrian.Package
+import GHC.Stack ( HasCallStack )
+
import Stage
import Way
@@ -156,3 +171,43 @@ templateHscPath stage = stageLibPath stage <&> (-/- "template-hsc.h")
-- Windows). See "Rules.Program".
mingwStamp :: FilePath
mingwStamp = "mingw" -/- ".stamp"
+
+-- | Same as @'Development.Shake.&%>'@ except that it works with an arbitrary
+-- traversable structure of 'FilePattern's, which avoids running into incomplete
+-- pattern match warnings (see #22430).
+(&%>) :: (HasCallStack, Traversable t, Show (t FilePath))
+ => t FilePattern -> (t FilePath -> Action ()) -> Rules ()
+ps &%> f = toList ps Shake.&%> ( \ fs -> f (fromListWithShape ps fs) )
+
+-- | Utility function that fills in the values of a traversable shape
+-- with the elements of the provided list.
+fromListWithShape :: forall t a b
+ . ( HasCallStack, Show (t a), Show b, Traversable t )
+ => t a -> [b] -> t b
+fromListWithShape shape elts =
+ traverse (const getElt) shape `State.evalState` elts
+ where
+ getElt :: State [b] b
+ getElt = do { s <- State.get
+ ; case s of
+ { [] -> error $ "fromListWithShape: not enough elements to fill this shape\n"
+ ++ "elements: " ++ show elts ++"\n"
+ ++ "shape: " ++ show shape
+ ; b:bs ->
+ do { State.put bs
+ ; return b } } }
+
+infixr 5 :&
+data Nat = Zero | Succ Nat
+
+-- | A traversable vector type, defined for convenient use with '(&%>)'.
+type Vec :: Nat -> Type -> Type
+data Vec n a where
+ Nil :: Vec Zero a
+ (:&) :: a -> Vec n a -> Vec (Succ n) a
+
+deriving instance Functor (Vec n)
+deriving instance Foldable (Vec n)
+deriving instance Traversable (Vec n)
+instance Show a => Show (Vec n a) where
+ showsPrec p v = showsPrec p (toList v)
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -212,14 +212,18 @@ resolveContextData context at Context {..} = do
-- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
-- See: https://github.com/snowleopard/hadrian/issues/548
- let extDeps = externalPackageDeps lbi'
- deps = map (C.display . snd) extDeps
- depDirect = map (fromMaybe (error "resolveContextData: depDirect failed")
- . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps
- depIds = map (C.display . Installed.installedUnitId) depDirect
- Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
- depPkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
- forDeps f = concatMap f depPkgs
+ let extDeps = externalPackageDeps lbi'
+ deps = map (C.display . snd) extDeps
+ depDirect = map (fromMaybe (error "resolveContextData: depDirect failed")
+ . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps
+ depIds = map (C.display . Installed.installedUnitId) depDirect
+ ghcProg =
+ case C.lookupProgram C.ghcProgram (C.withPrograms lbi') of
+ Just ghc -> ghc
+ Nothing -> error "resolveContextData: failed to look up 'ghc'"
+
+ depPkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
+ forDeps f = concatMap f depPkgs
-- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
packageHacks = case C.compilerFlavor (C.compiler lbi') of
=====================================
hadrian/src/Rules/Compile.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
module Rules.Compile (compilePackage) where
import Hadrian.BuildPath
@@ -57,8 +59,8 @@ compilePackage rs = do
-- When building dynamically we depend on the static rule if shared libs
-- are supported, because it will add the -dynamic-too flag when
-- compiling to build the dynamic files alongside the static files
- [ root -/- "**/build/**/*.dyn_o", root -/- "**/build/**/*.dyn_hi" ]
- &%> \ [dyn_o, _dyn_hi] -> do
+ ( root -/- "**/build/**/*.dyn_o" :& root -/- "**/build/**/*.dyn_hi" :& Nil )
+ &%> \ ( dyn_o :& _dyn_hi :& _ ) -> do
p <- platformSupportsSharedLibs
if p
then do
@@ -80,9 +82,11 @@ compilePackage rs = do
else compileHsObjectAndHi rs dyn_o
forM_ ((,) <$> hsExts <*> wayPats) $ \ ((oExt, hiExt), wayPat) ->
- [ root -/- "**/build/**/*." ++ wayPat ++ oExt
- , root -/- "**/build/**/*." ++ wayPat ++ hiExt ]
- &%> \ [o, _hi] -> compileHsObjectAndHi rs o
+ ( (root -/- "**/build/**/*." ++ wayPat ++ oExt)
+ :& (root -/- "**/build/**/*." ++ wayPat ++ hiExt)
+ :& Nil ) &%>
+ \ ( o :& _hi :& _ ) ->
+ compileHsObjectAndHi rs o
where
hsExts = [ ("o", "hi")
, ("o-boot", "hi-boot")
=====================================
hadrian/src/Rules/Dependencies.hs
=====================================
@@ -1,7 +1,6 @@
module Rules.Dependencies (buildPackageDependencies) where
import Data.Bifunctor
-import Data.Function
import qualified Data.List.NonEmpty as NE
import Base
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
module Rules.Documentation (
-- * Rules
buildPackageDocumentation, documentationRules,
@@ -333,7 +335,7 @@ buildSphinxInfoGuide = do
-- default target of which actually produces the target
-- for this build rule.
let p = dir -/- path
- let [texipath, infopath] = map (p <.>) ["texi", "info"]
+ let (texipath :& infopath :& _) = fmap (p <.>) ("texi" :& "info" :& Nil)
build $ target docContext (Makeinfo) [texipath] [infopath]
copyFileUntracked infopath file
=====================================
hadrian/src/Rules/Gmp.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
module Rules.Gmp (gmpRules, gmpBuildPath, gmpObjects) where
import Base
@@ -96,7 +98,8 @@ gmpRules = do
-- - <root>/stageN/gmp/gmp.h
-- - <root>/stageN/gmp/libgmp.a
-- - <root>/stageN/gmp/objs/*.o (unpacked objects from libgmp.a)
- [gmpPath -/- "libgmp.a", gmpPath -/- "gmp.h"] &%> \[lib,header] -> do
+ (gmpPath -/- "libgmp.a" :& gmpPath -/- "gmp.h" :& Nil) &%>
+ \( lib :& header :& _) -> do
let gmpP = takeDirectory lib
ctx <- makeGmpPathContext gmpP
-- build libgmp.a via gmp's Makefile
@@ -133,7 +136,8 @@ gmpRules = do
-- Extract in-tree GMP sources and apply patches. Produce
-- - <root>/stageN/gmp/gmpbuild/Makefile.in
-- - <root>/stageN/gmp/gmpbuild/configure
- [gmpPath -/- "gmpbuild/Makefile.in", gmpPath -/- "gmpbuild/configure"] &%> \[mkIn,_] -> do
+ (gmpPath -/- "gmpbuild/Makefile.in" :& gmpPath -/- "gmpbuild/configure" :& Nil)
+ &%> \( mkIn :& _ ) -> do
top <- topDirectory
let gmpBuildP = takeDirectory mkIn
gmpP = takeDirectory gmpBuildP
=====================================
hadrian/src/Rules/Libffi.hs
=====================================
@@ -202,7 +202,8 @@ libffiRules = do
writeFileLines dynLibMan dynLibFiles
putSuccess "| Successfully build libffi."
- fmap (libffiPath -/-) ["Makefile.in", "configure" ] &%> \[mkIn, _] -> do
+ fmap (libffiPath -/-) ( "Makefile.in" :& "configure" :& Nil ) &%>
+ \ ( mkIn :& _ ) -> do
-- Extract libffi tar file
context <- libffiContext stage
removeDirectory libffiPath
@@ -225,7 +226,8 @@ libffiRules = do
files <- liftIO $ getDirectoryFilesIO "." [libffiPath -/- "**"]
produces files
- fmap (libffiPath -/-) ["Makefile", "config.guess", "config.sub"] &%> \[mk, _, _] -> do
+ fmap (libffiPath -/-) ("Makefile" :& "config.guess" :& "config.sub" :& Nil)
+ &%> \( mk :& _ ) -> do
_ <- needLibfffiArchive libffiPath
context <- libffiContext stage
=====================================
libraries/parsec
=====================================
@@ -1 +1 @@
-Subproject commit 0e23b3246fd7f6d125129316dcbedd609e6d2dca
+Subproject commit 1f542120d9adc5e22f8791a6d595210e93c6c389
=====================================
testsuite/tests/simplCore/should_compile/T22611.hs
=====================================
@@ -0,0 +1,23 @@
+-- The method `alterF` inside containers is marked as INLINEABLE
+-- and hence should be specialized to the `CheckRes` Functor.
+
+-- This only started to work with 9.6, this test checks that we don't
+-- regress on this.
+
+{-# language LambdaCase, Strict, DeriveFunctor, DerivingStrategies #-}
+
+module T22611 where
+
+import Data.Map.Strict as Map
+import qualified Data.Map.Strict as Map
+
+foo :: Either Int Char -> Map (Either Int Char) v -> Maybe (v, (Map (Either Int Char) v))
+foo x subst = case Map.alterF alt x subst of
+ NotFound -> foo (fmap (toEnum . (+1) . fromEnum) x) subst
+ Found p q -> Just (p, q)
+ where
+ alt :: Maybe a1 -> CheckRes a1 (Maybe a2)
+ alt = (\case {Nothing -> NotFound; Just t -> Found t Nothing})
+
+data CheckRes a m = NotFound | Found !a ~m
+ deriving stock Functor
=====================================
testsuite/tests/simplCore/should_compile/T22611.stderr
=====================================
@@ -0,0 +1,285 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 544, types: 486, coercions: 0, joins: 0/7}
+
+$WFound
+ = \ @a @m conrep conrep1 ->
+ case conrep of conrep2 { __DEFAULT -> Found conrep2 conrep1 }
+
+$fFunctorCheckRes_$c<$
+ = \ @a @a1 @b z ds ->
+ case z of z1 { __DEFAULT ->
+ case ds of {
+ NotFound -> NotFound;
+ Found a2 a3 -> Found a2 z1
+ }
+ }
+
+$fFunctorCheckRes_$cfmap
+ = \ @a @a1 @b f ds ->
+ case f of f1 { __DEFAULT ->
+ case ds of {
+ NotFound -> NotFound;
+ Found a2 a3 -> Found a2 (f1 a3)
+ }
+ }
+
+$fFunctorCheckRes
+ = \ @a -> C:Functor $fFunctorCheckRes_$cfmap $fFunctorCheckRes_$c<$
+
+Rec {
+$w$sgo15
+ = \ @a1 ww ww1 ds ds1 ->
+ case ds of ds2 { __DEFAULT ->
+ case ds1 of {
+ Bin ipv2 ipv3 ipv4 ipv5 ipv6 ->
+ case ds2 of wild1 {
+ Left a2 ->
+ case ipv3 of {
+ Left b2 ->
+ case a2 of { I# x# ->
+ case b2 of { I# y# ->
+ case <# x# y# of {
+ __DEFAULT ->
+ case ==# x# y# of {
+ __DEFAULT ->
+ $w$sgo15
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv6;
+ 1# ->
+ case ww1 of ds3 {
+ __DEFAULT ->
+ let {
+ hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+ let { zeros = word2Int# (ctz# ds3) } in
+ (# Just ipv4, uncheckedShiftRL# hi1 zeros,
+ or#
+ (uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#))
+ zeros)
+ (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ 0## ->
+ (# Just ipv4, 0##,
+ uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (word2Int# (ctz# ww)) #)
+ }
+ };
+ 1# ->
+ $w$sgo15
+ (uncheckedShiftRL# ww 1#)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv5
+ }
+ }
+ };
+ Right ipv ->
+ $w$sgo15
+ (uncheckedShiftRL# ww 1#)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv5
+ };
+ Right a2 ->
+ case ipv3 of {
+ Left ipv ->
+ $w$sgo15
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv6;
+ Right b2 ->
+ case a2 of { C# x ->
+ case b2 of { C# y ->
+ case eqChar# x y of {
+ __DEFAULT ->
+ case leChar# x y of {
+ __DEFAULT ->
+ $w$sgo15
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv6;
+ 1# ->
+ $w$sgo15
+ (uncheckedShiftRL# ww 1#)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv5
+ };
+ 1# ->
+ case ww1 of ds3 {
+ __DEFAULT ->
+ let {
+ hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+ let { zeros = word2Int# (ctz# ds3) } in
+ (# Just ipv4, uncheckedShiftRL# hi1 zeros,
+ or#
+ (uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros)
+ (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ 0## ->
+ (# Just ipv4, 0##,
+ uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (word2Int# (ctz# ww)) #)
+ }
+ }
+ }
+ }
+ }
+ };
+ Tip ->
+ case ww1 of ds3 {
+ __DEFAULT ->
+ let {
+ hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+ let { zeros = word2Int# (ctz# ds3) } in
+ (# Nothing, uncheckedShiftRL# hi1 zeros,
+ or#
+ (uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros)
+ (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ 0## ->
+ (# Nothing, 0##,
+ uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (word2Int# (ctz# ww)) #)
+ }
+ }
+ }
+end Rec }
+
+$salterF
+ = \ @v @a f1 k1 m ->
+ case $w$sgo15 9223372036854775808## 0## k1 m of
+ { (# ww, ww1, ww2 #) ->
+ case f1 ww of {
+ NotFound -> NotFound;
+ Found a1 a2 ->
+ Found
+ a1
+ (case a2 of {
+ Nothing ->
+ case ww of {
+ Nothing -> m;
+ Just old -> case $wbogus (##) of { __DEFAULT -> $wgo ww1 ww2 m }
+ };
+ Just new ->
+ case new of new1 { __DEFAULT ->
+ case ww of {
+ Nothing -> $winsertAlong ww1 ww2 k1 new1 m;
+ Just ds -> $wreplaceAlong ww1 ww2 new1 m
+ }
+ }
+ })
+ }
+ }
+
+lvl
+ = \ @v ds ->
+ case ds of {
+ Nothing -> NotFound;
+ Just t -> case t of conrep { __DEFAULT -> Found conrep Nothing }
+ }
+
+Rec {
+$wfoo
+ = \ @v x subst ->
+ case $salterF lvl x subst of {
+ NotFound ->
+ case x of wild1 {
+ Left x1 -> $wfoo wild1 subst;
+ Right y ->
+ $wfoo
+ (Right
+ (case y of { C# c# ->
+ let { i# = +# (ord# c#) 1# } in
+ case leWord# (int2Word# i#) 1114111## of {
+ __DEFAULT -> $wlvl i#;
+ 1# -> C# (chr# i#)
+ }
+ }))
+ subst
+ };
+ Found p q -> (# p, q #)
+ }
+end Rec }
+
+foo
+ = \ @v x subst ->
+ case $wfoo x subst of { (# ww, ww1 #) -> Just (ww, ww1) }
+
+$trModule4 = "main"#
+
+$trModule3 = TrNameS $trModule4
+
+$trModule2 = "T22611"#
+
+$trModule1 = TrNameS $trModule2
+
+$trModule = Module $trModule3 $trModule1
+
+$krep = KindRepVar 1#
+
+$krep1 = KindRepVar 0#
+
+$tcCheckRes2 = "CheckRes"#
+
+$tcCheckRes1 = TrNameS $tcCheckRes2
+
+$tcCheckRes
+ = TyCon
+ 2720702776801478797#Word64
+ 9603347784695333983#Word64
+ $trModule
+ $tcCheckRes1
+ 0#
+ krep$*->*->*
+
+$krep2 = : $krep []
+
+$krep3 = : $krep1 $krep2
+
+$tc'NotFound1 = KindRepTyConApp $tcCheckRes $krep3
+
+$tc'NotFound3 = "'NotFound"#
+
+$tc'NotFound2 = TrNameS $tc'NotFound3
+
+$tc'NotFound
+ = TyCon
+ 11874520794839816490#Word64
+ 7404827959462889921#Word64
+ $trModule
+ $tc'NotFound2
+ 2#
+ $tc'NotFound1
+
+$krep4 = KindRepFun $krep $tc'NotFound1
+
+$tc'Found1 = KindRepFun $krep1 $krep4
+
+$tc'Found3 = "'Found"#
+
+$tc'Found2 = TrNameS $tc'Found3
+
+$tc'Found
+ = TyCon
+ 14824125456853884021#Word64
+ 17338070180827954559#Word64
+ $trModule
+ $tc'Found2
+ 2#
+ $tc'Found1
+
+
+------ Local rules for imported ids --------
+"SPEC/T22611 alterF @(CheckRes v) @(Either Int Char) @_" [2]
+ forall @v @a $dFunctor $dOrd. alterF $dFunctor $dOrd = $salterF
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -468,3 +468,5 @@ test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
test('T22662', normal, compile, [''])
test('T22725', normal, compile, ['-O'])
test('T22502', normal, compile, ['-O'])
+test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea9441f4b63db4aaf6c5c2d6d0a9ac55f664bc20...bc1b053065cdd25d6ad209f2cf61227bcd0fe70b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea9441f4b63db4aaf6c5c2d6d0a9ac55f664bc20...bc1b053065cdd25d6ad209f2cf61227bcd0fe70b
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/20230116/cc645669/attachment-0001.html>
More information about the ghc-commits
mailing list