+\begin{code}
+tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
+-- See Note [Eta-expanding at let bindings]
+tryEtaExpand env bndr rhs
+ = do { dflags <- getDOptsSmpl
+ ; (new_arity, new_rhs) <- try_expand dflags
+
+ ; WARN( new_arity < old_arity || new_arity < _dmd_arity,
+ (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_arity
+ <+> ppr new_arity <+> ppr _dmd_arity) $$ ppr new_rhs) )
+ -- Note [Arity decrease]
+ return (new_arity, new_rhs) }
+ where
+ try_expand dflags
+ | sm_eta_expand (getMode env) -- Provided eta-expansion is on
+ , not (exprIsTrivial rhs)
+ , let dicts_cheap = dopt Opt_DictsCheap dflags
+ new_arity = findArity dicts_cheap bndr rhs old_arity
+ , new_arity > rhs_arity
+ = do { tick (EtaExpansion bndr)
+ ; return (new_arity, etaExpand new_arity rhs) }
+ | otherwise
+ = return (rhs_arity, rhs)
+
+ rhs_arity = exprArity rhs
+ old_arity = idArity bndr
+ _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr
+
+findArity :: Bool -> Id -> CoreExpr -> Arity -> Arity
+-- This implements the fixpoint loop for arity analysis
+-- See Note [Arity analysis]
+findArity dicts_cheap bndr rhs old_arity
+ = go (exprEtaExpandArity (mk_cheap_fn dicts_cheap init_cheap_app) rhs)
+ -- We always call exprEtaExpandArity once, but usually
+ -- that produces a result equal to old_arity, and then
+ -- we stop right away (since arities should not decrease)
+ -- Result: the common case is that there is just one iteration
+ where
+ go :: Arity -> Arity
+ go cur_arity
+ | cur_arity <= old_arity = cur_arity
+ | new_arity == cur_arity = cur_arity
+ | otherwise = ASSERT( new_arity < cur_arity )
+ pprTrace "Exciting arity"
+ (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
+ , ppr rhs])
+ go new_arity
+ where
+ new_arity = exprEtaExpandArity (mk_cheap_fn dicts_cheap cheap_app) rhs
+
+ cheap_app :: CheapAppFun
+ cheap_app fn n_val_args
+ | fn == bndr = n_val_args < cur_arity
+ | otherwise = isCheapApp fn n_val_args
+
+ init_cheap_app :: CheapAppFun
+ init_cheap_app fn n_val_args
+ | fn == bndr = True
+ | otherwise = isCheapApp fn n_val_args
+
+mk_cheap_fn :: Bool -> CheapAppFun -> CheapFun
+mk_cheap_fn dicts_cheap cheap_app
+ | not dicts_cheap
+ = \e _ -> exprIsCheap' cheap_app e
+ | otherwise
+ = \e mb_ty -> exprIsCheap' cheap_app e
+ || case mb_ty of
+ Nothing -> False
+ Just ty -> isDictLikeTy ty
+ -- If the experimental -fdicts-cheap flag is on, we eta-expand through
+ -- dictionary bindings. This improves arities. Thereby, it also
+ -- means that full laziness is less prone to floating out the
+ -- application of a function to its dictionary arguments, which
+ -- can thereby lose opportunities for fusion. Example:
+ -- foo :: Ord a => a -> ...
+ -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
+ -- -- So foo has arity 1
+ --
+ -- f = \x. foo dInt $ bar x
+ --
+ -- The (foo DInt) is floated out, and makes ineffective a RULE
+ -- foo (bar x) = ...
+ --
+ -- One could go further and make exprIsCheap reply True to any
+ -- dictionary-typed expression, but that's more work.
+ --
+ -- See Note [Dictionary-like types] in TcType.lhs for why we use
+ -- isDictLikeTy here rather than isDictTy
+\end{code}