Refactor WorkWrap, get rid of worthSplittingArgDmd
authorJoachim Breitner <mail@joachim-breitner.de>
Thu, 16 Jan 2014 14:42:31 +0000 (14:42 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 16 Jan 2014 16:49:19 +0000 (16:49 +0000)
Instead of first checking whether splitting is useful, and then firing
up the worker-wrapper-machinery, which will do the same checks again, we
now simply generate a worker and wrapper, and while doing so keep track
of whether what we did was in any way useful.

So now there is only one place left where we decide whether we want to
do w/w, and that place has access to more information, in particular the
actual types at hand.

compiler/basicTypes/Demand.lhs
compiler/stranal/WorkWrap.lhs
compiler/stranal/WwLib.lhs

index 3ebd724..879c156 100644 (file)
@@ -47,8 +47,6 @@ module Demand (
 
         isSingleUsed, reuseEnv, zapDemand, zapStrictSig,
 
-        worthSplittingArgDmd, worthSplittingThunkDmd,
-
         strictifyDictDmd
 
      ) where
@@ -845,32 +843,6 @@ different:
    unused, so we can use absDmd there.
  * Further arguments *can* be used, of course. Hence topDmd is used.
 
-
-%************************************************************************
-%*                                                                      *
-            Whether a demand justifies a w/w split
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-worthSplittingArgDmd :: Demand    -- Demand on a function argument
-                     -> Bool
-worthSplittingArgDmd dmd
-  = go dmd
-  where
-    go (JD {absd=Abs}) = True      -- Absent arg
-
-    -- See Note [Worker-wrapper for bottoming functions]
-    go (JD {strd=Str HyperStr, absd=Use _ (UProd _)}) = True
-
-    -- See Note [Worthy functions for Worker-Wrapper split]
-    go (JD {strd=Str (SProd {})})                    = True  -- Product arg to evaluate
-    go (JD {strd=Str HeadStr, absd=Use _ (UProd _)}) = True  -- Strictly used product arg
-    go (JD {strd=Str HeadStr, absd=Use _ UHead})     = True
-
-    go _ = False
-\end{code}
-
 Note [Worthy functions for Worker-Wrapper split]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For non-bottoming functions a worker-wrapper transformation takes into
index 5c24069..9aa36c2 100644 (file)
@@ -17,7 +17,6 @@ import CoreSyn
 import CoreUnfold      ( certainlyWillInline, mkInlineUnfolding, mkWwInlineRule )
 import CoreUtils       ( exprType, exprIsHNF )
 import CoreArity       ( exprArity )
-import Type             ( isVoidTy )
 import Var
 import Id
 import IdInfo
@@ -257,30 +256,21 @@ tryWW dflags is_rec fn_id rhs
        -- Furthermore, don't even expose strictness info
   = return [ (fn_id, rhs) ]
 
-  | is_fun && (worth_splitting_args wrap_dmds rhs || returnsCPR res_info)
-  = checkSize dflags new_fn_id rhs $
-    splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs
-
-  | is_thunk && (worthSplittingArgDmd fn_dmd || returnsCPR res_info)
-       -- See Note [Thunk splitting]
-  = ASSERT2( isNonRec is_rec, ppr new_fn_id )  -- The thunk must be non-recursive
-    checkSize dflags new_fn_id rhs $
-    splitThunk dflags new_fn_id rhs
-
   | otherwise
-  = return [ (new_fn_id, rhs) ]
+  = do
+    let doSplit | is_fun    = splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs
+                | is_thunk  = splitThunk dflags is_rec new_fn_id rhs
+                                               -- See Note [Thunk splitting]
+                | otherwise = return Nothing
+    try <- doSplit
+    case try of
+        Nothing ->    return $ [ (new_fn_id, rhs) ]
+        Just binds -> checkSize dflags new_fn_id rhs binds
 
   where
-    fn_info     = idInfo fn_id
-    fn_dmd       = demandInfo fn_info
+    fn_info     = idInfo fn_id
     inline_act   = inlinePragmaActivation (inlinePragInfo fn_info)
 
-    worth_splitting_args [d] (Lam b _)
-      | isAbsDmd d && isVoidTy (idType b)
-      = False  -- Note [Do not split void functions]
-    worth_splitting_args wrap_dmds _
-      = any worthSplittingArgDmd wrap_dmds
-
        -- In practice it always will have a strictness
        -- signature, even if it's a uninformative one
     strict_sig  = strictnessInfo fn_info
@@ -299,8 +289,7 @@ tryWW dflags is_rec fn_id rhs
     is_thunk  = not is_fun && not (exprIsHNF rhs)
 
 ---------------------
-checkSize :: DynFlags -> Id -> CoreExpr
-         -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
+checkSize :: DynFlags -> Id -> CoreExpr -> [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
 checkSize dflags fn_id rhs thing_inside
   | isStableUnfolding (realIdUnfolding fn_id)
   = return [ (fn_id, rhs) ]
@@ -315,22 +304,22 @@ checkSize dflags fn_id rhs thing_inside
        -- NB: use idUnfolding because we don't want to apply
        --     this criterion to a loop breaker!
 
-  | otherwise = thing_inside
+  | otherwise = return thing_inside
   where
     inline_rule = mkInlineUnfolding Nothing rhs
 
 ---------------------
-splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
-         -> UniqSM [(Id, CoreExpr)]
+splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr
+         -> UniqSM (Maybe [(Id, CoreExpr)])
 splitFun dflags fn_id fn_info wrap_dmds res_info rhs
-  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
-    (do {
-       -- The arity should match the signature
-      (work_demands, wrap_fn, work_fn) <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots
-    ; work_uniq <- getUniqueM
-    ; let
-       work_rhs = work_fn rhs
-       work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)
+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
+    -- The arity should match the signature
+    stuff <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots
+    case stuff of
+      Just (work_demands, wrap_fn, work_fn) -> do
+        work_uniq <- getUniqueM
+        let work_rhs = work_fn rhs
+           work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)
                        `setIdOccInfo` occInfo fn_info
                                -- Copy over occurrence info from parent
                                -- Notably whether it's a loop breaker
@@ -354,25 +343,27 @@ splitFun dflags fn_id fn_info wrap_dmds res_info rhs
                                 -- Set the arity so that the Core Lint check that the
                                 -- arity is consistent with the demand type goes through
 
-       wrap_rhs  = wrap_fn work_id
-       wrap_prag = InlinePragma { inl_inline = Inline
-                                 , inl_sat    = Nothing
-                                 , inl_act    = ActiveAfter 0
-                                 , inl_rule   = rule_match_info }
+           wrap_rhs  = wrap_fn work_id
+           wrap_prag = InlinePragma { inl_inline = Inline
+                                     , inl_sat    = Nothing
+                                     , inl_act    = ActiveAfter 0
+                                     , inl_rule   = rule_match_info }
                -- See Note [Wrapper activation]
                -- The RuleMatchInfo is (and must be) unaffected
                -- The inl_inline is bound to be False, else we would not be
                --    making a wrapper
 
-       wrap_id   = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity
-                         `setInlinePragma` wrap_prag
-                         `setIdOccInfo` NoOccInfo
+            wrap_id   = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity
+                             `setInlinePragma` wrap_prag
+                             `setIdOccInfo` NoOccInfo
                                -- Zap any loop-breaker-ness, to avoid bleating from Lint
                                -- about a loop breaker with an INLINE rule
+        return $ Just [(work_id, work_rhs), (wrap_id, wrap_rhs)]
+            -- Worker first, because wrapper mentions it
+            -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
 
-    ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
-       -- Worker first, because wrapper mentions it
-       -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
+      Nothing ->
+        return Nothing
   where
     fun_ty          = idType fn_id
     inl_prag        = inlinePragInfo fn_info
@@ -458,8 +449,11 @@ then the splitting will go deeper too.
 --     -->  x = let x = e in
 --              case x of (a,b) -> let x = (a,b)  in x
 
-splitThunk :: DynFlags -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
-splitThunk dflags fn_id rhs = do
-    (_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id]
-    return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
+splitThunk :: DynFlags -> RecFlag -> Var -> Expr Var -> UniqSM (Maybe [(Var, Expr Var)])
+splitThunk dflags is_rec fn_id rhs = do
+    (useful,_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id]
+    let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
+    if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive
+                   return (Just res)
+              else return Nothing
 \end{code}
index 4acf255..1f568b7 100644 (file)
@@ -105,13 +105,13 @@ the unusable strictness-info into the interfaces.
 
 \begin{code}
 mkWwBodies :: DynFlags
-           -> Type                              -- Type of original function
-           -> [Demand]                          -- Strictness of original function
-           -> DmdResult                         -- Info about function result
-           -> [OneShotInfo]                     -- One-shot-ness of the function, value args only
-           -> UniqSM ([Demand],                 -- Demands for worker (value) args
-                      Id -> CoreExpr,           -- Wrapper body, lacking only the worker Id
-                      CoreExpr -> CoreExpr)     -- Worker body, lacking the original function rhs
+           -> Type                                  -- Type of original function
+           -> [Demand]                              -- Strictness of original function
+           -> DmdResult                             -- Info about function result
+           -> [OneShotInfo]                         -- One-shot-ness of the function, value args only
+           -> UniqSM (Maybe ([Demand],              -- Demands for worker (value) args
+                             Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
+                             CoreExpr -> CoreExpr)) -- Worker body, lacking the original function rhs
 
 -- wrap_fn_args E       = \x y -> E
 -- work_fn_args E       = E x y
@@ -128,15 +128,20 @@ mkWwBodies dflags fun_ty demands res_info one_shots
   = do  { let arg_info = demands `zip` (one_shots ++ repeat NoOneShotInfo)
               all_one_shots = foldr (worstOneShot . snd) OneShotLam arg_info
         ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
-        ; (work_args, wrap_fn_str,  work_fn_str) <- mkWWstr dflags wrap_args
+        ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags wrap_args
 
         -- Do CPR w/w.  See Note [Always do CPR w/w]
-        ; (wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) <- mkWWcpr res_ty res_info
+        ; (useful2, wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) <- mkWWcpr res_ty res_info
 
         ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args all_one_shots cpr_res_ty
-        ; return ([idDemandInfo v | v <- work_call_args, isId v],
-                  wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
-                  mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
+              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
+              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
+              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
+
+        ; if useful1 && not (only_one_void_argument) || useful2
+          then return (Just (worker_args_dmds, wrapper_body, worker_body))
+          else return Nothing
+        }
         -- We use an INLINE unconditionally, even if the wrapper turns out to be
         -- something trivial like
         --      fw = ...
@@ -144,6 +149,16 @@ mkWwBodies dflags fun_ty demands res_info one_shots
         -- The point is to propagate the coerce to f's call sites, so even though
         -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
         -- fw from being inlined into f's RHS
+  where
+    -- Note [Do not split void functions]
+    only_one_void_argument
+      | [d] <- demands
+      , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty
+      , isAbsDmd d && isVoidTy arg_ty1
+      = True
+      | otherwise
+      = False
+
 \end{code}
 
 Note [Always do CPR w/w]
@@ -358,7 +373,8 @@ That's why we carry the TvSubst through mkWWargs
 mkWWstr :: DynFlags
         -> [Var]                                -- Wrapper args; have their demand info on them
                                                 --  *Includes type variables*
-        -> UniqSM ([Var],                       -- Worker args
+        -> UniqSM (Bool,                        -- Is this useful
+                   [Var],                       -- Worker args
                    CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call
                                                 -- and without its lambdas
                                                 -- This fn adds the unboxing
@@ -367,12 +383,12 @@ mkWWstr :: DynFlags
                                                 -- and lacking its lambdas.
                                                 -- This fn does the reboxing
 mkWWstr _ []
-  = return ([], nop_fn, nop_fn)
+  = return (False, [], nop_fn, nop_fn)
 
 mkWWstr dflags (arg : args) = do
-    (args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
-    (args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
-    return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
+    (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
+    (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
+    return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
 
 \end{code}
 
@@ -405,29 +421,31 @@ as-yet-un-filled-in pkgState files.
 
 \begin{code}
 ----------------------
--- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn)
+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
 --   *  wrap_fn assumes wrap_arg is in scope,
 --        brings into scope work_args (via cases)
 --   * work_fn assumes work_args are in scope, a
 --        brings into scope wrap_arg (via lets)
-mkWWstr_one :: DynFlags -> Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+mkWWstr_one :: DynFlags -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
 mkWWstr_one dflags arg
   | isTyVar arg
-  = return ([arg],  nop_fn, nop_fn)
+  = return (False, [arg],  nop_fn, nop_fn)
 
+  -- See Note [Worker-wrapper for bottoming functions]
   | isAbsDmd dmd
   , Just work_fn <- mk_absent_let dflags arg
      -- Absent case.  We can't always handle absence for arbitrary
      -- unlifted types, so we need to choose just the cases we can
      --- (that's what mk_absent_let does)
-  = return ([], nop_fn, work_fn)
+  = return (True, [], nop_fn, work_fn)
 
+  -- See Note [Worthy functions for Worker-Wrapper split]
   | isSeqDmd dmd  -- `seq` demand; evaluate in wrapper in the hope
                   -- of dropping seqs in the worker
   = let arg_w_unf = arg `setIdUnfolding` evaldUnfolding
           -- Tell the worker arg that it's sure to be evaluated
           -- so that internal seqs can be dropped
-    in return ([arg_w_unf], mk_seq_case arg, nop_fn)
+    in return (True, [arg_w_unf], mk_seq_case arg, nop_fn)
                 -- Pass the arg, anyway, even if it is in theory discarded
                 -- Consider
                 --      f x y = x `seq` y
@@ -455,12 +473,12 @@ mkWWstr_one dflags arg
                                               data_con unpk_args
                 rebox_fn       = Let (NonRec arg con_app)
                 con_app        = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
-         ; (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
-         ; return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
+         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
                            -- Don't pass the arg, rebox instead
 
   | otherwise   -- Other cases
-  = return ([arg], nop_fn, nop_fn)
+  = return (False, [arg], nop_fn, nop_fn)
 
   where
     dmd = idDemandInfo arg
@@ -530,22 +548,23 @@ left-to-right traversal of the result structure.
 \begin{code}
 mkWWcpr :: Type                              -- function body type
         -> DmdResult                         -- CPR analysis results
-        -> UniqSM (CoreExpr -> CoreExpr,             -- New wrapper
-                   CoreExpr -> CoreExpr,             -- New worker
-                   Type)                        -- Type of worker's body
+        -> UniqSM (Bool,                     -- Is w/w'ing useful?
+                   CoreExpr -> CoreExpr,     -- New wrapper
+                   CoreExpr -> CoreExpr,     -- New worker
+                   Type)                     -- Type of worker's body
 
 mkWWcpr body_ty res
   = case returnsCPR_maybe res of
-       Nothing      -> return (id, id, body_ty)  -- No CPR info
+       Nothing      -> return (False, id, id, body_ty)  -- No CPR info
        Just con_tag | Just stuff <- deepSplitCprType_maybe con_tag body_ty
                     -> mkWWcpr_help stuff
                     |  otherwise
                        -- See Note [non-algebraic or open body type warning]
                     -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
-                       return (id, id, body_ty)
+                       return (False, id, id, body_ty)
 
 mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
-             -> UniqSM (CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
+             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
 
 mkWWcpr_help (data_con, inst_tys, arg_tys, co)
   | [arg_ty1] <- arg_tys
@@ -558,7 +577,8 @@ mkWWcpr_help (data_con, inst_tys, arg_tys, co)
        ; let arg       = mk_ww_local arg_uniq  arg_ty1
              con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
 
-       ; return ( \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
+       ; return ( True
+                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
                 , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (Var arg)
                 , arg_ty1 ) }
 
@@ -572,7 +592,8 @@ mkWWcpr_help (data_con, inst_tys, arg_tys, co)
              ubx_tup_app  = mkConApp2 ubx_tup_con arg_tys args
              con_app      = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
 
-       ; return ( \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)]
+       ; return (True
+                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)]
                 , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app
                 , ubx_tup_ty ) }