diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2020-12-10 15:57:31 +0100 |
---|---|---|
committer | Sebastian Graf <sebastian.graf@kit.edu> | 2020-12-20 13:42:06 +0100 |
commit | b7e8a40da0f4577bb9741947f73349c7231eb14d (patch) | |
tree | 1e193bc5e011a381fca05928cf30d5c81c8ca682 | |
parent | 8f52b3fcc1901d1da5820ef7c6094861894d7902 (diff) | |
download | haskell-b7e8a40da0f4577bb9741947f73349c7231eb14d.tar.gz |
tmp
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/StaticArgs.hs | 10 |
2 files changed, 12 insertions, 9 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 34c80c8839..a820abc968 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -542,6 +542,7 @@ prepareBinding env top_lvl old_bndr bndr rhs `setDemandInfo` demandInfo info `setInlinePragInfo` inlinePragInfo info `setArityInfo` arityInfo info + `setStaticArgsInfo` staticArgsInfo info -- We do /not/ want to transfer OccInfo, Rules, Unfolding -- Note [Preserve strictness in cast w/w] @@ -3787,18 +3788,18 @@ simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf = simplStableUnfolding env top_lvl cont_mb id rhs_ty arity unf | isExitJoinId id = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify - | Just static_args <- isStrongLoopBreakerWithStaticArgs id - , (lam_bndrs, lam_body) <- collectBinders new_rhs + | (lam_bndrs, lam_body) <- collectBinders new_rhs + , Just static_args <- isStrongLoopBreakerWithNStaticArgs id (length lam_bndrs) = do { unf_rhs <- saTransform id static_args lam_bndrs lam_body ; pprTraceM "simplLetUnfolding" (ppr id $$ ppr static_args $$ ppr unf_rhs) ; mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id unf_rhs } | otherwise = mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id new_rhs -isStrongLoopBreakerWithStaticArgs :: Id -> Maybe [Staticness ()] -isStrongLoopBreakerWithStaticArgs id +isStrongLoopBreakerWithNStaticArgs :: Id -> Int -> Maybe [Staticness ()] +isStrongLoopBreakerWithNStaticArgs id n_args | isStrongLoopBreaker $ idOccInfo id - , static_args <- getStaticArgs $ idStaticArgs id + , static_args <- take n_args $ getStaticArgs $ idStaticArgs id , notNull static_args = Just static_args | otherwise diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index f6d4b02988..5c456bb8b3 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -185,7 +185,7 @@ satAnalExpr env e@Lam{} = (occs, mkLams bndrs body') (occs, body') = satAnalExpr (env `addInScopeVars` bndrs) body satAnalExpr env (Let bnd body) = (occs, Let bnd' body') where - (occs_bind, bnd') = satAnalBind env bnd' + (occs_bind, bnd') = satAnalBind env bnd (occs_body, body') = satAnalExpr (env `addInScopeVars` bindersOf bnd) body !occs = combineSatOccs occs_body occs_bind satAnalExpr env (Case scrut bndr ty alts) = (occs, Case scrut' bndr ty alts') @@ -201,12 +201,11 @@ satAnalAlt env (dc, bndrs, rhs) = (occs, (dc, bndrs, rhs')) (occs, rhs') = satAnalExpr (env `addInScopeVars` bndrs) rhs satAnalApp :: SatEnv -> CoreExpr -> [CoreArg] -> (SatOccs, CoreExpr) -satAnalApp env head args = (add_static_args_info occs, expr') +satAnalApp env head args = (add_static_args_info occs, mkApps head' args') where (occs_head, head') = satAnalExpr env head (occs_args, args') = mapAndUnzip (satAnalExpr env) args occs = combineSatOccsList (occs_head:occs_args) - expr' = mkApps head' args' add_static_args_info occs | Var fn <- head, Just params <- lookupInterestingId env fn = addSatOccs occs fn (mkStaticArgs $ zipWith asStaticArg params args) @@ -521,8 +520,11 @@ saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body n_static_args = count isStaticValue staticness saTransform :: MonadUnique m => Id -> [Staticness a] -> [Id] -> CoreExpr -> m CoreExpr +-- Precondition: At least as many arg_staticness as rhs_binders +-- Precondition: At least one NotStatic saTransform binder arg_staticness rhs_binders rhs_body - = do { MASSERT( arg_staticness `leLength` rhs_binders ) + = do { MASSERT2( arg_staticness `leLength` rhs_binders, ppr binder $$ ppr (mkStaticArgs arg_staticness) $$ ppr rhs_binders ) + ; MASSERT2( mkStaticArgs arg_staticness /= noStaticArgs, ppr binder $$ ppr rhs_binders ) ; shadow_lam_bndrs <- mapM clone binders_w_staticness ; uniq <- getUniqueM ; return (mk_new_rhs uniq shadow_lam_bndrs) } |