X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=a931f29eaface65bb102b97d30b311d9289efdac;hb=63f6b0868f4948232f87bc4df52c9d3a2ec8f184;hp=58f72cbbc240bac22ba71e35bed15f074e35f0c0;hpb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;p=ghc-hetmet.git diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 58f72cb..a931f29 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -171,8 +171,8 @@ However things are made quite a bit more complicated by RULES. Remember ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We avoid infinite inlinings by choosing loop breakers, and ensuring that a loop breaker cuts each loop. But what is a - "loop"? In particular, a RULES is like an equation for 'f' that - is *always* inlined if it are applicable. We do *not* disable + "loop"? In particular, a RULE is like an equation for 'f' that + is *always* inlined if it is applicable. We do *not* disable rules for loop-breakers. It's up to whoever makes the rules to make sure that the rules themselves alwasys terminate. See Note [Rules for recursive functions] in Simplify.lhs @@ -237,8 +237,9 @@ However things are made quite a bit more complicated by RULES. Remember * Note [Rule dependency info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The VarSet in a SpecInfo is used for dependency analysis in the - occurrence analyser. We must track free vars in *both* lhs and rhs. Why both? - Consider + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in addRuleUsage. + Why both? Consider x = y RULE f x = 4 Then if we substitute y for x, we'd better do so in the @@ -365,8 +366,9 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) ---------------------------- -- Now reconstruct the cycle - pairs | no_rules = reOrderCycle tagged_nodes - | otherwise = concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR loop_breaker_edges) + pairs | no_rules = reOrderCycle 0 tagged_nodes [] + | otherwise = foldr (reOrderRec 0) [] $ + stronglyConnCompFromEdgedVerticesR loop_breaker_edges -- See Note [Choosing loop breakers] for looop_breaker_edges loop_breaker_edges = map mk_node tagged_nodes @@ -457,42 +459,55 @@ data Details = ND Id -- Binder IdSet -- Other binders from this Rec group mentioned on RHS -- (derivable from UsageDetails but cached here) -reOrderRec :: SCC (Node Details) - -> [(Id,CoreExpr)] +reOrderRec :: Int -> SCC (Node Details) + -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -- Sorted into a plausible order. Enough of the Ids have -- IAmALoopBreaker pragmas that there are no loops left. -reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)] -reOrderRec (CyclicSCC cycle) = reOrderCycle cycle +reOrderRec _ (AcyclicSCC (ND bndr rhs _ _, _, _)) pairs = (bndr, rhs) : pairs +reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs -reOrderCycle :: [Node Details] -> [(Id,CoreExpr)] -reOrderCycle [] +reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +reOrderCycle _ [] _ = panic "reOrderCycle" -reOrderCycle [bind] -- Common case of simple self-recursion - = [(makeLoopBreaker False bndr, rhs)] +reOrderCycle _ [bind] pairs -- Common case of simple self-recursion + = (makeLoopBreaker False bndr, rhs) : pairs where (ND bndr rhs _ _, _, _) = bind -reOrderCycle (bind : binds) +reOrderCycle depth (bind : binds) pairs = -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out - concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR unchosen) ++ - [(makeLoopBreaker False bndr, rhs)] - +-- pprTrace "reOrderCycle" (ppr [b | (ND b _ _ _, _, _) <- bind:binds]) $ + foldr (reOrderRec new_depth) + ([ (makeLoopBreaker False bndr, rhs) + | (ND bndr rhs _ _, _, _) <- chosen_binds] ++ pairs) + (stronglyConnCompFromEdgedVerticesR unchosen) where - (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds - ND bndr rhs _ _ = chosen_bind + (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds + + approximate_loop_breaker = depth >= 2 + new_depth | approximate_loop_breaker = 0 + | otherwise = depth+1 + -- After two iterations (d=0, d=1) give up + -- and approximate, returning to d=0 -- This loop looks for the bind with the lowest score -- to pick as the loop breaker. The rest accumulate in - choose_loop_breaker (details,_,_) _loop_sc acc [] - = (details, acc) -- Done + choose_loop_breaker loop_binds _loop_sc acc [] + = (loop_binds, acc) -- Done - choose_loop_breaker loop_bind loop_sc acc (bind : binds) + -- If approximate_loop_breaker is True, we pick *all* + -- nodes with lowest score, else just one + -- See Note [Complexity of loop breaking] + choose_loop_breaker loop_binds loop_sc acc (bind : binds) | sc < loop_sc -- Lower score so pick this new one - = choose_loop_breaker bind sc (loop_bind : acc) binds + = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds - | otherwise -- No lower so don't pick it - = choose_loop_breaker loop_bind loop_sc (bind : acc) binds + | approximate_loop_breaker && sc == loop_sc + = choose_loop_breaker (bind : loop_binds) loop_sc acc binds + + | otherwise -- Higher score so don't pick it + = choose_loop_breaker loop_binds loop_sc (bind : acc) binds where sc = score bind @@ -509,7 +524,7 @@ reOrderCycle (bind : binds) -- bad choice for loop breaker | is_con_app rhs = 3 -- Data types help with cases - -- Note [conapp] + -- Note [Constructor applictions] -- If an Id is marked "never inline" then it makes a great loop breaker -- The only reason for not checking that here is that it is rare @@ -560,22 +575,59 @@ reOrderCycle (bind : binds) is_con_app _ = False makeLoopBreaker :: Bool -> Id -> Id --- Set the loop-breaker flag --- See Note [Weak loop breakers] +-- Set the loop-breaker flag: see Note [Weak loop breakers] makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak) \end{code} -Note [Worker inline loop] -~~~~~~~~~~~~~~~~~~~~~~~~ -Never choose a wrapper as the loop breaker! Because -wrappers get auto-generated inlinings when importing, and -that can lead to an infinite inlining loop. For example: +Note [Complexity of loop breaking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop-breaking algorithm knocks out one binder at a time, and +performs a new SCC analysis on the remaining binders. That can +behave very badly in tightly-coupled groups of bindings; in the +worst case it can be (N**2)*log N, because it does a full SCC +on N, then N-1, then N-2 and so on. + +To avoid this, we switch plans after 2 (or whatever) attempts: + Plan A: pick one binder with the lowest score, make it + a loop breaker, and try again + Plan B: pick *all* binders with the lowest score, make them + all loop breakers, and try again +Since there are only a small finite number of scores, this will +terminate in a constant number of iterations, rather than O(N) +iterations. + +You might thing that it's very unlikely, but RULES make it much +more likely. Here's a real example from Trac #1969: + Rec { $dm = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm1 + forall d. $dm Bool d = $s$dm2 #-} + + dInt = MkD .... opInt ... + dInt = MkD .... opBool ... + opInt = $dm dInt + opBool = $dm dBool + + $s$dm1 = \x. op dInt + $s$dm2 = \x. op dBool } +The RULES stuff means that we can't choose $dm as a loop breaker +(Note [Choosing loop breakers]), so we must choose at least (say) +opInt *and* opBool, and so on. The number of loop breakders is +linear in the number of instance declarations. + +Note [INLINE pragmas] +~~~~~~~~~~~~~~~~~~~~~ +Never choose a function with an INLINE pramga as the loop breaker! +If such a function is mutually-recursive with a non-INLINE thing, +then the latter should be the loop-breaker. + +A particular case is wrappers generated by the demand analyser. +If you make then into a loop breaker you may get an infinite +inlining loop. For example: rec { $wfoo x = ....foo x.... {-loop brk-} foo x = ...$wfoo x... } - The interface file sees the unfolding for $wfoo, and sees that foo is strict (and hence it gets an auto-generated wrapper). Result: an infinite inlining in the importing scope. So be a bit careful if you @@ -584,6 +636,22 @@ nofib/spectral/minimax. If the repTree wrapper is chosen as the loop breaker then compiling Game.hs goes into an infinite loop (this happened when we gave is_con_app a lower score than inline candidates). +Note [Constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really really important to inline dictionaries. Real +example (the Enum Ordering instance from GHC.Base): + + rec f = \ x -> case d of (p,q,r) -> p x + g = \ x -> case d of (p,q,r) -> q x + d = (v, f, g) + +Here, f and g occur just once; but we can't inline them into d. +On the other hand we *could* simplify those case expressions if +we didn't stupidly choose d as the loop breaker. +But we won't because constructor args are marked "Many". +Inlining dictionaries is really essential to unravelling +the loops in static numeric dictionaries, see GHC.Float. + Note [Closure conversion] ~~~~~~~~~~~~~~~~~~~~~~~~~ We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. @@ -629,7 +697,7 @@ occAnalRhs env id rhs = occAnal ctxt rhs where ctxt | certainly_inline id = env - | otherwise = rhsCtxt + | otherwise = rhsCtxt env -- Note that we generally use an rhsCtxt. This tells the occ anal n -- that it's looking at an RHS, which has an effect in occAnalApp -- @@ -657,10 +725,14 @@ addRuleUsage :: UsageDetails -> Id -> UsageDetails -- Add the usage from RULES in Id to the usage addRuleUsage usage id = foldVarSet add usage (idRuleVars id) + -- idRuleVars here: see Note [Rule dependency info] where - add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info - -- (i.e manyOcc) because many copies - -- of the specialised thing can appear + add v u = addOneOcc u v NoOccInfo + -- Give a non-committal binder info (i.e manyOcc) because + -- a) Many copies of the specialised thing can appear + -- b) We don't want to substitute a BIG expression inside a RULE + -- even if that's the only occurrence of the thing + -- (Same goes for INLINE.) \end{code} Expressions @@ -763,7 +835,7 @@ occAnal env expr@(Lam _ _) (really_final_usage, mkLams tagged_binders body') } where - env_body = vanillaCtxt -- Body is (no longer) an RhsContext + env_body = vanillaCtxt env -- Body is (no longer) an RhsContext (binders, body) = collectBinders expr binders' = oneShotGroup env binders linear = all is_one_shot binders' @@ -793,7 +865,7 @@ occAnal env (Case scrut bndr ty alts) Nothing -> usage Just _ -> extendVarEnv usage bndr NoOccInfo - alt_env = setVanillaCtxt env + alt_env = mkAltEnv env bndr_swap -- Consider x = case v of { True -> (p,q); ... } -- Then it's fine to inline p and q @@ -810,7 +882,7 @@ occAnal env (Case scrut bndr ty alts) -- in an interesting context; the case has -- at least one non-default alternative occ_anal_scrut scrut _alts - = occAnal vanillaCtxt scrut -- No need for rhsCtxt + = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt occAnal env (Let bind body) = case occAnal env body of { (body_usage, body') -> @@ -818,11 +890,11 @@ occAnal env (Let bind body) (final_usage, mkLets new_binds body') }} occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr]) -occAnalArgs _env args +occAnalArgs env args = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') -> (foldr (+++) emptyDetails arg_uds_s, args')} where - arg_env = vanillaCtxt + arg_env = vanillaCtxt env \end{code} Applications are dealt with specially because we want @@ -841,7 +913,7 @@ occAnalApp env (Var fun, args) where fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) - is_pap = isDataConWorkId fun || valArgCount args < idArity fun + is_pap = isConLikeId fun || valArgCount args < idArity fun -- Hack for build, fold, runST args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args @@ -896,12 +968,12 @@ appSpecial :: OccEnv appSpecial env n ctxt args = go n args where - arg_env = vanillaCtxt + arg_env = vanillaCtxt env go _ [] = (emptyDetails, []) -- Too few args go 1 (arg:args) -- The magic arg - = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') -> + = case occAnal (setCtxtTy arg_env ctxt) arg of { (arg_uds, arg') -> case occAnalArgs env args of { (args_uds, args') -> (arg_uds +++ args_uds, arg':args') }} @@ -924,25 +996,22 @@ We do these two transformations right here: ==> case (x |> co) of b { pi -> let x = b |> sym co in ri } - Why (2)? See Note [Ccase of cast] + Why (2)? See Note [Case of cast] In both cases, in a particular alternative (pi -> ri), we only add the binding if (a) x occurs free in (pi -> ri) (ie it occurs in ri, but is not bound in pi) (b) the pi does not bind b (or the free vars of co) - (c) x is not a We need (a) and (b) for the inserted binding to be correct. -Notice that (a) rapidly becomes false, so no bindings are injected. - -Notice the deliberate shadowing of 'x'. But we must call localiseId -on 'x' first, in case it's a GlobalId, or has an External Name. -See, for example, SimplEnv Note [Global Ids in the substitution]. - For the alternatives where we inject the binding, we can transfer all x's OccInfo to b. And that is the point. +Notice that + * The deliberate shadowing of 'x'. + * That (a) rapidly becomes false, so no bindings are injected. + The reason for doing these transformations here is because it allows us to adjust the OccInfo for 'x' and 'b' as we go. @@ -960,6 +1029,90 @@ us to adjust the OccInfo for 'x' and 'b' as we go. The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding {x=b}; it's Nothing if the binder-swap doesn't happen. +There is a danger though. Consider + let v = x +# y + in case (f v) of w -> ...v...v... +And suppose that (f v) expands to just v. Then we'd like to +use 'w' instead of 'v' in the alternative. But it may be too +late; we may have substituted the (cheap) x+#y for v in the +same simplifier pass that reduced (f v) to v. + +I think this is just too bad. CSE will recover some of it. + +Note [Binder swap on GlobalId scrutinees] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the scrutinee is a GlobalId we must take care in two ways + + i) In order to *know* whether 'x' occurs free in the RHS, we need its + occurrence info. BUT, we don't gather occurrence info for + GlobalIds. That's what the (small) occ_scrut_ids set in OccEnv is + for: it says "gather occurrence info for these. + + ii) We must call localiseId on 'x' first, in case it's a GlobalId, or + has an External Name. See, for example, SimplEnv Note [Global Ids in + the substitution]. + +Historical note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressoins when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This old note describes a problem that is also fixed by doing the +binder-swap in OccAnal: + + There is another situation when it might make sense to suppress the + case-expression binde-swap. If we have + + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } + + We'll perform the binder-swap for the outer case, giving + + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } + + But there is no point in doing it for the inner case, because w1 can't + be inlined anyway. Furthermore, doing the case-swapping involves + zapping w2's occurrence info (see paragraphs that follow), and that + forces us to bind w2 when doing case merging. So we get + + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } + + This is plain silly in the common case where w2 is dead. + + Even so, I can't see a good way to implement this idea. I tried + not doing the binder-swap if the scrutinee was already evaluated + but that failed big-time: + + data T = MkT !Int + + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... + + Notice that because MkT is strict, x is marked "evaluated". But to + eliminate the last case, we must either make sure that x (as well as + x1) has unfolding MkT y1. THe straightforward thing to do is to do + the binder-swap. So this whole note is a no-op. + +It's fixed by doing the binder-swap in OccAnal because we can do the +binder-swap unconditionally and still get occurrence analysis +information right. + Note [Case of cast] ~~~~~~~~~~~~~~~~~~~ Consider case (x `cast` co) of b { I# -> @@ -1005,7 +1158,7 @@ occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs) (usg_wo_scrut, scrut_var') = tagBinder alt_usg (localiseId scrut_var) -- Note the localiseId; we're making a new binding -- for it, and it might have an External Name, or - -- even be a GlobalId + -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] shadowing bndr = bndr `elemVarSet` rhs_fvs rhs_fvs = exprFreeVars scrut_rhs @@ -1021,8 +1174,15 @@ occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs) \begin{code} data OccEnv - = OccEnv OccEncl -- Enclosing context information - CtxtTy -- Tells about linearity + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_ctxt :: !CtxtTy -- Tells about linearity + , occ_scrut_ids :: !GblScrutIds } + +type GblScrutIds = IdSet -- GlobalIds that are scrutinised, and for which + -- we want to gather occurence info; see + -- Note [Binder swap for GlobalId scrutinee] + -- No need to prune this if there's a shadowing binding + -- because it's OK for it to be too big -- OccEncl is used to control whether to inline into constructor arguments -- For example: @@ -1049,24 +1209,36 @@ type CtxtTy = [Bool] -- the CtxtTy inside applies initOccEnv :: OccEnv -initOccEnv = OccEnv OccRhs [] - -vanillaCtxt :: OccEnv -vanillaCtxt = OccEnv OccVanilla [] - -rhsCtxt :: OccEnv -rhsCtxt = OccEnv OccRhs [] +initOccEnv = OccEnv { occ_encl = OccRhs + , occ_ctxt = [] + , occ_scrut_ids = emptyVarSet } + +vanillaCtxt :: OccEnv -> OccEnv +vanillaCtxt env = OccEnv { occ_encl = OccVanilla, occ_ctxt = [] + , occ_scrut_ids = occ_scrut_ids env } + +rhsCtxt :: OccEnv -> OccEnv +rhsCtxt env = OccEnv { occ_encl = OccRhs, occ_ctxt = [] + , occ_scrut_ids = occ_scrut_ids env } + +mkAltEnv :: OccEnv -> Maybe (Id, CoreExpr) -> OccEnv +-- Does two things: a) makes the occ_ctxt = OccVanilla +-- b) extends the scrut_ids if necessary +mkAltEnv env (Just (scrut_id, _)) + | not (isLocalId scrut_id) + = OccEnv { occ_encl = OccVanilla + , occ_scrut_ids = extendVarSet (occ_scrut_ids env) scrut_id + , occ_ctxt = occ_ctxt env } +mkAltEnv env _ + | isRhsEnv env = env { occ_encl = OccVanilla } + | otherwise = env + +setCtxtTy :: OccEnv -> CtxtTy -> OccEnv +setCtxtTy env ctxt = env { occ_ctxt = ctxt } isRhsEnv :: OccEnv -> Bool -isRhsEnv (OccEnv OccRhs _) = True -isRhsEnv (OccEnv OccVanilla _) = False - -setVanillaCtxt :: OccEnv -> OccEnv -setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty -setVanillaCtxt other_env = other_env - -setCtxt :: OccEnv -> CtxtTy -> OccEnv -setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt +isRhsEnv (OccEnv { occ_encl = OccRhs }) = True +isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr] -- The result binders have one-shot-ness set that they might not have had originally. @@ -1074,7 +1246,7 @@ oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr] -- linearity context knows that c,n are one-shot, and it records that fact in -- the binder. This is useful to guide subsequent float-in/float-out tranformations -oneShotGroup (OccEnv _encl ctxt) bndrs +oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs = go ctxt bndrs [] where go _ [] rev_bndrs = reverse rev_bndrs @@ -1088,8 +1260,8 @@ oneShotGroup (OccEnv _encl ctxt) bndrs go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs) addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt (OccEnv encl ctxt) args - = OccEnv encl (replicate (valArgCount args) True ++ ctxt) +addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args + = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt } \end{code} %************************************************************************ @@ -1174,9 +1346,10 @@ setBinderOcc usage bndr \begin{code} mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails -mkOneOcc _env id int_cxt +mkOneOcc env id int_cxt | isLocalId id = unitVarEnv id (OneOcc False True int_cxt) - | otherwise = emptyDetails + | id `elemVarSet` occ_scrut_ids env = unitVarEnv id NoOccInfo + | otherwise = emptyDetails markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo