From 182ce7e265699c9fd326f59d29767923100a2d16 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 21 Jun 2006 20:58:55 +0000 Subject: [PATCH] Arity and eta-expansion tuning Roman found that loop :: STRef s a -> Int -> ST s Int loop ref n = case n of 0 -> return n n -> loop ref (n-1) wasn't eta-expanding nicely, despite the 'state hack' (see Id.isStateHackType). The reason was two-fold: a) a bug in CoreUtils.arityType (the Var case) b) the arity of a recursive function was not being exposed in its RHS (see commments with SimplEnv.addLetIdInfo The commit fixes both. --- compiler/basicTypes/Id.lhs | 2 +- compiler/coreSyn/CoreUtils.lhs | 15 ++++++++------- compiler/simplCore/SimplEnv.lhs | 39 ++++++++++++++++++++++++++------------- 3 files changed, 35 insertions(+), 21 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 8f955d3..798bde6 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -475,7 +475,7 @@ idLBVarInfo id = lbvarInfo (idInfo id) isOneShotBndr :: Id -> Bool -- This one is the "business end", called externally. -- Its main purpose is to encapsulate the Horrible State Hack -isOneShotBndr id = isOneShotLambda id || (isStateHackType (idType id)) +isOneShotBndr id = isOneShotLambda id || isStateHackType (idType id) isStateHackType :: Type -> Bool isStateHackType ty diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 00cce7e..6aa6583 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -822,8 +822,9 @@ arityType (Var v) -- False -> \(s:RealWorld) -> e -- where foo has arity 1. Then we want the state hack to -- apply to foo too, so we can eta expand the case. - mk 0 tys | isBottomingId v = ABot - | otherwise = ATop + mk 0 tys | isBottomingId v = ABot + | (ty:tys) <- tys, isStateHackType ty = AFun True ATop + | otherwise = ATop mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys) mk n [] = AFun False (mk (n-1) []) @@ -851,14 +852,14 @@ arityType (App f a) = case arityType f of -- f x y = case x of { (a,b) -> e } -- The difference is observable using 'seq' arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of - xs@(AFun one_shot _) | one_shot -> xs - xs | exprIsCheap scrut -> xs - | otherwise -> ATop + xs | exprIsCheap scrut -> xs + xs@(AFun one_shot _) | one_shot -> AFun True ATop + other -> ATop arityType (Let b e) = case arityType e of - xs@(AFun one_shot _) | one_shot -> xs xs | all exprIsCheap (rhssOfBind b) -> xs - | otherwise -> ATop + xs@(AFun one_shot _) | one_shot -> AFun True ATop + other -> ATop arityType other = ATop diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index c91ca58..c7b4826 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -535,19 +535,34 @@ This is important. Manuel found cases where he really, really wanted a RULE for a recursive function to apply in that function's own right-hand side. -NB 2: We do not transfer the arity (see Subst.substIdInfo) -The arity of an Id should not be visible -in its own RHS, else we eta-reduce +NB 2: ARITY. We *do* transfer the arity. This is important, so that +the arity of an Id is visible in its own RHS. For example: + f = \x. ....g (\y. f y).... +We can eta-reduce the arg to g, becuase f is a value. But that +needs to be visible. + +This interacts with the 'state hack' too: + f :: Bool -> IO Int + f = \x. case x of + True -> f y + False -> \s -> ... +Can we eta-expand f? Only if we see that f has arity 1, and then we +take advantage of the 'state hack' on the result of +(f y) :: State# -> (State#, Int) to expand the arity one more. + +There is a disadvantage though. Making the arity visible in the RHA +allows us to eta-reduce f = \x -> f x to f = f -which isn't sound. And it makes the arity in f's IdInfo greater than -the manifest arity, which isn't good. -The arity will get added later. +which technically is not sound. This is very much a corner case, so +I'm not worried about it. Another idea is to ensure that f's arity +never decreases; its arity started as 1, and we should never eta-reduce +below that. -NB 3: It's important that we *do* transer the loop-breaker OccInfo, -because that's what stops the Id getting inlined infinitely, in the body -of the letrec. +NB 3: OccInfo. It's important that we *do* transer the loop-breaker +OccInfo, because that's what stops the Id getting inlined infinitely, +in the body of the letrec. NB 4: does no harm for non-recursive bindings @@ -577,7 +592,7 @@ substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo -- worker info -- Zap the unfolding -- Keep only 'robust' OccInfo --- Zap Arity +-- arity -- -- Seq'ing on the returned IdInfo is enough to cause all the -- substitutions to happen completely @@ -585,20 +600,18 @@ substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo substIdInfo subst info | nothing_to_do = Nothing | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo) - `setArityInfo` (if keep_arity then old_arity else unknownArity) `setSpecInfo` CoreSubst.substSpec subst old_rules `setWorkerInfo` CoreSubst.substWorker subst old_wrkr `setUnfoldingInfo` noUnfolding) -- setSpecInfo does a seq -- setWorkerInfo does a seq where - nothing_to_do = keep_occ && keep_arity && + nothing_to_do = keep_occ && isEmptySpecInfo old_rules && not (workerExists old_wrkr) && not (hasUnfolding (unfoldingInfo info)) keep_occ = not (isFragileOcc old_occ) - keep_arity = old_arity == unknownArity old_arity = arityInfo info old_occ = occInfo info old_rules = specInfo info -- 1.7.10.4