Split mkInlineUnfolding into two functions

Previously, `mkInlineUnfolding` took a `Maybe` argument indicating
whether the caller requested a specific arity.  This was not
self-documenting at call sites. Now we distinguish between
`mkInlineUnfolding` and `mkInlineUnfoldingWithArity`.

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2933

10 files changed, 42 insertions, 24 deletions

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 7c8ffed95e..df9d202fc8 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -292,7 +292,8 @@ mkDictSelId name clas
 
     info | new_tycon
          = base_info `setInlinePragInfo` alwaysInlinePragma
-                     `setUnfoldingInfo`  mkInlineUnfolding (Just 1) (mkDictSelRhs clas val_index)
+                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity 1
+                                           (mkDictSelRhs clas val_index)
                    -- See Note [Single-method classes] in TcInstDcls
                    -- for why alwaysInlinePragma
 
@@ -533,7 +534,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
              -- See Note [Inline partially-applied constructor wrappers]
              -- Passing Nothing here allows the wrapper to inline when
              -- unsaturated.
-             wrap_unf = mkInlineUnfolding Nothing wrap_rhs
+             wrap_unf = mkInlineUnfolding wrap_rhs
              wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs
              wrap_rhs = mkLams wrap_tvs $
                         mkLams wrap_args $
@@ -1091,7 +1092,7 @@ dollarId = pcMiscPrelId dollarName ty
     fun_ty = mkFunTy alphaTy openBetaTy
     ty     = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $
              mkFunTy fun_ty fun_ty
-    unf    = mkInlineUnfolding (Just 2) rhs
+    unf    = mkInlineUnfoldingWithArity 2 rhs
     [f,x]  = mkTemplateLocals [fun_ty, alphaTy]
     rhs    = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $
              App (Var f) (Var x)
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index f23c662bd8..7356d41cb4 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -23,7 +23,8 @@ module CoreUnfold (
         noUnfolding, mkImplicitUnfolding,
         mkUnfolding, mkCoreUnfolding,
         mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
-        mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
+        mkInlineUnfolding, mkInlineUnfoldingWithArity,
+        mkInlinableUnfolding, mkWwInlineRule,
         mkCompulsoryUnfolding, mkDFunUnfolding,
         specUnfolding,
 
@@ -125,20 +126,34 @@ mkWorkerUnfolding dflags work_fn
 
 mkWorkerUnfolding _ _ _ = noUnfolding
 
-mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
-mkInlineUnfolding mb_arity expr
+-- | Make an unfolding that may be used unsaturated
+-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its
+-- manifest arity (the number of outer lambdas applications will
+-- resolve before doing any work).
+mkInlineUnfolding :: CoreExpr -> Unfolding
+mkInlineUnfolding expr
   = mkCoreUnfolding InlineStable
                     True         -- Note [Top-level flag on inline rules]
                     expr' guide
   where
     expr' = simpleOptExpr expr
-    guide = case mb_arity of
-              Nothing    -> UnfWhen { ug_arity = manifestArity expr'
-                                    , ug_unsat_ok = unSaturatedOk
-                                    , ug_boring_ok = boring_ok }
-              Just arity -> UnfWhen { ug_arity = arity
-                                    , ug_unsat_ok = needSaturated
-                                    , ug_boring_ok = boring_ok }
+    guide = UnfWhen { ug_arity = manifestArity expr'
+                    , ug_unsat_ok = unSaturatedOk
+                    , ug_boring_ok = boring_ok }
+    boring_ok = inlineBoringOk expr'
+
+-- | Make an unfolding that will be used once the RHS has been saturated
+-- to the given arity.
+mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding
+mkInlineUnfoldingWithArity arity expr
+  = mkCoreUnfolding InlineStable
+                    True         -- Note [Top-level flag on inline rules]
+                    expr' guide
+  where
+    expr' = simpleOptExpr expr
+    guide = UnfWhen { ug_arity = arity
+                    , ug_unsat_ok = needSaturated
+                    , ug_boring_ok = boring_ok }
     boring_ok = inlineBoringOk expr'
 
 mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index bb1dc50ddc..833d3570b3 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -378,12 +378,12 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
        , let real_arity = dict_arity + arity
         -- NB: The arity in the InlineRule takes account of the dictionaries
-       = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
+       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs
          , etaExpand real_arity rhs)
 
        | otherwise
        = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
