[Git][ghc/ghc][wip/backports-9.4] 7 commits: Simplify: Take care with eta reduction in recursive RHSs (#21652)
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Oct 14 21:10:41 UTC 2022
Ben Gamari pushed to branch wip/backports-9.4 at Glasgow Haskell Compiler / GHC
Commits:
c0b5736c by Sebastian Graf at 2022-10-14T17:10:27-04:00
Simplify: Take care with eta reduction in recursive RHSs (#21652)
Similar to the fix to #20836 in CorePrep, we now track the set of enclosing
recursive binders in the SimplEnv and SimpleOptEnv.
See Note [Eta reduction in recursive RHSs] for details.
I also updated Note [Arity robustness] with the insights Simon and I had in a
call discussing the issue.
Fixes #21652.
Unfortunately, we get a 5% ghc/alloc regression in T16577. That is due to
additional eta reduction in GHC.Read.choose1 and the resulting ANF-isation
of a large list literal at the top-level that didn't happen before (presumably
because it was too interesting to float to the top-level). There's not much we
can do about that.
Metric Increase:
T16577
(cherry picked from commit 49fb2f9b16ca987648d2ac57eecf1892d49852ec)
- - - - -
ccdaa83c by Ben Gamari at 2022-10-14T17:10:27-04:00
CmmToLlvm: Don't aliasify builtin LLVM variables
Our aliasification logic would previously turn builtin LLVM variables
into aliases, which apparently confuses LLVM. This manifested in
initializers failing to be emitted, resulting in many profiling failures
with the LLVM backend.
Fixes #22019.
(cherry picked from commit cd6f5bfd0cc2bcf74de1d9edb43fe4b338b4c4e3)
- - - - -
671491cc by Matthew Pickering at 2022-10-14T17:10:27-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)
- - - - -
6bf992e6 by Ryan Scott at 2022-10-14T17:10:27-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)
- - - - -
3eace272 by Ryan Scott at 2022-10-14T17:10:27-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)
- - - - -
9ae4865b by Cheng Shao at 2022-10-14T17:10:27-04:00
rts: fix missing dirty_MVAR argument in stg_writeIOPortzh
(cherry picked from commit ee471dfb8a4a4bb5131a5baa61d1d0d22c933d5f)
- - - - -
6af677a9 by Matthew Pickering at 2022-10-14T17:10:27-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)
- - - - -
30 changed files:
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Utils.hs
- 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/arityanal/should_compile/Arity03.stderr
- + testsuite/tests/arityanal/should_run/Makefile
- + testsuite/tests/arityanal/should_run/T21652.hs
- + testsuite/tests/arityanal/should_run/T21652.stdout
- + testsuite/tests/arityanal/should_run/all.T
- testsuite/tests/deSugar/should_compile/T19969.stderr
- + 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/CmmToLlvm/Base.hs
=====================================
@@ -67,7 +67,7 @@ import GHC.Utils.Logger
import Data.Maybe (fromJust)
import Control.Monad (ap)
import Data.Char (isDigit)
-import Data.List (sortBy, groupBy, intercalate)
+import Data.List (sortBy, groupBy, intercalate, isPrefixOf)
import Data.Ord (comparing)
import qualified Data.List.NonEmpty as NE
@@ -550,6 +550,12 @@ generateExternDecls = do
modifyEnv $ \env -> env { envAliases = emptyUniqSet }
return (concat defss, [])
+-- | Is a variable one of the special @$llvm@ globals?
+isBuiltinLlvmVar :: LlvmVar -> Bool
+isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =
+ "$llvm" `isPrefixOf` unpackFS lbl
+isBuiltinLlvmVar _ = False
+
-- | Here we take a global variable definition, rename it with a
-- @$def@ suffix, and generate the appropriate alias.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
@@ -557,8 +563,9 @@ aliasify :: LMGlobal -> LlvmM [LMGlobal]
-- Here we obtain the indirectee's precise type and introduce
-- fresh aliases to both the precise typed label (lbl$def) and the i8*
-- typed (regular) label of it with the matching new names.
-aliasify (LMGlobal (LMGlobalVar lbl ty at LMAlias{} link sect align Alias)
- (Just orig)) = do
+aliasify (LMGlobal var@(LMGlobalVar lbl ty at LMAlias{} link sect align Alias)
+ (Just orig))
+ | not $ isBuiltinLlvmVar var = do
let defLbl = llvmDefLabel lbl
LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
defOrigLbl = llvmDefLabel origLbl
@@ -571,7 +578,8 @@ aliasify (LMGlobal (LMGlobalVar lbl ty at LMAlias{} link sect align Alias)
pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
, LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
]
-aliasify (LMGlobal var val) = do
+aliasify (LMGlobal var val)
+ | not $ isBuiltinLlvmVar var = do
let LMGlobalVar lbl ty link sect align const = var
defLbl = llvmDefLabel lbl
@@ -589,6 +597,7 @@ aliasify (LMGlobal var val) = do
return [ LMGlobal defVar val
, LMGlobal aliasVar (Just aliasVal)
]
+aliasify global = pure [global]
-- Note [Llvm Forward References]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -647,3 +656,6 @@ aliasify (LMGlobal var val) = do
-- away with casting the alias to the desired type in @getSymbolPtr@
-- and instead just emit a reference to the definition symbol directly.
-- This is the @Just@ case in @getSymbolPtr at .
+--
+-- Note that we must take care not to turn LLVM's builtin variables into
+-- aliases (e.g. $llvm.global_ctors) since this confuses LLVM.
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -505,6 +505,67 @@ Suppose f = \xy. x+y
Then f :: \??.T
f v :: \?.T
f <expensive> :: T
+
+
+
+Note [Eta reduction in recursive RHSs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following recursive function:
+ f = \x. ....g (\y. f y)....
+The recursive call of f in its own RHS seems like a fine opportunity for
+eta-reduction because f has arity 1. And often it is!
+
+Alas, that is unsound in general if the eta-reduction happens in a tail context.
+Making the arity visible in the RHS allows us to eta-reduce
+ f = \x -> f x
+to
+ f = f
+which means we optimise terminating programs like (f `seq` ()) into
+non-terminating ones. Nor is this problem just for tail calls. Consider
+ f = id (\x -> f x)
+where we have (for some reason) not yet inlined `id`. We must not eta-reduce to
+ f = id f
+because that will then simplify to `f = f` as before.
+
+An immediate idea might be to look at whether the called function is a local
+loopbreaker and refrain from eta-expanding. But that doesn't work for mutually
+recursive function like in #21652:
+ f = g
+ g* x = f x
+Here, g* is the loopbreaker but f isn't.
+
+What can we do?
+
+Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when
+ entering the let body.
+ Has the disadvantage that other transformations which make use of arity
+ (such as dropping of `seq`s when arity > 0) will no longer work in the RHS.
+ Plus it requires non-trivial refactorings to both the simple optimiser (in
+ the way `subst_opt_bndr` is used) as well as the Simplifier (in the way
+ `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's
+ substitution twice in the process. A very complicated stop-gap.
+
+Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are
+ the ones we should not eta-reduce. All call-site must maintain this set.
+ Example:
+ rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }...
+ ; f2 = ...f1... }
+ when eta-reducing those inner lambdas, we need to know that we are in the
+ rec group for {f1, f2, g}.
+ This is very much like the solution in Note [Speculative evaluation] in
+ GHC.CoreToStg.Prep.
+ It is a bit tiresome to maintain this info, because it means another field
+ in SimplEnv and SimpleOptEnv.
+
+We implement Fix (2) because of it isn't as complicated to maintain as (1).
+Plus, it is the correct fix to begin with. After all, the arity is correct,
+but doing the transformation isn't. The moving parts are:
+ * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders
+ * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind`
+ * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce`
+The situation is very similar to Note [Speculative evaluation] which has the
+same fix.
+
-}
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -64,6 +64,7 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Data.Maybe ( isNothing, orElse )
import GHC.Data.FastString
import GHC.Unit.Module ( moduleName, pprModuleName )
+import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
@@ -256,9 +257,11 @@ simplRecBind :: SimplEnv -> BindContext
-> [(InId, InExpr)]
-> SimplM (SimplFloats, SimplEnv)
simplRecBind env0 bind_cxt pairs0
- = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
- ; (rec_floats, env1) <- go env_with_info triples
- ; return (mkRecFloats rec_floats, env1) }
+ = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0
+ ; let new_bndrs = map sndOf3 triples
+ ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->
+ go env triples
+ ; return (mkRecFloats rec_floats, env2) }
where
add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
-- Add the (substituted) rules to the binder
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -17,7 +17,7 @@ module GHC.Core.Opt.Simplify.Env (
zapSubstEnv, setSubstEnv, bumpCaseDepth,
getInScope, setInScopeFromE, setInScopeFromF,
setInScopeSet, modifyInScope, addNewInScopeIds,
- getSimplRules,
+ getSimplRules, enterRecGroupRHSs,
-- * Substitution results
SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
@@ -55,6 +55,7 @@ import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Data.OrdList
+import GHC.Data.Graph.UnVar
import GHC.Types.Id as Id
import GHC.Core.Make ( mkWildValBinder )
import GHC.Driver.Session ( DynFlags )
@@ -96,6 +97,10 @@ data SimplEnv
, seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion
, seIdSubst :: SimplIdSubst -- InId |--> OutExpr
+ -- | Fast OutVarSet tracking which recursive RHSs we are analysing.
+ -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.
+ , seRecIds :: !UnVarSet
+
----------- Dynamic part of the environment -----------
-- Dynamic in the sense of describing the setup where
-- the expression finally ends up
@@ -286,6 +291,7 @@ mkSimplEnv mode
, seTvSubst = emptyVarEnv
, seCvSubst = emptyVarEnv
, seIdSubst = emptyVarEnv
+ , seRecIds = emptyUnVarSet
, seCaseDepth = 0 }
-- The top level "enclosing CC" is "SUBSUMED".
@@ -391,6 +397,13 @@ modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
modifyInScope env@(SimplEnv {seInScope = in_scope}) v
= env {seInScope = extendInScopeSet in_scope v}
+enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))
+ -> SimplM (r, SimplEnv)
+enterRecGroupRHSs env bndrs k = do
+ --pprTraceM "enterRecGroupRHSs" (ppr bndrs)
+ (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)}
+ return (r, env''{seRecIds = seRecIds env})
+
{- Note [Setting the right in-scope set]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
@@ -886,31 +899,18 @@ seqIds (id:ids) = seqId id `seq` seqIds ids
Note [Arity robustness]
~~~~~~~~~~~~~~~~~~~~~~~
We *do* transfer the arity from the in_id of a let binding to the
-out_id. This is important, so that the arity of an Id is visible in
-its own RHS. For example:
- f = \x. ....g (\y. f y)....
-We can eta-reduce the arg to g, because f is a value. But that
-needs to be visible.
-
-This interacts with the 'state hack' too:
- f :: Bool -> IO Int
- f = \x. case x of
- True -> f y
- False -> \s -> ...
-Can we eta-expand f? Only if we see that f has arity 1, and then we
-take advantage of the 'state hack' on the result of
-(f y) :: State# -> (State#, Int) to expand the arity one more.
-
-There is a disadvantage though. Making the arity visible in the RHS
-allows us to eta-reduce
- f = \x -> f x
-to
- f = f
-which technically is not sound. This is very much a corner case, so
-I'm not worried about it. Another idea is to ensure that f's arity
-never decreases; its arity started as 1, and we should never eta-reduce
-below that.
-
+out_id so that its arity is visible in its RHS. Examples:
+
+ * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)
+ Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a
+ hard time figuring that out when `f` only has arity 0 in its own RHS.
+ * f = \x y. ....(f `seq` blah)....
+ We want to drop the seq.
+ * f = \x. g (\y. f y)
+ You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.
+ Unfortunately, it is not sound in general to eta-reduce in f's RHS.
+ Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how
+ we prevent that.
Note [Robust OccInfo]
~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1610,6 +1610,7 @@ mkLam env bndrs body cont
; mkLam' dflags bndrs body }
where
mode = getMode env
+ rec_ids = seRecIds env
mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
mkLam' dflags bndrs body@(Lam {})
@@ -1633,7 +1634,7 @@ mkLam env bndrs body cont
mkLam' dflags bndrs body
| gopt Opt_DoEtaReduction dflags
- , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body
+ , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce rec_ids bndrs body
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -52,6 +52,7 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.Maybe ( orElse )
+import GHC.Data.Graph.UnVar
import Data.List (mapAccumL)
import qualified Data.ByteString as BS
@@ -193,6 +194,10 @@ data SimpleOptEnv
, soe_subst :: Subst
-- ^ Deals with cloning; includes the InScopeSet
+
+ , soe_rec_ids :: !UnVarSet
+ -- ^ Fast OutVarSet tracking which recursive RHSs we are analysing.
+ -- See Note [Eta reduction in recursive RHSs]
}
instance Outputable SimpleOptEnv where
@@ -205,6 +210,7 @@ emptyEnv :: SimpleOpts -> SimpleOptEnv
emptyEnv opts = SOE
{ soe_inl = emptyVarEnv
, soe_subst = emptySubst
+ , soe_rec_ids = emptyUnVarSet
, soe_co_opt_opts = so_co_opts opts
, soe_uf_opts = so_uf_opts opts
}
@@ -219,6 +225,13 @@ soeSetInScope (SOE { soe_subst = subst1 })
env2@(SOE { soe_subst = subst2 })
= env2 { soe_subst = setInScope subst2 (substInScope subst1) }
+enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r))
+ -> (SimpleOptEnv, r)
+enterRecGroupRHSs env bndrs k
+ = (env'{soe_rec_ids = soe_rec_ids env}, r)
+ where
+ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}
+
---------------
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo env (e_env, e)
@@ -228,6 +241,7 @@ simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr env expr
= go expr
where
+ rec_ids = soe_rec_ids env
subst = soe_subst env
in_scope = substInScope subst
in_scope_env = (in_scope, simpleUnfoldingFun)
@@ -290,13 +304,16 @@ simple_opt_expr env expr
----------------------
-- go_lam tries eta reduction
+ -- It is quite important that it does so. I tried removing this code and
+ -- got a lot of regressions, e.g., +11% ghc/alloc in T18223 and many
+ -- run/alloc increases. Presumably RULEs are affected.
go_lam env bs' (Lam b e)
= go_lam env' (b':bs') e
where
(env', b') = subst_opt_bndr env b
go_lam env bs' e
- | Just etad_e <- tryEtaReduce bs e' = etad_e
- | otherwise = mkLams bs e'
+ | Just etad_e <- tryEtaReduce rec_ids bs e' = etad_e
+ | otherwise = mkLams bs e'
where
bs = reverse bs'
e' = simple_opt_expr env e
@@ -390,12 +407,13 @@ simple_opt_bind env (NonRec b r) top_level
(env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level
simple_opt_bind env (Rec prs) top_level
- = (env'', res_bind)
+ = (env2, res_bind)
where
res_bind = Just (Rec (reverse rev_prs'))
prs' = joinPointBindings_maybe prs `orElse` prs
- (env', bndrs') = subst_opt_bndrs env (map fst prs')
- (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs')
+ (env1, bndrs') = subst_opt_bndrs env (map fst prs')
+ (env2, rev_prs') = enterRecGroupRHSs env1 bndrs' $ \env ->
+ foldl' do_pr (env, []) (prs' `zip` bndrs')
do_pr (env, prs) ((b,r), b')
= (env', case mb_pr of
Just pr -> pr : prs
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -2429,8 +2429,8 @@ need to address that here.
-- When updating this function, make sure to update
-- CorePrep.tryEtaReducePrep as well!
-tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
-tryEtaReduce bndrs body
+tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> Maybe CoreExpr
+tryEtaReduce rec_ids bndrs body
= go (reverse bndrs) body (mkRepReflCo (exprType body))
where
incoming_arity = count isId bndrs
@@ -2469,14 +2469,15 @@ tryEtaReduce bndrs body
ok_fun _fun = False
---------------
- ok_fun_id fun = -- There are arguments to reduce...
- fun_arity fun >= incoming_arity &&
- -- ... and the function can be eta reduced to arity 0
- canEtaReduceToArity fun 0 0
+ ok_fun_id fun =
+ -- Don't eta-reduce in fun in its own recursive RHSs
+ not (fun `elemUnVarSet` rec_ids) && -- criterion (R)
+ -- There are arguments to reduce...
+ fun_arity fun >= incoming_arity &&
+ -- ... and the function can be eta reduced to arity 0
+ canEtaReduceToArity fun 0 0
---------------
fun_arity fun -- See Note [Arity care]
- | isLocalId fun
- , isStrongLoopBreaker (idOccInfo fun) = 0
| arity > 0 = arity
| isEvaldUnfolding (idUnfolding fun) = 1
-- See Note [Eta reduction of an eval'd function]
=====================================
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/arityanal/should_compile/Arity03.stderr
=====================================
@@ -18,20 +18,15 @@ end Rec }
fac [InlPrag=[2]] :: Int -> Int
[GblId,
Arity=1,
- Str=<1P(1L)>,
- Cpr=m1,
+ Str=<1!P(1L)>,
+ Cpr=1,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
- Tmpl= \ (w [Occ=Once1!] :: Int) -> case w of { GHC.Types.I# ww1 [Occ=Once1] -> case F3.$wfac ww1 of ww2 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww2 } }}]
-fac = \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> case F3.$wfac ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } }
+ Tmpl= \ (x [Occ=Once1!] :: Int) -> case x of { GHC.Types.I# ww [Occ=Once1] -> case F3.$wfac ww of ww1 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww1 } }}]
+fac = \ (x :: Int) -> case x of { GHC.Types.I# ww -> case F3.$wfac ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
f3 :: Int -> Int
-[GblId,
- Arity=1,
- Str=<1P(1L)>,
- Cpr=m1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)
- Tmpl= fac}]
+[GblId, Arity=1, Str=<1!P(1L)>, Cpr=1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
f3 = fac
=====================================
testsuite/tests/arityanal/should_run/Makefile
=====================================
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
=====================================
testsuite/tests/arityanal/should_run/T21652.hs
=====================================
@@ -0,0 +1,10 @@
+import GHC.Exts
+
+f, g :: a -> a
+f = g
+g x = f x
+{-# NOINLINE f #-}
+{-# NOINLINE g #-}
+
+-- should print done, not <<loop>>
+main = lazy g `seq` putStrLn "done"
=====================================
testsuite/tests/arityanal/should_run/T21652.stdout
=====================================
@@ -0,0 +1 @@
+done
=====================================
testsuite/tests/arityanal/should_run/all.T
=====================================
@@ -0,0 +1,2 @@
+# Regression tests
+test('T21652', [ only_ways(['optasm']) ], compile_and_run, [''])
=====================================
testsuite/tests/deSugar/should_compile/T19969.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 12, types: 18, coercions: 0, joins: 0/0}
+ = {terms: 8, types: 14, coercions: 0, joins: 0/0}
Rec {
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
@@ -10,7 +10,7 @@ f [Occ=LoopBreaker] :: [Int] -> [Int]
f = \ (x :: [Int]) -> f x
end Rec }
--- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
[GblId,
Arity=1,
@@ -19,10 +19,10 @@ g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
- Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}]
-g = \ (x :: [Int]) -> f x
+ Tmpl= f}]
+g = f
--- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
[GblId,
Arity=1,
@@ -31,8 +31,8 @@ h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
- Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}]
-h = \ (x :: [Int]) -> f x
+ Tmpl= f}]
+h = f
=====================================
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/f3f737a70763a3264dbc0888dca384d147e6b31f...6af677a99fb8a5992897928b6fbb4e68879467ec
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f3f737a70763a3264dbc0888dca384d147e6b31f...6af677a99fb8a5992897928b6fbb4e68879467ec
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/7b800dca/attachment-0001.html>
More information about the ghc-commits
mailing list