ignore RealWorld in size_expr; flag to keep w/w from creating sharing

size_expr now ignores RealWorld lambdas, arguments, and applications.

Worker-wrapper previously removed all lambdas from a function, if they
were all unused. Removing *all* value lambdas is no longer
allowed. Instead (\_ -> E) will become (\_void -> E), where it used to
become E. The previous behavior can be recovered via the new
-ffun-to-thunk flag.

Nofib notables:

----------------------------------------------------------------
        Program               O2          O2 newly ignoring RealWorld
                                          and not turning function
                                          closures into thunks
----------------------------------------------------------------

 Allocations

  comp_lab_zift            333090392%           -5.0%
reverse-complem            155188304%           -3.2%

        rewrite             15380888%           +4.0%
         boyer2              3901064%           +7.5%

rewrite previously benefited from fortunate LoopBreaker choice that is
now disrupted.

A function in boyer2 goes from $wonewayunify1 size 700 to size 650,
thus gets inlined into rewritelemmas, thus exposing a parameter
scrutinisation, thus allowing SpecConstr, which unfortunately involves
reboxing.

Run Time

 fannkuch-redux                 7.89%          -15.9%

            hpg                 0.25%           +5.6%
           wang                 0.21%           +5.8%

/shrug

4 files changed, 54 insertions, 25 deletions

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index d49717c4fa..513bb22166 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -61,6 +61,7 @@ import IdInfo
 import BasicTypes	( Arity )
 import Type
 import PrelNames
+import TysPrim          ( realWorldStatePrimTy )
 import Bag
 import Util
 import FastTypes
@@ -395,16 +396,19 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
     size_up (Type _)   = sizeZero           -- Types cost nothing
     size_up (Coercion _) = sizeZero
     size_up (Lit lit)  = sizeN (litSize lit)
-    size_up (Var f)    = size_up_call f []  -- Make sure we get constructor
-    	    	       	 	      	    -- discounts even on nullary constructors
+    size_up (Var f) | isRealWorldId f = sizeZero
+                      -- Make sure we get constructor discounts even
+                      -- on nullary constructors
+                    | otherwise       = size_up_call f [] 0
 
-    size_up (App fun (Type _)) = size_up fun
-    size_up (App fun (Coercion _)) = size_up fun
-    size_up (App fun arg)      = size_up arg  `addSizeNSD`
-                                 size_up_app fun [arg]
+    size_up (App fun arg)
+      | isTyCoArg arg = size_up fun
+      | otherwise     = size_up arg  `addSizeNSD`
+                        size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0)
 
-    size_up (Lam b e) | isId b    = lamScrutDiscount dflags (size_up e `addSizeN` 10)
-		      | otherwise = size_up e
+    size_up (Lam b e)
+      | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10)
+      | otherwise = size_up e
 
     size_up (Let (NonRec binder rhs) body)
       = size_up rhs		`addSizeNSD`
@@ -480,22 +484,23 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
 
     ------------ 
     -- size_up_app is used when there's ONE OR MORE value args
-    size_up_app (App fun arg) args 
-	| isTyCoArg arg		   = size_up_app fun args
-	| otherwise		   = size_up arg  `addSizeNSD`
-                                     size_up_app fun (arg:args)
-    size_up_app (Var fun)     args = size_up_call fun args
-    size_up_app other         args = size_up other `addSizeN` length args
+    size_up_app (App fun arg) args voids
+	| isTyCoArg arg                  = size_up_app fun args voids
+	| isRealWorldExpr arg            = size_up_app fun (arg:args) (voids + 1)
+	| otherwise		         = size_up arg  `addSizeNSD`
+                                           size_up_app fun (arg:args) voids
+    size_up_app (Var fun)     args voids = size_up_call fun args voids
+    size_up_app other         args voids = size_up other `addSizeN` (length args - voids)
 
     ------------ 
-    size_up_call :: Id -> [CoreExpr] -> ExprSize
-    size_up_call fun val_args
+    size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
+    size_up_call fun val_args voids
        = case idDetails fun of
            FCallId _        -> sizeN (10 * (1 + length val_args))
            DataConWorkId dc -> conSize    dc (length val_args)
            PrimOpId op      -> primOpSize op (length val_args)
 	   ClassOpId _ 	    -> classOpSize dflags top_args val_args
-	   _     	    -> funSize dflags top_args fun (length val_args)
+	   _     	    -> funSize dflags top_args fun (length val_args) voids
 
     ------------ 
     size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10
