Commit 3d5cb335 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot
Browse files

Fix INLINE pragmas in desugarer

In #19969 we discovered that GHC has has a bug *forever* that means it
sometimes essentially discarded INLINE pragams.  This happened when you have
* Two more more mutually recursive functions
* Some of which (presumably not all!) have an INLINE pragma
* Completely monomorphic.

This hits a particular case in GHC.HsToCore.Binds.dsAbsBinds, which was
simply wrong -- it put the INLINE pragma on the wrong binder.

This patch fixes the bug, rather easily, by adjusting the
no-tyvar, no-dict case of GHC.HsToCore.Binds.dsAbsBinds.

I also discovered that the GHC.Core.Opt.Pipeline.shortOutIndirections
was not doing a good job for

    {-# INLINE lcl_id #-}
    lcl_id = BIG

    gbl_id = lcl_id

Here we want to transfer the stable unfolding to gbl_id (we do), but
we also want to remove it from lcl_id (we were not doing that).
Otherwise both Ids have large stable unfoldings.  Easily fixed.
Note [Transferring IdInfo] explains.
parent 472c2bf0
Pipeline #36896 failed with stages
in 1 minute and 32 seconds
......@@ -1028,28 +1028,36 @@ Instead, transfer IdInfo from lcl_id to exp_id, specifically
Overwriting, rather than merging, seems to work ok.
We also zap the InlinePragma on the lcl_id. It might originally
have had a NOINLINE, which we have now transferred; and we really
want the lcl_id to inline now that its RHS is trivial!
For the lcl_id we
* Zap the InlinePragma. It might originally have had a NOINLINE, which
we have now transferred; and we really want the lcl_id to inline now
that its RHS is trivial!
* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline,
replacing lcl_id by gbl_id. That won't happen if lcl_id has its original
great big Stable unfolding
-}
transferIdInfo :: Id -> Id -> (Id, Id)
-- See Note [Transferring IdInfo]
transferIdInfo exported_id local_id
= ( modifyIdInfo transfer exported_id
, local_id `setInlinePragma` defaultInlinePragma )
, modifyIdInfo zap_info local_id )
where
local_info = idInfo local_id
transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info
`setCprSigInfo` cprSigInfo local_info
`setUnfoldingInfo` unfoldingInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
`setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info
transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info
`setCprSigInfo` cprSigInfo local_info
`setUnfoldingInfo` unfoldingInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
`setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info
new_info = setRuleInfoHead (idName exported_id)
(ruleInfo local_info)
-- Remember to set the function-name field of the
-- rules as we transfer them from one function to another
zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma
`setUnfoldingInfo` noUnfolding
dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
......
......@@ -226,6 +226,9 @@ dsAbsBinds dflags tyvars dicts exports
-- A very important common case: one exported variable
-- Non-recursive bindings come through this way
-- So do self-recursive bindings
-- gbl_id = wrap (/\tvs \dicts. let ev_binds
-- letrec bind_prs
-- in lcl_id)
| [export] <- exports
, ABE { abe_poly = global_id, abe_mono = local_id
, abe_wrap = wrap, abe_prags = prags } <- export
......@@ -259,26 +262,28 @@ dsAbsBinds dflags tyvars dicts exports
-- Another common case: no tyvars, no dicts
-- In this case we can have a much simpler desugaring
-- lcl_id{inl-prag} = rhs -- Auxiliary binds
-- gbl_id = lcl_id |> co -- Main binds
| null tyvars, null dicts
= do { let mk_bind (ABE { abe_wrap = wrap
, abe_poly = global
, abe_mono = local
, abe_prags = prags })
= do { core_wrap <- dsHsWrapper wrap
; return (makeCorePair dflags global
(isDefaultMethod prags)
0 (core_wrap (Var local))) }
; main_binds <- mapM mk_bind exports
; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
= do { let mk_main :: ABExport GhcTc -> DsM (Id, CoreExpr)
mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id
, abe_wrap = wrap })
-- No SpecPrags (no dicts)
-- Can't be a default method (default methods are singletons)
= do { core_wrap <- dsHsWrapper wrap
; return ( gbl_id `setInlinePragma` defaultInlinePragma
, core_wrap (Var lcl_id)) }
; main_prs <- mapM mk_main exports
; return (force_vars, flattenBinds ds_ev_binds
++ mk_aux_binds bind_prs ++ main_prs ) }
-- The general case
-- See Note [Desugaring AbsBinds]
| otherwise
= do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
| (lcl_id, rhs) <- bind_prs ]
= do { let aux_binds = Rec (mk_aux_binds bind_prs)
-- Monomorphic recursion possible, hence Rec
new_force_vars = get_new_force_vars force_vars
locals = map abe_mono exports
all_locals = locals ++ new_force_vars
......@@ -286,7 +291,7 @@ dsAbsBinds dflags tyvars dicts exports
tup_ty = exprType tup_expr
; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets ds_ev_binds $
mkLet core_bind $
mkLet aux_binds $
tup_expr
; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs)
......@@ -320,19 +325,21 @@ dsAbsBinds dflags tyvars dicts exports
, (poly_tup_id, poly_tup_rhs) :
concat export_binds_s) }
where
mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]
mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs
| (lcl_id, rhs) <- bind_prs
, let lcl_w_inline = lookupVarEnv inline_env lcl_id
`orElse` lcl_id ]
inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
-- the inline pragma from the source
-- The type checker put the inline pragma
-- on the *global* Id, so we need to transfer it
-- the inline pragma from the source
-- The type checker put the inline pragma
-- on the *global* Id, so we need to transfer it
inline_env
= mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
| ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
, let prag = idInlinePragma gbl_id ]
add_inline :: Id -> Id -- tran
add_inline lcl_id = lookupVarEnv inline_env lcl_id
`orElse` lcl_id
global_env :: IdEnv Id -- Maps local Id to its global exported Id
global_env =
mkVarEnv [ (local, global)
......
{-# OPTIONS_GHC -dno-typeable-binds -O2 -fno-worker-wrapper #-}
module T19969 where
-- Three mutually recursive functions
-- We want to inline g, h, keeping f as the loop breaker
f x = reverse (g (x:: [Int])) :: [Int]
{-# INLINE g #-}
g x = reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (h x))))))))))))
{-# INLINE h #-}
h x = reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (f x))))))))))))
==================== Tidy Core ====================
Result size of Tidy Core
= {terms: 12, types: 18, coercions: 0, joins: 0/0}
Rec {
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
f [Occ=LoopBreaker] :: [Int] -> [Int]
[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []]
f = \ (x :: [Int]) -> f x
end Rec }
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
[GblId,
Arity=1,
Str=<B>b,
Cpr=b,
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
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
[GblId,
Arity=1,
Str=<B>b,
Cpr=b,
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
......@@ -110,3 +110,4 @@ test('T14815', [], makefile_test, ['T14815'])
test('T13208', [], makefile_test, ['T13208'])
test('T16615', normal, compile, ['-ddump-ds -dsuppress-uniques'])
test('T18112', [grep_errmsg('cast')], compile, ['-ddump-ds'])
test('T19969', normal, compile, ['-ddump-simpl -dsuppress-uniques'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment