diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-06-01 21:17:51 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-10 13:54:40 -0400 |
commit | 3d5cb3352c1e1c20f0d5de427f4edbc765ce06d6 (patch) | |
tree | c0f47881c34c64268b2def0aee6fe1ff63e69a0d /compiler/GHC/HsToCore/Binds.hs | |
parent | 472c2bf003e9f3bb93b82265f2a0a7124f944421 (diff) | |
download | haskell-3d5cb3352c1e1c20f0d5de427f4edbc765ce06d6.tar.gz |
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.
Diffstat (limited to 'compiler/GHC/HsToCore/Binds.hs')
-rw-r--r-- | compiler/GHC/HsToCore/Binds.hs | 51 |
1 files changed, 29 insertions, 22 deletions
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 50a3c319f9..184dda1481 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -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) |