-tryEtaExpansion :: OutExpr
- -> (ArityInfo -> OutExpr -> SimplM (OutStuff a))
- -> SimplM (OutStuff a)
-tryEtaExpansion rhs thing_inside
- | not opt_SimplDoLambdaEtaExpansion
- || null y_tys -- No useful expansion
- || not (is_case1 || is_case2) -- Neither case matches
- = thing_inside final_arity rhs -- So, no eta expansion, but
- -- return a good arity
-
- | is_case1
- = make_y_bndrs $ \ y_bndrs ->
- thing_inside final_arity
- (mkLams x_bndrs $ mkLams y_bndrs $
- mkApps body (map Var y_bndrs))
-
- | otherwise -- Must be case 2
- = mapAndUnzipSmpl bind_z_arg arg_infos `thenSmpl` \ (maybe_z_binds, z_args) ->
- addAuxiliaryBinds (catMaybes maybe_z_binds) $
- make_y_bndrs $ \ y_bndrs ->
- thing_inside final_arity
- (mkLams y_bndrs $
- mkApps (mkApps fun z_args) (map Var y_bndrs))
- where
- all_trivial_args = all is_trivial arg_infos
- is_case1 = all_trivial_args
- is_case2 = null x_bndrs && not (any unlifted_non_trivial arg_infos)
-
- (x_bndrs, body) = collectBinders rhs -- NB: x_bndrs can include type variables
- x_arity = valBndrCount x_bndrs
-
- (fun, args) = collectArgs body
- arg_infos = [(arg, exprType arg, exprIsTrivial arg) | arg <- args]
+tryEtaExpansion :: OutExpr -> OutType -> SimplM ([OutBind], OutExpr)
+tryEtaExpansion rhs rhs_ty
+ | not opt_SimplDoLambdaEtaExpansion -- Not if switched off
+ || exprIsTrivial rhs -- Not if RHS is trivial
+ || final_arity == 0 -- Not if arity is zero
+ = returnSmpl ([], rhs)
+
+ | n_val_args == 0 && not arity_is_manifest
+ = -- Some lambdas but not enough: case 1
+ getUniqSupplySmpl `thenSmpl` \ us ->
+ returnSmpl ([], etaExpand final_arity us rhs rhs_ty)
+
+ | n_val_args > 0 && not (any cant_bind arg_infos)
+ = -- Partial application: case 2
+ mapAndUnzipSmpl bind_z_arg arg_infos `thenSmpl` \ (maybe_z_binds, z_args) ->
+ getUniqSupplySmpl `thenSmpl` \ us ->
+ returnSmpl (catMaybes maybe_z_binds,
+ etaExpand final_arity us (mkApps fun z_args) rhs_ty)