[Git][ghc/ghc][wip/T18962-simpl] tmp

[Sebastian Graf]

Sebastian Graf pushed to branch wip/T18962-simpl at Glasgow Haskell Compiler / GHC


Commits:
b9867ba0 by Sebastian Graf at 2020-12-10T15:57:31+01:00
tmp

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/StaticArgs.hs


Changes:

=====================================
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


=====================================
compiler/GHC/Core/Opt/StaticArgs.hs
=====================================
@@ -185,7 +185,7 @@ satAnalExpr env e at 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) }



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9867ba0386438dff378bb3b3b130e4d0be0c0d4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9867ba0386438dff378bb3b3b130e4d0be0c0d4
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/20201210/df555170/attachment-0001.html>