[commit: ghc] wip/T14068: Also loopify global bindings (#14068) (4fa85c9)
git at git.haskell.org
git at git.haskell.org
Tue Aug 1 15:14:21 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T14068
Link : http://ghc.haskell.org/trac/ghc/changeset/4fa85c9636e9481de4d3c1cae125aa1e5f95d459/ghc
>---------------------------------------------------------------
commit 4fa85c9636e9481de4d3c1cae125aa1e5f95d459
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Tue Aug 1 11:13:21 2017 -0400
Also loopify global bindings (#14068)
>---------------------------------------------------------------
4fa85c9636e9481de4d3c1cae125aa1e5f95d459
compiler/coreSyn/CoreOpt.hs | 7 +++++--
compiler/simplCore/OccurAnal.hs | 17 ++++++++++-------
compiler/simplCore/Simplify.hs | 36 ++++++++++++++++++++++--------------
3 files changed, 37 insertions(+), 23 deletions(-)
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index 0dae086..88f7b41 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -659,10 +659,13 @@ loopificationJoinPointBinding_maybe bndr rhs
| isJoinId bndr
= Nothing -- do not loopificate again
- | RecursiveTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
+ | let occ = idOccInfo bndr
+ , RecursiveTailCalled join_arity <- tailCallInfo occ
, not (badUnfoldingForJoin join_arity bndr)
, (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
- = Just (bndr `asJoinId` join_arity, mkLams bndrs body)
+ = let occ' = occ { occ_tail = AlwaysTailCalled join_arity }
+ bndr' = setIdOccInfo bndr occ'
+ in Just (bndr' `asJoinId` join_arity, mkLams bndrs body)
| otherwise
= Nothing
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index a652e1c..a16b761 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -2660,15 +2660,17 @@ tagRecBinders lvl body_uds triples
-- 4. Tag each binder with its adjusted details
bndrs'
- -- 4a. If this is only one function, and the recursive calls are
- -- tail calls, then the simplifier turn it into a non-recursive function
- -- with a local joinrec.
- | [bndr] <- bndrs
+ -- 4a. If this is the only one function, not a join-point already
+ -- and the _recursive calls_ are all tail calls, then the simplifier
+ -- can loopify it with a local joinrec. Mark it as such.
+ | not will_be_joins
+ , [bndr] <- bndrs
, let occ_rhs = lookupDetails unadj_uds_rhss bndr
, AlwaysTailCalled arity <- tailCallInfo occ_rhs
- = let occ = lookupDetails adj_uds bndr
- occ' = markRecursiveTailCalled arity occ
- in [ setBinderOcc occ' bndr ]
+ = let occ = lookupDetails adj_uds bndr
+ occ' = markRecursiveTailCalled arity occ
+ bndr' = setIdOccInfo bndr occ'
+ in [bndr']
-- 4b. Otherwise, just use the adjusted details
| otherwise
= [ setBinderOcc (lookupDetails adj_uds bndr) bndr
@@ -2677,6 +2679,7 @@ tagRecBinders lvl body_uds triples
-- 5. Drop the binders from the adjusted details and return
usage' = adj_uds `delDetailsList` bndrs
in
+ pprTrace "tagRecBinders" (ppr bndrs <+> ppr (map idOccInfo bndrs') <+> ppr unadj_uds_rhss) $
(usage', bndrs')
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 51b93ff..362989e 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -266,6 +266,8 @@ simplTopBinds env0 binds0
simpl_binds env (bind:binds) = do { env' <- simpl_bind env bind
; simpl_binds env' binds }
+ simpl_bind env bind | Just bind' <- maybeLoopify bind
+ = simpl_bind env bind'
simpl_bind env (Rec pairs) = simplRecBind env TopLevel Nothing pairs
simpl_bind env (NonRec b r) = do { (env', b') <- addBndrRules env b (lookupRecBndr env b)
; simplRecOrTopPair env' TopLevel
@@ -1127,6 +1129,10 @@ simplExprF1 env (Case scrut bndr _ alts) cont
env'' = env `addLetFloats` env'
; rebuildCase env'' scrut'' bndr alts cont }
+simplExprF1 env (Let bind body) cont
+ | Just bind' <- maybeLoopify bind
+ = simplExprF1 env (Let bind' body) cont
+
simplExprF1 env (Let (Rec pairs) body) cont
= simplRecE env pairs body cont
@@ -1638,7 +1644,6 @@ simplRecE :: SimplEnv
-- simplRecE is used for
-- * non-top-level recursive lets in expressions
simplRecE env pairs body cont
-
| Just pairs' <- joinPointBindings_maybe pairs
= do { (env1, cont') <- prepareJoinCont env cont
; let bndrs' = map fst pairs'
@@ -1649,19 +1654,6 @@ simplRecE env pairs body cont
; env3 <- simplRecBind env2 NotTopLevel (Just cont') pairs'
; simplExprF env3 body cont' }
- -- Is this a tail-recursive function that we want to loopify? Then
- -- lets loopify it and re-analyse.
- | [(bndr,rhs)] <- pairs
- , Just (join_bndr, join_rhs) <- loopificationJoinPointBinding_maybe bndr rhs
- , let Just arity = isJoinId_maybe join_bndr
- = do { let (join_params, _join_body) = collectNBinders arity join_rhs
- ; let bndr' = zapFragileIdInfo bndr -- TODO: What do we have to zap here?
- ; let rhs' = mkLams join_params $
- mkLetRec [(join_bndr,join_rhs)] $
- mkVarApps (Var join_bndr) join_params
- ; simplNonRecE env bndr' (rhs', env) ([], body) cont
- }
-
| otherwise
= do { let bndrs = map fst pairs
; MASSERT(all (not . isJoinId) bndrs)
@@ -1671,6 +1663,22 @@ simplRecE env pairs body cont
; env2 <- simplRecBind env1 NotTopLevel Nothing pairs
; simplExprF env2 body cont }
+
+-- Is this a tail-recursive function that we want to loopify? Then
+-- lets loopify it and simplify that
+maybeLoopify :: InBind -> Maybe InBind
+maybeLoopify (Rec [(bndr, rhs)])
+ | Just (join_bndr, join_rhs) <- loopificationJoinPointBinding_maybe bndr rhs
+ = do { let Just arity = isJoinId_maybe join_bndr
+ ; let (join_params, _join_body) = collectNBinders arity join_rhs
+ ; let bndr' = zapFragileIdInfo bndr -- TODO: What do we have to zap here?
+ ; let rhs' = mkLams join_params $
+ mkLetRec [(join_bndr,join_rhs)] $
+ mkVarApps (Var join_bndr) join_params
+ ; Just (NonRec bndr' rhs')
+ }
+maybeLoopify _ = Nothing
+
{-
************************************************************************
* *
More information about the ghc-commits
mailing list