Remove OneShotInfo field of LFReEntrant, document OneShotInfo

The field is only used in withNewTickyCounterFun and it's easier to
directly pass a parameter for one-shot info to withNewTickyCounterFun
instead of passing it via LFReEntrant. This also makes !2842 simpler.

Other changes:

- New Note (by SPJ) [OneShotInfo overview] added.
- Arity argument of thunkCode removed as it's always 0.

4 files changed, 106 insertions, 50 deletions

diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 566f4ad281..9d3b12a631 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -111,7 +111,7 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
               (_, _, fv_details) = mkVirtHeapOffsets dflags header []
         -- Don't drop the non-void args until the closure info has been made
         ; forkClosureBody (closureCodeBody True id closure_info ccs
-                                (nonVoidIds args) (length args) body fv_details)
+                                args body fv_details)
 
         ; return () }
 
@@ -358,8 +358,8 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body
                 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
                 --                  (b) ignore Sequel from context; use empty Sequel
                 -- And compile the body
-                closureCodeBody False bndr closure_info cc (nonVoidIds args)
-                                (length args) body fv_details
+                closureCodeBody False bndr closure_info cc args
+                                body fv_details
 
         -- BUILD THE OBJECT
 --      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
@@ -436,8 +436,7 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
                 -> Id              -- the closure's name
                 -> ClosureInfo     -- Lots of information about this closure
                 -> CostCentreStack -- Optional cost centre attached to closure
-                -> [NonVoid Id]    -- incoming args to the closure
-                -> Int             -- arity, including void args
+                -> [Id]            -- incoming args to the closure
                 -> CgStgExpr
                 -> [(NonVoid Id, ByteOff)] -- the closure's free vars
                 -> FCode ()
@@ -452,31 +451,32 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
   normal form, so there is no need to set up an update frame.
 -}
 
-closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
-  | arity == 0 -- No args i.e. thunk
+-- No args i.e. thunk
+closureCodeBody top_lvl bndr cl_info cc [] body fv_details
   = withNewTickyCounterThunk
         (isStaticClosure cl_info)
         (closureUpdReqd cl_info)
         (closureName cl_info) $
     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
-      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
+      \(_, node, _) -> thunkCode cl_info fv_details cc node body
    where
      lf_info  = closureLFInfo cl_info
      info_tbl = mkCmmInfo cl_info bndr cc
 
-closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
-  = -- Note: args may be [], if all args are Void
-    withNewTickyCounterFun
-        (closureSingleEntry cl_info)
-        (closureName cl_info)
-        args $ do {
+closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
+  = let nv_args = nonVoidIds args
+        arity = length args
+    in
+    -- See Note [OneShotInfo overview] in GHC.Types.Basic.
+    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info)
+        nv_args $ do {
 
         ; let
              lf_info  = closureLFInfo cl_info
              info_tbl = mkCmmInfo cl_info bndr cc
 
         -- Emit the main entry code
-        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
+        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl nv_args $
             \(_offset, node, arg_regs) -> do
                 -- Emit slow-entry code (for entering a closure through a PAP)
                 { mkSlowEntryCode bndr cl_info arg_regs
@@ -565,15 +565,15 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
 
 -----------------------------------------
 thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
-          -> LocalReg -> Int -> CgStgExpr -> FCode ()
-thunkCode cl_info fv_details _cc node arity body
+          -> LocalReg -> CgStgExpr -> FCode ()
+thunkCode cl_info fv_details _cc node body
   = do { dflags <- getDynFlags
        ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
              node'       = if node_points then Just node else Nothing
         ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
 
         -- Heap overflow check
-        ; entryHeapCheck cl_info node' arity [] $ do
+        ; entryHeapCheck cl_info node' 0 [] $ do
         { -- Overwrite with black hole if necessary
           -- but *after* the heap-overflow check
         ; tickyEnterThunk cl_info
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index 431a46ef48..7f29d43bca 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -48,7 +48,7 @@ module GHC.StgToCmm.Closure (
 
         -- ** Predicates
         -- These are really just functions on LambdaFormInfo
-        closureUpdReqd, closureSingleEntry,
+        closureUpdReqd,
         closureReEntrant, closureFunInfo,
         isToplevClosure,
 
@@ -201,7 +201,6 @@ argPrimRep arg = typePrimRep1 (stgArgType arg)
 data LambdaFormInfo
   = LFReEntrant         -- Reentrant closure (a function)
         TopLevelFlag    -- True if top level
-        OneShotInfo
         !RepArity       -- Arity. Invariant: always > 0
         !Bool           -- True <=> no fvs
         ArgDescr        -- Argument descriptor (should really be in ClosureInfo)
@@ -285,8 +284,7 @@ mkLFReEntrant :: TopLevelFlag    -- True of top level
 mkLFReEntrant _ _ [] _
   = pprPanic "mkLFReEntrant" empty
 mkLFReEntrant top fvs args arg_descr
-  = LFReEntrant top os_info (length args) (null fvs) arg_descr
-  where os_info = idOneShotInfo (head args)
+  = LFReEntrant top (length args) (null fvs) arg_descr
 
 -------------
 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
@@ -335,7 +333,7 @@ mkLFImported id
                 -- the id really does point directly to the constructor
 
   | arity > 0
-  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
+  = LFReEntrant TopLevel arity True (panic "arg_descr")
 
   | otherwise
   = mkLFArgument id -- Not sure of exact arity
@@ -384,9 +382,9 @@ tagForArity dflags arity
 lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
 -- Return the tag in the low order bits of a variable bound
 -- to this LambdaForm
-lfDynTag dflags (LFCon con)                 = tagForCon dflags con
-lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity
-lfDynTag _      _other                      = 0
+lfDynTag dflags (LFCon con)               = tagForCon dflags con
+lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity
+lfDynTag _      _other                    = 0
 
 
 -----------------------------------------------------------------------------
@@ -407,11 +405,11 @@ isLFReEntrant _                = False
 -----------------------------------------------------------------------------
 
 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
-lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
-lfClosureType (LFCon con)                    = Constr (dataConTagZ con)
-                                                      (dataConIdentity con)
-lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel
-lfClosureType _                              = panic "lfClosureType"
+lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con)                  = Constr (dataConTagZ con)
+                                                    (dataConIdentity con)
+lfClosureType (LFThunk _ _ _ is_sel _)     = thunkClosureType is_sel
+lfClosureType _                            = panic "lfClosureType"
 
 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
 thunkClosureType (SelectorThunk off) = ThunkSelector off
@@ -431,7 +429,7 @@ nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
 -- this closure has R1 (the "Node" register) pointing to the
 -- closure itself --- the "self" argument
 
-nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
+nodeMustPointToIt _ (LFReEntrant top _ no_fvs _)
   =  not no_fvs          -- Certainly if it has fvs we need to point to it
   || isNotTopLevel top   -- See Note [GC recovery]
         -- For lex_profiling we also access the cost centre for a
@@ -566,7 +564,7 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc
   -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details
   = JumpToIt block_id args
 
-getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
+getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc
               _self_loop_info
   | n_args == 0 -- No args at all
   && not (gopt Opt_SccProfilingOn dflags)
@@ -811,11 +809,6 @@ lfUpdatable :: LambdaFormInfo -> Bool
 lfUpdatable (LFThunk _ _ upd _ _)  = upd
 lfUpdatable _ = False
 
-closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
-closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
-closureSingleEntry _ = False
-
 closureReEntrant :: ClosureInfo -> Bool
 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
 closureReEntrant _ = False
@@ -824,8 +817,8 @@ closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
 
 lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)
-lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)
-lfFunInfo _                                   = Nothing
+lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
+lfFunInfo _                                 = Nothing
 
 funTag :: DynFlags -> ClosureInfo -> DynTag
 funTag dflags (ClosureInfo { closureLFInfo = lf_info })
@@ -834,9 +827,9 @@ funTag dflags (ClosureInfo { closureLFInfo = lf_info })
 isToplevClosure :: ClosureInfo -> Bool
 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
   = case lf_info of
-      LFReEntrant TopLevel _ _ _ _ -> True
-      LFThunk TopLevel _ _ _ _     -> True
-      _other                       -> False
+      LFReEntrant TopLevel _ _ _ -> True
+      LFThunk TopLevel _ _ _ _   -> True
+      _other                     -> False
 
 --------------------------------------
 --   Label generation
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index 1170e48a73..b84b1cb055 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -92,8 +92,7 @@ module GHC.StgToCmm.Ticky (
   tickyEnterViaNode,
 
   tickyEnterFun,
-  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value
-                                              -- thunks only
+  tickyEnterThunk,
   tickyEnterLNE,
 
   tickyUpdateBhCaf,
@@ -291,7 +290,7 @@ tickyEnterThunk cl_info
       registerTickyCtrAtEntryDyn ticky_ctr_lbl
       bumpTickyEntryCount ticky_ctr_lbl }
   where
-    updatable = closureSingleEntry cl_info
+    updatable = not (closureUpdReqd cl_info)
     static    = isStaticClosure cl_info
 
     ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"
@@ -299,9 +298,6 @@ tickyEnterThunk cl_info
         | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"
                                    else fsLit "ENT_DYN_THK_MANY_ctr"
 
-tickyEnterStdThunk :: ClosureInfo -> FCode ()
-tickyEnterStdThunk = tickyEnterThunk
-
 tickyBlackHole :: Bool{-updatable-} -> FCode ()
 tickyBlackHole updatable
   = ifTicky (bumpTickyCounter ctr)
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index b878328c2d..a361036c3c 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -243,13 +243,80 @@ instance Outputable Alignment where
 ************************************************************************
 -}
 
+{-
+Note [OneShotInfo overview]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lambda-bound Ids (and only lambda-bound Ids) may be decorated with
+one-shot info.  The idea is that if we see
+    (\x{one-shot}. e)
+it means that this lambda will only be applied once.  In particular
+that means we can float redexes under the lambda without losing
+work.  For example, consider
+    let t = expensive in
+    (\x{one-shot}. case t of { True -> ...; False -> ... })
+
+Because it's a one-shot lambda, we can safely inline t, giving
+    (\x{one_shot}. case <expensive> of of
+                       { True -> ...; False -> ... })
+
+Moving parts:
+
+* Usage analysis, performed as part of demand-analysis, finds
+  out whether functions call their argument once.  Consider
+     f g x = Just (case g x of { ... })
+
+  Here 'f' is lazy in 'g', but it guarantees to call it no
+  more than once.  So g will get a C1(U) usage demand.
+
+* Occurrence analysis propagates this usage information
+  (in the demand signature of a function) to its calls.
+  Example, given 'f' above
+     f (\x.e) blah
+
+  Since f's demand signature says it has a C1(U) usage demand on its
+  first argument, the occurrence analyser sets the \x to be one-shot.
+  This is done via the occ_one_shots field of OccEnv.
+
+* Float-in and float-out take account of one-shot-ness
+
+* Occurrence analysis doesn't set "inside-lam" for occurrences inside
+  a one-shot lambda
+
+Other notes
+
+* A one-shot lambda can use its argument many times.  To elaborate
+  the example above
+    let t = expensive in
+    (\x{one-shot}. case t of { True -> x+x; False -> x*x })
+
+  Here the '\x' is one-shot, which justifies inlining 't',
+  but x is used many times. That's absolutely fine.
+
+* It's entirely possible to have
+     (\x{one-shot}. \y{many-shot}. e)
+
+  For example
+     let t = expensive
+         g = \x -> let v = x+t in
+             \y -> x + v
+     in map (g 5) xs
+
+  Here the `\x` is a one-shot binder: `g` is applied to one argument
+  exactly once.  And because the `\x` is one-shot, it would be fine to
+  float that `let t = expensive` binding inside the `\x`.
+
+  But the `\y` is most definitely not one-shot!
+-}
+
 -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
 -- variable info. Sometimes we know whether the lambda binding this variable
--- is a \"one-shot\" lambda; that is, whether it is applied at most once.
+-- is a "one-shot" lambda; that is, whether it is applied at most once.
 --
 -- This information may be useful in optimisation, as computations may
 -- safely be floated inside such a lambda without risk of duplicating
 -- work.
+--
+-- See also Note [OneShotInfo overview] above.
 data OneShotInfo
   = NoOneShotInfo -- ^ No information
   | OneShotLam    -- ^ The lambda is applied at most once.