@@ -528,6 +533,12 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
 	= mkSizeIs bOMB_OUT_SIZE (n1 +# n2) 
                                  (xs `unionBags` ys) 
                                  d2  -- Ignore d1
+
+    isRealWorldId id = idType id `eqType` realWorldStatePrimTy
+
+    -- an expression of type State# RealWorld must be a variable
+    isRealWorldExpr (Var id) = isRealWorldId id
+    isRealWorldExpr _        = False
 \end{code}
 
 
@@ -560,17 +571,17 @@ classOpSize dflags top_args (arg1 : other_args)
 		     	      -> unitBag (dict, ufDictDiscount dflags)
 		     _other   -> emptyBag
     		     
-funSize :: DynFlags -> [Id] -> Id -> Int -> ExprSize
+funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize
 -- Size for functions that are not constructors or primops
 -- Note [Function applications]
-funSize dflags top_args fun n_val_args
+funSize dflags top_args fun n_val_args voids
   | fun `hasKey` buildIdKey   = buildSize
   | fun `hasKey` augmentIdKey = augmentSize
   | otherwise = SizeIs (iUnbox size) arg_discount (iUnbox res_discount)
   where
     some_val_args = n_val_args > 0
 
-    size | some_val_args = 10 * (1 + n_val_args)
+    size | some_val_args = 10 * (1 + n_val_args - voids)
          | otherwise     = 0
 	-- The 1+ is for the function itself
 	-- Add 1 for each non-trivial arg;
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ba860622ed..24c573b366 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -299,6 +299,7 @@ data GeneralFlag
    | Opt_CmmElimCommonBlocks
    | Opt_OmitYields
    | Opt_SimpleListLiterals
+   | Opt_FunToThunk               -- allow WwLib.mkWorkerArgs to remove all value lambdas
 
    -- Interface files
    | Opt_IgnoreInterfacePragmas
@@ -2487,6 +2488,7 @@ fFlags = [
   ( "cmm-elim-common-blocks",           Opt_CmmElimCommonBlocks, nop ),
   ( "omit-yields",                      Opt_OmitYields, nop ),
   ( "simple-list-literals",             Opt_SimpleListLiterals, nop ),
+  ( "fun-to-thunk",                     Opt_FunToThunk, nop ),
   ( "gen-manifest",                     Opt_GenManifest, nop ),
   ( "embed-manifest",                   Opt_EmbedManifest, nop ),
   ( "ext-core",                         Opt_EmitExternalCore, nop ),
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index d03baf04ae..16c368e5c5 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -1409,7 +1409,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
                              `setIdArity` count isId spec_lam_args
               spec_str   = calcSpecStrictness fn spec_lam_args pats
                 -- Conditionally use result of new worker-wrapper transform
-              (spec_lam_args, spec_call_args) = mkWorkerArgs qvars False body_ty
+              (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) qvars False body_ty
                 -- Usual w/w hack to avoid generating 
                 -- a spec_rhs of unlifted type and no args
 
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index fb9396e5ea..810db2069b 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -140,7 +140,7 @@ mkWwBodies dflags fun_ty demands res_info one_shots
         -- 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
 
-	; let (work_lam_args, work_call_args) = mkWorkerArgs work_args all_one_shots cpr_res_ty
+	; 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) }
@@ -184,23 +184,39 @@ add a void argument.  E.g.
 We use the state-token type which generates no code.
 
 \begin{code}
-mkWorkerArgs :: [Var]
+mkWorkerArgs :: DynFlags -> [Var]
              -> Bool    -- Whether all arguments are one-shot
 	     -> Type	-- Type of body
 	     -> ([Var],	-- Lambda bound args
 		 [Var])	-- Args at call site
-mkWorkerArgs args all_one_shot res_ty
-    | any isId args || not (isUnLiftedType res_ty)
+mkWorkerArgs dflags args all_one_shot res_ty
+    | any isId args || not needsAValueLambda
     = (args, args)
     | otherwise	
     = (args ++ [newArg], args ++ [realWorldPrimId])
     where
+      needsAValueLambda =
+        isUnLiftedType res_ty
+        || not (gopt Opt_FunToThunk dflags)
+           -- see Note [Protecting the last value argument]
+
       -- see Note [All One-Shot Arguments of a Worker]
       newArg = if all_one_shot 
                then setOneShotLambda voidArgId
                else voidArgId     
 \end{code}
 
+Note [Protecting the last value argument]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+If the user writes (\_ -> E), they might be intentionally disallowing
+the sharing of E. Since absence analysis and worker-wrapper are keen
+to remove such unused arguments, we add in a void argument to prevent
+the function from becoming a thunk.
+
+The user can avoid that argument with the -ffun-to-thunk
+flag. However, removing all the value argus may introduce space leaks.
+
 Note [All One-Shot Arguments of a Worker]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~