-         (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
+         (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
 
 dictArity :: [Var] -> Arity
 -- Don't count coercion variables in arity
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
index b7ea8ab777..dc084ee233 100644
--- a/compiler/deSugar/DsForeign.hs
+++ b/compiler/deSugar/DsForeign.hs
@@ -272,7 +272,8 @@ dsFCall fn_id co fcall mDeclHeader = do
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
         wrap_rhs'    = Cast wrap_rhs co
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
+                                                (length args) wrap_rhs'
 
     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
 
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index aaeb997b54..6291369579 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -2494,7 +2494,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do
                       DataAlt dc -> setIdUnfolding case_bndr unf
                           where
                                  -- See Note [Case binders and join points]
-                             unf = mkInlineUnfolding Nothing rhs
+                             unf = mkInlineUnfolding rhs
                              rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
 
                       LitAlt {} -> WARN( True, text "mkDupableAlt"
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 8d8d23dd77..4b2b383b83 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -36,7 +36,7 @@ import TcHsType
 import TcUnify
 import CoreSyn    ( Expr(..), mkApps, mkVarApps, mkLams )
 import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
-import CoreUnfold ( mkInlineUnfolding, mkDFunUnfolding )
+import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
 import Type
 import TcEvidence
 import TyCon
@@ -884,7 +884,7 @@ addDFunPrags :: DFunId -> [Id] -> DFunId
 -- is messing with.
 addDFunPrags dfun_id sc_meth_ids
  | is_newtype
-  = dfun_id `setIdUnfolding`  mkInlineUnfolding (Just 0) con_app
+  = dfun_id `setIdUnfolding`  mkInlineUnfoldingWithArity 0 con_app
             `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
  | otherwise
  = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_bndrs dict_con dict_args
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 49bfeda445..9cc68efe77 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -17,7 +17,7 @@ import Vectorise.Env
 import Vectorise.Monad
 
 import HscTypes hiding      ( MonadThings(..) )
-import CoreUnfold           ( mkInlineUnfolding )
+import CoreUnfold           ( mkInlineUnfoldingWithArity )
 import PprCore
 import CoreSyn
 import CoreMonad            ( CoreM, getHscEnv )
@@ -325,7 +325,7 @@ vectTopBinder var inline expr
     }
   where
     unfolding = case inline of
-                  Inline arity -> mkInlineUnfolding (Just arity) expr
+                  Inline arity -> mkInlineUnfoldingWithArity arity expr
                   DontInline   -> noUnfolding
 {-
 !!!TODO: dfuns and unfoldings:
diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs
index 85256cf3ab..5b7748a499 100644
--- a/compiler/vectorise/Vectorise/Generic/PADict.hs
+++ b/compiler/vectorise/Vectorise/Generic/PADict.hs
@@ -116,7 +116,8 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr
            let body = mkLams (tvs ++ args) expr
            raw_var  <- newExportedVar (method_name dfun_name name) (exprType body)
            let var  = raw_var
-                      `setIdUnfolding` mkInlineUnfolding (Just (length args)) body
+                      `setIdUnfolding` mkInlineUnfoldingWithArity
+                                         (length args) body
                       `setInlinePragma` alwaysInlinePragma
            hoistBinding var body
            return var
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index d70de485fe..612c051a2c 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -448,7 +448,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc
 
           raw_worker <- mkVectId orig_worker (exprType body)
           let vect_worker = raw_worker `setIdUnfolding`
-                              mkInlineUnfolding (Just arity) body
+                              mkInlineUnfoldingWithArity arity body
           defGlobalVar orig_worker vect_worker
           return (vect_worker, body)
       where
diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
index 7bca567d1b..05883457bf 100644
--- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs
+++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
@@ -62,7 +62,7 @@ hoistExpr fs expr inl
   where
     mk_inline var = case inl of
                       Inline arity -> var `setIdUnfolding`
-                                      mkInlineUnfolding (Just arity) expr
+                                      mkInlineUnfoldingWithArity arity expr
                       DontInline   -> var
 
 hoistVExpr :: VExpr -> Inline -> VM VVar