[Git][ghc/ghc][wip/backports-9.4] 5 commits: haddock docs: Fix links from identifiers to dependent packages
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Oct 14 20:47:51 UTC 2022
Ben Gamari pushed to branch wip/backports-9.4 at Glasgow Haskell Compiler / GHC
Commits:
9f2bda74 by Matthew Pickering at 2022-10-14T16:26:39-04:00
haddock docs: Fix links from identifiers to dependent packages
When implementing the base_url changes I made the pretty bad mistake of
zipping together two lists which were in different orders. The simpler
thing to do is just modify `haddockDependencies` to also return the
package identifier so that everything stays in sync.
Fixes #22001
(cherry picked from commit 2361b3bc08811b0d2fb8f8fc5635b7c2fec157c6)
- - - - -
235996c2 by Ryan Scott at 2022-10-14T16:31:32-04:00
DeriveFunctor: Check for last type variables using dataConUnivTyVars
Previously, derived instances of `Functor` (as well as the related classes
`Foldable`, `Traversable`, and `Generic1`) would determine which constraints to
infer by checking for fields that contain the last type variable. The problem
was that this last type variable was taken from `tyConTyVars`. For GADTs, the
type variables in each data constructor are _not_ the same type variables as
in `tyConTyVars`, leading to #22167.
This fixes the issue by instead checking for the last type variable using
`dataConUnivTyVars`. (This is very similar in spirit to the fix for #21185,
which also replaced an errant use of `tyConTyVars` with type variables from
each data constructor.)
Fixes #22167.
(cherry picked from commit 8a666ad2a89a8ad2aa24a6406b88f516afaec671)
- - - - -
09521b70 by Ryan Scott at 2022-10-14T16:33:56-04:00
Windows: Always define _UCRT when compiling C code
As seen in #22159, this is required to ensure correct behavior when MinGW-w64
headers are in the `C_INCLUDE_PATH`.
Fixes #22159.
(cherry picked from commit 3a815f30bcba5672085e823aeef90863253b0b1a)
- - - - -
7d269ec1 by Cheng Shao at 2022-10-14T16:37:50-04:00
rts: fix missing dirty_MVAR argument in stg_writeIOPortzh
(cherry picked from commit ee471dfb8a4a4bb5131a5baa61d1d0d22c933d5f)
- - - - -
f3f737a7 by Matthew Pickering at 2022-10-14T16:47:12-04:00
Don't include BufPos in interface files
Ticket #22162 pointed out that the build directory was leaking into the
ABI hash of a module because the BufPos depended on the location of the
build tree.
BufPos is only used in GHC.Parser.PostProcess.Haddock, and the
information doesn't need to be propagated outside the context of a
module.
Fixes #22162
(cherry picked from commit 7f0decd5063a853fc8f38a8944b2c91995cd5e48)
- - - - -
17 changed files:
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Tc/Deriv/Functor.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Deriv/Infer.hs
- compiler/GHC/Types/SrcLoc.hs
- compiler/GHC/Utils/Binary.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Settings/Builders/Haddock.hs
- m4/fp_setup_windows_toolchain.m4
- rts/PrimOps.cmm
- + testsuite/tests/deriving/should_compile/T22167.hs
- testsuite/tests/deriving/should_compile/all.T
- testsuite/tests/ffi/should_run/Makefile
- + testsuite/tests/ffi/should_run/T22159.hs
- + testsuite/tests/ffi/should_run/T22159.stdout
- + testsuite/tests/ffi/should_run/T22159_c.c
- testsuite/tests/ffi/should_run/all.T
Changes:
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -781,5 +781,5 @@ toHieName name
| isKnownKeyName name = KnownKeyName (nameUnique name)
| isExternalName name = ExternalName (nameModule name)
(nameOccName name)
- (nameSrcSpan name)
- | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
+ (removeBufSpan $ nameSrcSpan name)
+ | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
=====================================
compiler/GHC/Tc/Deriv/Functor.hs
=====================================
@@ -538,8 +538,36 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
go _ _ = (caseTrivial,False)
--- Return all syntactic subterms of ty that contain var somewhere
--- These are the things that should appear in instance constraints
+-- | Return all syntactic subterms of a 'Type' that are applied to the 'TyVar'
+-- argument. This determines what constraints should be inferred for derived
+-- 'Functor', 'Foldable', and 'Traversable' instances in "GHC.Tc.Deriv.Infer".
+-- For instance, if we have:
+--
+-- @
+-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))
+-- @
+--
+-- Then the following would hold:
+--
+-- * @'deepSubtypesContaining' a Int@ would return @[]@, since @Int@ does not
+-- contain the type variable @a@ at all.
+--
+-- * @'deepSubtypesContaining' a a@ would return @[]@. Although the type @a@
+-- contains the type variable @a@, it is not /applied/ to @a@, which is the
+-- criterion that 'deepSubtypesContaining' checks for.
+--
+-- * @'deepSubtypesContaining' a (Maybe a)@ would return @[Maybe]@, as @Maybe@
+-- is applied to @a at .
+--
+-- * @'deepSubtypesContaining' a (Either Int (Maybe a))@ would return
+-- @[Either Int, Maybe]@. Both of these types are applied to @a@ through
+-- composition.
+--
+-- As used in "GHC.Tc.Deriv.Infer", the 'Type' argument will always come from
+-- 'derivDataConInstArgTys', so it is important that the 'TyVar' comes from
+-- 'dataConUnivTyVars' to match. Make sure /not/ to take the 'TyVar' from
+-- 'tyConTyVars', as these differ from the 'dataConUnivTyVars' when the data
+-- type is a GADT. (See #22167 for what goes wrong if 'tyConTyVars' is used.)
deepSubtypesContaining :: TyVar -> Type -> [TcType]
deepSubtypesContaining tv
= functorLikeTraverse tv
=====================================
compiler/GHC/Tc/Deriv/Generics.hs
=====================================
@@ -91,10 +91,25 @@ gen_Generic_binds gk loc dit = do
************************************************************************
-}
+-- | Called by 'GHC.Tc.Deriv.Infer.inferConstraints'; generates a list of
+-- types, each of which must be a 'Functor' in order for the 'Generic1'
+-- instance to work. For instance, if we have:
+--
+-- @
+-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))
+-- @
+--
+-- Then @'get_gen1_constrained_tys' a (f (g a))@ would return @[Either Int]@,
+-- as a derived 'Generic1' instance would need to call 'fmap' at that type.
+-- Invoking @'get_gen1_constrained_tys' a@ on any of the other fields would
+-- return @[]@.
+--
+-- 'get_gen1_constrained_tys' is very similar in spirit to
+-- 'deepSubtypesContaining' in "GHC.Tc.Deriv.Functor". Just like with
+-- 'deepSubtypesContaining', it is important that the 'TyVar' argument come
+-- from 'dataConUnivTyVars'. (See #22167 for what goes wrong if 'tyConTyVars'
+-- is used.)
get_gen1_constrained_tys :: TyVar -> Type -> [Type]
--- called by GHC.Tc.Deriv.Infer.inferConstraints; generates a list of
--- types, each of which must be a Functor in order for the Generic1 instance to
--- work.
get_gen1_constrained_tys argVar
= argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
, ata_par1 = [], ata_rec1 = const []
=====================================
compiler/GHC/Tc/Deriv/Infer.hs
=====================================
@@ -176,9 +176,10 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys
-- Constraints arising from the arguments of each constructor
con_arg_constraints
- :: (CtOrigin -> TypeOrKind
- -> Type
- -> [(ThetaSpec, Maybe TCvSubst)])
+ :: ([TyVar] -> CtOrigin
+ -> TypeOrKind
+ -> Type
+ -> [(ThetaSpec, Maybe TCvSubst)])
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
con_arg_constraints get_arg_constraints
= let -- Constraints from the fields of each data constructor.
@@ -193,7 +194,8 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys
, not (isUnliftedType arg_ty)
, let orig = DerivOriginDC data_con arg_n wildcard
, preds_and_mbSubst
- <- get_arg_constraints orig arg_t_or_k arg_ty
+ <- get_arg_constraints (dataConUnivTyVars data_con)
+ orig arg_t_or_k arg_ty
]
-- Stupid constraints from DatatypeContexts. Note that we
-- must gather these constraints from the data constructors,
@@ -235,21 +237,39 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys
is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind
|| is_generic1
- get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
- -> [(ThetaSpec, Maybe TCvSubst)]
- get_gen1_constraints functor_cls orig t_or_k ty
+ get_gen1_constraints ::
+ Class
+ -> [TyVar] -- The universally quantified type variables for the
+ -- data constructor
+ -> CtOrigin -> TypeOrKind -> Type
+ -> [(ThetaSpec, Maybe TCvSubst)]
+ get_gen1_constraints functor_cls dc_univs orig t_or_k ty
= mk_functor_like_constraints orig t_or_k functor_cls $
- get_gen1_constrained_tys last_tv ty
-
- get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
- -> [(ThetaSpec, Maybe TCvSubst)]
- get_std_constrained_tys orig t_or_k ty
+ get_gen1_constrained_tys last_dc_univ ty
+ where
+ -- If we are deriving an instance of 'Generic1' and have made
+ -- it this far, then there should be at least one universal type
+ -- variable, making this use of 'last' safe.
+ last_dc_univ = assert (not (null dc_univs)) $
+ last dc_univs
+
+ get_std_constrained_tys ::
+ [TyVar] -- The universally quantified type variables for the
+ -- data constructor
+ -> CtOrigin -> TypeOrKind -> Type
+ -> [(ThetaSpec, Maybe TCvSubst)]
+ get_std_constrained_tys dc_univs orig t_or_k ty
| is_functor_like
= mk_functor_like_constraints orig t_or_k main_cls $
- deepSubtypesContaining last_tv ty
+ deepSubtypesContaining last_dc_univ ty
| otherwise
= [( [mk_cls_pred orig t_or_k main_cls ty]
, Nothing )]
+ where
+ -- If 'is_functor_like' holds, then there should be at least one
+ -- universal type variable, making this use of 'last' safe.
+ last_dc_univ = assert (not (null dc_univs)) $
+ last dc_univs
mk_functor_like_constraints :: CtOrigin -> TypeOrKind
-> Class -> [Type]
@@ -277,9 +297,6 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys
, tcUnifyTy ki typeToTypeKind
)
- rep_tc_tvs = tyConTyVars rep_tc
- last_tv = last rep_tc_tvs
-
-- Extra Data constraints
-- The Data class (only) requires that for
-- instance (...) => Data (T t1 t2)
@@ -318,7 +335,7 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys
-- Generic1 needs Functor
-- See Note [Getting base classes]
| is_generic1
- -> assert (rep_tc_tvs `lengthExceeds` 0) $
+ -> assert (tyConTyVars rep_tc `lengthExceeds` 0) $
-- Generic1 has a single kind variable
assert (cls_tys `lengthIs` 1) $
do { functorClass <- lift $ tcLookupClass functorClassName
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -68,6 +68,7 @@ module GHC.Types.SrcLoc (
getBufPos,
BufSpan(..),
getBufSpan,
+ removeBufSpan,
-- * Located
Located,
@@ -398,6 +399,10 @@ data UnhelpfulSpanReason
| UnhelpfulOther !FastString
deriving (Eq, Show)
+removeBufSpan :: SrcSpan -> SrcSpan
+removeBufSpan (RealSrcSpan s _) = RealSrcSpan s Strict.Nothing
+removeBufSpan s = s
+
{- Note [Why Maybe BufPos]
~~~~~~~~~~~~~~~~~~~~~~~~~~
In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan).
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -1306,19 +1306,6 @@ instance Binary RealSrcSpan where
return (mkRealSrcSpan (mkRealSrcLoc f sl sc)
(mkRealSrcLoc f el ec))
-instance Binary BufPos where
- put_ bh (BufPos i) = put_ bh i
- get bh = BufPos <$> get bh
-
-instance Binary BufSpan where
- put_ bh (BufSpan start end) = do
- put_ bh start
- put_ bh end
- get bh = do
- start <- get bh
- end <- get bh
- return (BufSpan start end)
-
instance Binary UnhelpfulSpanReason where
put_ bh r = case r of
UnhelpfulNoLocationInfo -> putByte bh 0
@@ -1337,10 +1324,11 @@ instance Binary UnhelpfulSpanReason where
_ -> UnhelpfulOther <$> get bh
instance Binary SrcSpan where
- put_ bh (RealSrcSpan ss sb) = do
+ put_ bh (RealSrcSpan ss _sb) = do
putByte bh 0
+ -- BufSpan doesn't ever get serialised because the positions depend
+ -- on build location.
put_ bh ss
- put_ bh sb
put_ bh (UnhelpfulSpan s) = do
putByte bh 1
@@ -1350,8 +1338,7 @@ instance Binary SrcSpan where
h <- getByte bh
case h of
0 -> do ss <- get bh
- sb <- get bh
- return (RealSrcSpan ss sb)
+ return (RealSrcSpan ss Strict.Nothing)
_ -> do s <- get bh
return (UnhelpfulSpan s)
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -249,7 +249,7 @@ buildPackageDocumentation = do
vanillaSrcs <- hsSources context
let srcs = vanillaSrcs `union` generatedSrcs
- need $ srcs ++ haddocks
+ need $ srcs ++ (map snd haddocks)
-- Build Haddock documentation
-- TODO: Pass the correct way from Rules via Context.
@@ -364,8 +364,8 @@ buildManPage = do
copyFileUntracked (dir -/- "ghc.1") file
-- | Find the Haddock files for the dependencies of the current library.
-haddockDependencies :: Context -> Action [FilePath]
+haddockDependencies :: Context -> Action [(Package, FilePath)]
haddockDependencies context = do
depNames <- interpretInContext context (getContextData depNames)
- sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
+ sequence [ (,) <$> pure depPkg <*> (pkgHaddockFile $ vanillaContext Stage1 depPkg)
| Just depPkg <- map findPackageByName depNames, depPkg /= rts ]
=====================================
hadrian/src/Settings/Builders/Haddock.hs
=====================================
@@ -43,9 +43,8 @@ haddockBuilderArgs = mconcat
context <- getContext
version <- expr $ pkgVersion pkg
synopsis <- expr $ pkgSynopsis pkg
- trans_deps <- expr $ contextDependencies context
- pkgs <- expr $ mapM (pkgIdentifier . C.package) $ trans_deps
haddocks <- expr $ haddockDependencies context
+ haddocks_with_versions <- expr $ sequence $ [(,h) <$> pkgIdentifier p | (p, h) <- haddocks]
hVersion <- expr $ pkgVersion haddock
statsDir <- expr $ haddockStatsFilesDir
baseUrlTemplate <- expr (docsBaseUrl <$> userSetting defaultDocArgs)
@@ -69,7 +68,7 @@ haddockBuilderArgs = mconcat
, map ("--hide=" ++) <$> getContextData otherModules
, pure [ "--read-interface=../" ++ p
++ "," ++ baseUrl p ++ "/src/%{MODULE}.html#%{NAME},"
- ++ haddock | (p, haddock) <- zip pkgs haddocks ]
+ ++ haddock | (p, haddock) <- haddocks_with_versions ]
, pure [ "--optghc=" ++ opt | opt <- ghcOpts, not ("--package-db" `isInfixOf` opt) ]
, getInputs
, arg "+RTS"
=====================================
m4/fp_setup_windows_toolchain.m4
=====================================
@@ -82,7 +82,11 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[
CC="${mingwbin}clang.exe"
CXX="${mingwbin}clang++.exe"
- cflags="--rtlib=compiler-rt"
+
+ # Signal that we are linking against UCRT with the _UCRT macro. This is
+ # necessary to ensure correct behavior when MinGW-w64 headers are in the
+ # header include path (#22159).
+ cflags="--rtlib=compiler-rt -D_UCRT"
CFLAGS="$cflags"
CONF_CC_OPTS_STAGE1="$cflags"
CONF_CC_OPTS_STAGE2="$cflags"
=====================================
rts/PrimOps.cmm
=====================================
@@ -2226,7 +2226,7 @@ loop:
if (q == stg_END_TSO_QUEUE_closure) {
/* No takes, the IOPort is now full. */
if (info == stg_MVAR_CLEAN_info) {
- ccall dirty_MVAR(BaseReg "ptr", ioport "ptr");
+ ccall dirty_MVAR(BaseReg "ptr", ioport "ptr", StgMVar_value(ioport) "ptr");
}
StgMVar_value(ioport) = val;
=====================================
testsuite/tests/deriving/should_compile/T22167.hs
=====================================
@@ -0,0 +1,24 @@
+module T22167 where
+
+import GHC.Generics (Generic1)
+
+data T1 f a = MkT1 (f a)
+ deriving (Functor, Foldable, Traversable)
+
+data T2 f a where
+ MkT2 :: f a -> T2 f a
+ deriving (Functor, Foldable, Traversable)
+
+-- A slightly more complicated example from the `syntactic` library
+data (sym1 :+: sym2) sig
+ where
+ InjL :: sym1 a -> (sym1 :+: sym2) a
+ InjR :: sym2 a -> (sym1 :+: sym2) a
+ deriving (Functor, Foldable, Traversable)
+
+-- Test Generic1 instances with inferred Functor constraints
+data G1 f g a = MkG1 (f (g a)) deriving Generic1
+
+data G2 f g a where
+ MkG2 :: f (g a) -> G2 f g a
+ deriving Generic1
=====================================
testsuite/tests/deriving/should_compile/all.T
=====================================
@@ -139,3 +139,4 @@ test('T20387', normal, compile, [''])
test('T20501', normal, compile, [''])
test('T20719', normal, compile, [''])
test('T20994', normal, compile, [''])
+test('T22167', normal, compile, [''])
=====================================
testsuite/tests/ffi/should_run/Makefile
=====================================
@@ -49,3 +49,10 @@ T15933:
'$(TEST_HC)' $(TEST_HC_OPTS) -c T15933.hs
'$(TEST_HC)' $(TEST_HC_OPTS) T15933_c.o T15933.o -o T15933
./T15933
+
+.PHONY: T22159
+T22159:
+ C_INCLUDE_PATH=/mingw64/include '$(TEST_HC)' $(TEST_HC_OPTS) -c T22159.hs
+ C_INCLUDE_PATH=/mingw64/include '$(TEST_HC)' $(TEST_HC_OPTS) -c T22159_c.c
+ C_INCLUDE_PATH=/mingw64/include '$(TEST_HC)' $(TEST_HC_OPTS) T22159.o T22159_c.o -o T22159
+ ./T22159
=====================================
testsuite/tests/ffi/should_run/T22159.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE CPP #-}
+module Main (main) where
+
+#if defined(i386_HOST_ARCH)
+# define WINDOWS_CCONV stdcall
+#elif defined(x86_64_HOST_ARCH)
+# define WINDOWS_CCONV ccall
+#else
+# error Unknown mingw32 arch
+#endif
+
+import Foreign.C.String (peekCWString)
+import Foreign.C.Types (CWchar)
+import Foreign.Marshal.Alloc (allocaBytes)
+import Foreign.Ptr (Ptr)
+
+foreign import WINDOWS_CCONV "hello" c_hello :: Ptr CWchar -> IO ()
+
+main :: IO ()
+main = allocaBytes 12 $ \buf -> do
+ c_hello buf
+ str <- peekCWString buf
+ putStrLn str
=====================================
testsuite/tests/ffi/should_run/T22159.stdout
=====================================
@@ -0,0 +1 @@
+hello
=====================================
testsuite/tests/ffi/should_run/T22159_c.c
=====================================
@@ -0,0 +1,6 @@
+#include <stdio.h>
+#include <wchar.h>
+
+void hello(wchar_t *buf) {
+ swprintf_s(buf, 12, L"hello");
+}
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -224,3 +224,8 @@ test('IncallAffinity',
['IncallAffinity_c.c -no-hs-main'])
test('T19237', normal, compile_and_run, ['T19237_c.c'])
+
+test('T22159',
+ [unless(opsys('mingw32'), skip),
+ extra_files(['T22159_c.c'])],
+ makefile_test, ['T22159'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e4a38c8b88a93cc740b7432902e46586e10eab1...f3f737a70763a3264dbc0888dca384d147e6b31f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e4a38c8b88a93cc740b7432902e46586e10eab1...f3f737a70763a3264dbc0888dca384d147e6b31f
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/20221014/57d0cfe5/attachment-0001.html>
More information about the ghc-commits
mailing list