{-# LANGUAGE CPP #-}

-- | Constructed Product Result analysis. Identifies functions that surely
-- return heap-allocated records on every code path, so that we can eliminate
-- said heap allocation by performing a worker/wrapper split.
--
-- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/.
-- CPR analysis should happen after strictness analysis.
-- See Note [Phase ordering].
module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Driver.Session
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Core
import GHC.Core.Seq
import GHC.Utils.Outputable
import GHC.Builtin.Names ( runRWKey )
import GHC.Types.Var.Env
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.DataCon
import GHC.Core.Multiplicity
import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram )
import GHC.Core.Type
import GHC.Core.FamInstEnv
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Logger  ( Logger, dumpIfSet_dyn, DumpFormat (..) )
import GHC.Data.Graph.UnVar -- for UnVarSet
import GHC.Data.Maybe   ( isNothing )

import Control.Monad ( guard )
import Data.List ( mapAccumL )

import GHC.Driver.Ppr
String -> SDoc -> Any -> Any
_ = String -> SDoc -> Any -> Any
forall a. String -> SDoc -> a -> a
pprTrace -- Tired of commenting out the import all the time

{- Note [Constructed Product Result]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The goal of Constructed Product Result analysis is to identify functions that
surely return heap-allocated records on every code path, so that we can
eliminate said heap allocation by performing a worker/wrapper split.

@swap@ below is such a function:

  swap (a, b) = (b, a)

A @case@ on an application of @swap@, like
@case swap (10, 42) of (a, b) -> a + b@ could cancel away
(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then
say that @swap@ has the CPR property.

We can't inline recursive functions, but similar reasoning applies there:

  f x n = case n of
    0 -> (x, 0)
    _ -> f (x+1) (n-1)

Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed
product with the case. So @f@, too, has the CPR property. But we can't really
"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@
might be too big to inline (or even marked NOINLINE). We still want to exploit
the CPR property, and that is exactly what the worker/wrapper transformation
can do for us:

  $wf x n = case n of
    0 -> case (x, 0) of -> (a, b) -> (# a, b #)
    _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #)
  f x n = case $wf x n of (# a, b #) -> (a, b)

where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to:

  $wf x n = case n of
    0 -> (# x, 0 #)
    _ -> $wf (x+1) (n-1)

Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and
eliminate the heap-allocated pair constructor.

Note [Phase ordering]
~~~~~~~~~~~~~~~~~~~~~
We need to perform strictness analysis before CPR analysis, because that might
unbox some arguments, in turn leading to more constructed products.
Ideally, we would want the following pipeline:

1. Strictness
2. worker/wrapper (for strictness)
3. CPR
4. worker/wrapper (for CPR)

Currently, we omit 2. and anticipate the results of worker/wrapper.
See Note [CPR for binders that will be unboxed]
and Note [Optimistic field binder CPR].
An additional w/w pass would simplify things, but probably add slight overhead.
So currently we have

1. Strictness
2. CPR
3. worker/wrapper (for strictness and CPR)
-}

--
-- * Analysing programs
--

cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
cprAnalProgram Logger
logger DynFlags
dflags FamInstEnvs
fam_envs CoreProgram
binds = do
  let env :: AnalEnv
env            = FamInstEnvs -> AnalEnv
emptyAnalEnv FamInstEnvs
fam_envs
  let binds_plus_cpr :: CoreProgram
binds_plus_cpr = (AnalEnv, CoreProgram) -> CoreProgram
forall a b. (a, b) -> b
snd ((AnalEnv, CoreProgram) -> CoreProgram)
-> (AnalEnv, CoreProgram) -> CoreProgram
forall a b. (a -> b) -> a -> b
$ (AnalEnv -> CoreBind -> (AnalEnv, CoreBind))
-> AnalEnv -> CoreProgram -> (AnalEnv, CoreProgram)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
cprAnalTopBind AnalEnv
env CoreProgram
binds
  Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_cpr_signatures String
"Cpr signatures" DumpFormat
FormatText (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
    (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram (CprSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CprSig -> SDoc) -> (IdInfo -> CprSig) -> IdInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> CprSig
cprInfo) CoreProgram
binds_plus_cpr
  -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
  CoreProgram -> ()
seqBinds CoreProgram
binds_plus_cpr () -> IO CoreProgram -> IO CoreProgram
`seq` CoreProgram -> IO CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_plus_cpr

-- Analyse a (group of) top-level binding(s)
cprAnalTopBind :: AnalEnv
               -> CoreBind
               -> (AnalEnv, CoreBind)
cprAnalTopBind :: AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
cprAnalTopBind AnalEnv
env (NonRec CoreBndr
id Expr CoreBndr
rhs)
  = (AnalEnv
env', CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
id' Expr CoreBndr
rhs')
  where
    (CoreBndr
id', Expr CoreBndr
rhs', AnalEnv
env') = TopLevelFlag
-> AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> (CoreBndr, Expr CoreBndr, AnalEnv)
cprAnalBind TopLevelFlag
TopLevel AnalEnv
env CoreBndr
id Expr CoreBndr
rhs

cprAnalTopBind AnalEnv
env (Rec [(CoreBndr, Expr CoreBndr)]
pairs)
  = (AnalEnv
env', [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
pairs')
  where
    (AnalEnv
env', [(CoreBndr, Expr CoreBndr)]
pairs') = TopLevelFlag
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
cprFix TopLevelFlag
TopLevel AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs

--
-- * Analysing expressions
--

-- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from
-- "Constructed Product Result Analysis for Haskell"
cprAnal, cprAnal'
  :: AnalEnv
  -> CoreExpr            -- ^ expression to be denoted by a 'CprType'
  -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'

cprAnal :: AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $
                  AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal' AnalEnv
env Expr CoreBndr
e

cprAnal' :: AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal' AnalEnv
_ (Lit Literal
lit)     = (CprType
topCprType, Literal -> Expr CoreBndr
forall b. Literal -> Expr b
Lit Literal
lit)
cprAnal' AnalEnv
_ (Type Type
ty)     = (CprType
topCprType, Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
ty)      -- Doesn't happen, in fact
cprAnal' AnalEnv
_ (Coercion Coercion
co) = (CprType
topCprType, Coercion -> Expr CoreBndr
forall b. Coercion -> Expr b
Coercion Coercion
co)

cprAnal' AnalEnv
env (Cast Expr CoreBndr
e Coercion
co)
  = (CprType
cpr_ty, Expr CoreBndr -> Coercion -> Expr CoreBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr CoreBndr
e' Coercion
co)
  where
    (CprType
cpr_ty, Expr CoreBndr
e') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
e

cprAnal' AnalEnv
env (Tick CoreTickish
t Expr CoreBndr
e)
  = (CprType
cpr_ty, CoreTickish -> Expr CoreBndr -> Expr CoreBndr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t Expr CoreBndr
e')
  where
    (CprType
cpr_ty, Expr CoreBndr
e') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
e

cprAnal' AnalEnv
env e :: Expr CoreBndr
e@(Var{})
  = AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
e [] []
cprAnal' AnalEnv
env e :: Expr CoreBndr
e@(App{})
  = AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
e [] []

cprAnal' AnalEnv
env (Lam CoreBndr
var Expr CoreBndr
body)
  | CoreBndr -> Bool
isTyVar CoreBndr
var
  , (CprType
body_ty, Expr CoreBndr
body') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
body
  = (CprType
body_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var Expr CoreBndr
body')
  | Bool
otherwise
  = (CprType
lam_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var Expr CoreBndr
body')
  where
    -- See Note [CPR for binders that will be unboxed]
    env' :: AnalEnv
env'             = AnalEnv -> CoreBndr -> AnalEnv
extendSigEnvForArg AnalEnv
env CoreBndr
var
    (CprType
body_ty, Expr CoreBndr
body') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env' Expr CoreBndr
body
    lam_ty :: CprType
lam_ty           = CprType -> CprType
abstractCprTy CprType
body_ty

cprAnal' AnalEnv
env (Case Expr CoreBndr
scrut CoreBndr
case_bndr Type
ty [Alt CoreBndr]
alts)
  = (CprType
res_ty, Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr CoreBndr
scrut' CoreBndr
case_bndr Type
ty [Alt CoreBndr]
alts')
  where
    (CprType
scrut_ty, Expr CoreBndr
scrut') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
scrut
    env' :: AnalEnv
env'               = AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
case_bndr (CprType -> CprSig
CprSig CprType
scrut_ty)
    ([CprType]
alt_tys, [Alt CoreBndr]
alts')   = (Alt CoreBndr -> (CprType, Alt CoreBndr))
-> [Alt CoreBndr] -> ([CprType], [Alt CoreBndr])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (AnalEnv -> CprType -> Alt CoreBndr -> (CprType, Alt CoreBndr)
cprAnalAlt AnalEnv
env' CprType
scrut_ty) [Alt CoreBndr]
alts
    res_ty :: CprType
res_ty             = (CprType -> CprType -> CprType) -> CprType -> [CprType] -> CprType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CprType -> CprType -> CprType
lubCprType CprType
botCprType [CprType]
alt_tys

cprAnal' AnalEnv
env (Let (NonRec CoreBndr
id Expr CoreBndr
rhs) Expr CoreBndr
body)
  = (CprType
body_ty, CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
id' Expr CoreBndr
rhs') Expr CoreBndr
body')
  where
    (CoreBndr
id', Expr CoreBndr
rhs', AnalEnv
env') = TopLevelFlag
-> AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> (CoreBndr, Expr CoreBndr, AnalEnv)
cprAnalBind TopLevelFlag
NotTopLevel AnalEnv
env CoreBndr
id Expr CoreBndr
rhs
    (CprType
body_ty, Expr CoreBndr
body')  = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env' Expr CoreBndr
body

cprAnal' AnalEnv
env (Let (Rec [(CoreBndr, Expr CoreBndr)]
pairs) Expr CoreBndr
body)
  = CprType
body_ty CprType -> (CprType, Expr CoreBndr) -> (CprType, Expr CoreBndr)
`seq` (CprType
body_ty, CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let ([(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
pairs') Expr CoreBndr
body')
  where
    (AnalEnv
env', [(CoreBndr, Expr CoreBndr)]
pairs')   = TopLevelFlag
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
cprFix TopLevelFlag
NotTopLevel AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs
    (CprType
body_ty, Expr CoreBndr
body') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env' Expr CoreBndr
body

cprAnalAlt
  :: AnalEnv
  -> CprType -- ^ CPR type of the scrutinee
  -> Alt Var -- ^ current alternative
  -> (CprType, Alt Var)
cprAnalAlt :: AnalEnv -> CprType -> Alt CoreBndr -> (CprType, Alt CoreBndr)
cprAnalAlt AnalEnv
env CprType
scrut_ty (Alt AltCon
con [CoreBndr]
bndrs Expr CoreBndr
rhs)
  = (CprType
rhs_ty, AltCon -> [CoreBndr] -> Expr CoreBndr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
bndrs Expr CoreBndr
rhs')
  where
    env_alt :: AnalEnv
env_alt
      | DataAlt DataCon
dc <- AltCon
con
      , let ids :: [CoreBndr]
ids = (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreBndr -> Bool
isId [CoreBndr]
bndrs
      , CprType Arity
arity Cpr
cpr <- CprType
scrut_ty
      , ASSERT( arity == 0 ) True
      = case DataCon -> Cpr -> UnpackConFieldsResult
unpackConFieldsCpr DataCon
dc Cpr
cpr of
          AllFieldsSame Cpr
field_cpr
            | let sig :: CprSig
sig = Arity -> Cpr -> CprSig
mkCprSig Arity
0 Cpr
field_cpr
            -> AnalEnv -> [CoreBndr] -> CprSig -> AnalEnv
extendSigEnvAllSame AnalEnv
env [CoreBndr]
ids CprSig
sig
          ForeachField [Cpr]
field_cprs
            | let sigs :: [CprSig]
sigs = (CoreBndr -> Cpr -> CprSig) -> [CoreBndr] -> [Cpr] -> [CprSig]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Arity -> Cpr -> CprSig
mkCprSig (Arity -> Cpr -> CprSig)
-> (CoreBndr -> Arity) -> CoreBndr -> Cpr -> CprSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Arity
idArity) [CoreBndr]
ids [Cpr]
field_cprs
            -> AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
extendSigEnvList AnalEnv
env (String -> [CoreBndr] -> [CprSig] -> [(CoreBndr, CprSig)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"cprAnalAlt" [CoreBndr]
ids [CprSig]
sigs)
      | Bool
otherwise
      = AnalEnv
env
    (CprType
rhs_ty, Expr CoreBndr
rhs') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env_alt Expr CoreBndr
rhs

--
-- * CPR transformer
--

cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr)
cprAnalApp :: AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
e [Expr CoreBndr]
args' [CprType]
arg_tys
  -- Collect CprTypes for (value) args (inlined collectArgs):
  | App Expr CoreBndr
fn Expr CoreBndr
arg <- Expr CoreBndr
e, Expr CoreBndr -> Bool
forall b. Expr b -> Bool
isTypeArg Expr CoreBndr
arg -- Don't analyse Type args
  = AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
fn (Expr CoreBndr
argExpr CoreBndr -> [Expr CoreBndr] -> [Expr CoreBndr]
forall a. a -> [a] -> [a]
:[Expr CoreBndr]
args') [CprType]
arg_tys
  | App Expr CoreBndr
fn Expr CoreBndr
arg <- Expr CoreBndr
e
  , (CprType
arg_ty, Expr CoreBndr
arg') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
arg
  = AnalEnv
-> Expr CoreBndr
-> [Expr CoreBndr]
-> [CprType]
-> (CprType, Expr CoreBndr)
cprAnalApp AnalEnv
env Expr CoreBndr
fn (Expr CoreBndr
arg'Expr CoreBndr -> [Expr CoreBndr] -> [Expr CoreBndr]
forall a. a -> [a] -> [a]
:[Expr CoreBndr]
args') (CprType
arg_tyCprType -> [CprType] -> [CprType]
forall a. a -> [a] -> [a]
:[CprType]
arg_tys)

  | Var CoreBndr
fn <- Expr CoreBndr
e
  = (AnalEnv -> CoreBndr -> [CprType] -> CprType
cprTransform AnalEnv
env CoreBndr
fn [CprType]
arg_tys, Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr CoreBndr
e [Expr CoreBndr]
args')

  | Bool
otherwise -- e is not an App and not a Var
  , (CprType
e_ty, Expr CoreBndr
e') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
e
  = (CprType -> Arity -> CprType
applyCprTy CprType
e_ty ([CprType] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CprType]
arg_tys), Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr CoreBndr
e' [Expr CoreBndr]
args')

cprTransform :: AnalEnv   -- ^ The analysis environment
             -> Id        -- ^ The function
             -> [CprType] -- ^ info about incoming /value/ arguments
             -> CprType   -- ^ The demand type of the application
cprTransform :: AnalEnv -> CoreBndr -> [CprType] -> CprType
cprTransform AnalEnv
env CoreBndr
id [CprType]
args
  = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig])
    CprType
sig
  where
    sig :: CprType
sig
      -- Top-level binding, local let-binding, lambda arg or case binder
      | Just CprSig
sig <- AnalEnv -> CoreBndr -> Maybe CprSig
lookupSigEnv AnalEnv
env CoreBndr
id
      = CprType -> Arity -> CprType
applyCprTy (CprSig -> CprType
getCprSig CprSig
sig) ([CprType] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CprType]
args)
      -- CPR transformers for special Ids
      | Just CprType
cpr_ty <- CoreBndr -> [CprType] -> Maybe CprType
cprTransformSpecial CoreBndr
id [CprType]
args
      = CprType
cpr_ty
      -- See Note [CPR for data structures]
      | Just Expr CoreBndr
rhs <- CoreBndr -> Maybe (Expr CoreBndr)
cprDataStructureUnfolding_maybe CoreBndr
id
      = (CprType, Expr CoreBndr) -> CprType
forall a b. (a, b) -> a
fst ((CprType, Expr CoreBndr) -> CprType)
-> (CprType, Expr CoreBndr) -> CprType
forall a b. (a -> b) -> a -> b
$ AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
rhs
      -- Imported function or data con worker
      | CoreBndr -> Bool
isGlobalId CoreBndr
id
      = CprType -> Arity -> CprType
applyCprTy (CprSig -> CprType
getCprSig (CoreBndr -> CprSig
idCprInfo CoreBndr
id)) ([CprType] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CprType]
args)
      | Bool
otherwise
      = CprType
topCprType

-- | CPR transformers for special Ids
cprTransformSpecial :: Id -> [CprType] -> Maybe CprType
cprTransformSpecial :: CoreBndr -> [CprType] -> Maybe CprType
cprTransformSpecial CoreBndr
id [CprType]
args
  -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep
  | CoreBndr -> Unique
idUnique CoreBndr
id Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
runRWKey -- `runRW (\s -> e)`
  , [CprType
arg] <- [CprType]
args           -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)
  = CprType -> Maybe CprType
forall a. a -> Maybe a
Just (CprType -> Maybe CprType) -> CprType -> Maybe CprType
forall a b. (a -> b) -> a -> b
$ CprType -> Arity -> CprType
applyCprTy CprType
arg Arity
1 -- `e` has CPR type `2`
  | Bool
otherwise
  = Maybe CprType
forall a. Maybe a
Nothing

--
-- * Bindings
--

-- Recursive bindings
cprFix :: TopLevelFlag
       -> AnalEnv                    -- Does not include bindings for this binding
       -> [(Id,CoreExpr)]
       -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info
cprFix :: TopLevelFlag
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
cprFix TopLevelFlag
top_lvl AnalEnv
orig_env [(CoreBndr, Expr CoreBndr)]
orig_pairs
  = Arity
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
loop Arity
1 AnalEnv
init_env [(CoreBndr, Expr CoreBndr)]
init_pairs
  where
    init_sig :: CoreBndr -> Expr CoreBndr -> CprSig
init_sig CoreBndr
id Expr CoreBndr
rhs
      -- See Note [CPR for data structures]
      | CoreBndr -> Expr CoreBndr -> Bool
isDataStructure CoreBndr
id Expr CoreBndr
rhs = CprSig
topCprSig
      | Bool
otherwise              = Arity -> Cpr -> CprSig
mkCprSig Arity
0 Cpr
botCpr
    -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
    orig_virgin :: Bool
orig_virgin = AnalEnv -> Bool
ae_virgin AnalEnv
orig_env
    init_pairs :: [(CoreBndr, Expr CoreBndr)]
init_pairs | Bool
orig_virgin  = [(CoreBndr -> CprSig -> CoreBndr
setIdCprInfo CoreBndr
id (CoreBndr -> Expr CoreBndr -> CprSig
init_sig CoreBndr
id Expr CoreBndr
rhs), Expr CoreBndr
rhs) | (CoreBndr
id, Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
orig_pairs ]
               | Bool
otherwise    = [(CoreBndr, Expr CoreBndr)]
orig_pairs
    init_env :: AnalEnv
init_env = AnalEnv -> [CoreBndr] -> AnalEnv
extendSigEnvFromIds AnalEnv
orig_env (((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
init_pairs)

    -- The fixed-point varies the idCprInfo field of the binders and and their
    -- entries in the AnalEnv, and terminates if that annotation does not change
    -- any more.
    loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
    loop :: Arity
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
loop Arity
n AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs
      | Bool
found_fixpoint = (AnalEnv
reset_env', [(CoreBndr, Expr CoreBndr)]
pairs')
      | Bool
otherwise      = Arity
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
loop (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) AnalEnv
env' [(CoreBndr, Expr CoreBndr)]
pairs'
      where
        -- In all but the first iteration, delete the virgin flag
        -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
        (AnalEnv
env', [(CoreBndr, Expr CoreBndr)]
pairs') = AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
step (Bool -> (AnalEnv -> AnalEnv) -> AnalEnv -> AnalEnv
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Arity
nArity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
/=Arity
1) AnalEnv -> AnalEnv
nonVirgin AnalEnv
env) [(CoreBndr, Expr CoreBndr)]
pairs
        -- Make sure we reset the virgin flag to what it was when we are stable
        reset_env' :: AnalEnv
reset_env'     = AnalEnv
env'{ ae_virgin :: Bool
ae_virgin = Bool
orig_virgin }
        found_fixpoint :: Bool
found_fixpoint = ((CoreBndr, Expr CoreBndr) -> CprSig)
-> [(CoreBndr, Expr CoreBndr)] -> [CprSig]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> CprSig
idCprInfo (CoreBndr -> CprSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> CprSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, Expr CoreBndr)]
pairs' [CprSig] -> [CprSig] -> Bool
forall a. Eq a => a -> a -> Bool
== ((CoreBndr, Expr CoreBndr) -> CprSig)
-> [(CoreBndr, Expr CoreBndr)] -> [CprSig]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> CprSig
idCprInfo (CoreBndr -> CprSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> CprSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, Expr CoreBndr)]
pairs

    step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)])
    step :: AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
step AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs = (AnalEnv
 -> (CoreBndr, Expr CoreBndr)
 -> (AnalEnv, (CoreBndr, Expr CoreBndr)))
-> AnalEnv
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL AnalEnv
-> (CoreBndr, Expr CoreBndr)
-> (AnalEnv, (CoreBndr, Expr CoreBndr))
go AnalEnv
env [(CoreBndr, Expr CoreBndr)]
pairs
      where
        go :: AnalEnv
-> (CoreBndr, Expr CoreBndr)
-> (AnalEnv, (CoreBndr, Expr CoreBndr))
go AnalEnv
env (CoreBndr
id, Expr CoreBndr
rhs) = (AnalEnv
env', (CoreBndr
id', Expr CoreBndr
rhs'))
          where
            (CoreBndr
id', Expr CoreBndr
rhs', AnalEnv
env') = TopLevelFlag
-> AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> (CoreBndr, Expr CoreBndr, AnalEnv)
cprAnalBind TopLevelFlag
top_lvl AnalEnv
env CoreBndr
id Expr CoreBndr
rhs

-- | Process the RHS of the binding for a sensible arity, add the CPR signature
-- to the Id, and augment the environment with the signature as well.
cprAnalBind
  :: TopLevelFlag
  -> AnalEnv
  -> Id
  -> CoreExpr
  -> (Id, CoreExpr, AnalEnv)
cprAnalBind :: TopLevelFlag
-> AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> (CoreBndr, Expr CoreBndr, AnalEnv)
cprAnalBind TopLevelFlag
top_lvl AnalEnv
env CoreBndr
id Expr CoreBndr
rhs
  -- See Note [CPR for data structures]
  | CoreBndr -> Expr CoreBndr -> Bool
isDataStructure CoreBndr
id Expr CoreBndr
rhs
  = (CoreBndr
id,  Expr CoreBndr
rhs,  AnalEnv
env) -- Data structure => no code => need to analyse rhs
  | Bool
otherwise
  = (CoreBndr
id', Expr CoreBndr
rhs', AnalEnv
env')
  where
    (CprType
rhs_ty, Expr CoreBndr
rhs')  = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
cprAnal AnalEnv
env Expr CoreBndr
rhs
    -- possibly trim thunk CPR info
    rhs_ty' :: CprType
rhs_ty'
      -- See Note [CPR for thunks]
      | Bool
stays_thunk = CprType -> CprType
trimCprTy CprType
rhs_ty
      -- See Note [CPR for sum types]
      | Bool
returns_sum = CprType -> CprType
trimCprTy CprType
rhs_ty
      | Bool
otherwise   = CprType
rhs_ty
    -- See Note [Arity trimming for CPR signatures]
    sig :: CprSig
sig  = Arity -> CprType -> CprSig
mkCprSigForArity (CoreBndr -> Arity
idArity CoreBndr
id) CprType
rhs_ty'
    id' :: CoreBndr
id'  = CoreBndr -> CprSig -> CoreBndr
setIdCprInfo CoreBndr
id CprSig
sig
    env' :: AnalEnv
env' = AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id CprSig
sig

    -- See Note [CPR for thunks]
    stays_thunk :: Bool
stays_thunk = Bool
is_thunk Bool -> Bool -> Bool
&& Bool
not_strict
    is_thunk :: Bool
is_thunk    = Bool -> Bool
not (Expr CoreBndr -> Bool
exprIsHNF Expr CoreBndr
rhs) Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreBndr -> Bool
isJoinId CoreBndr
id)
    not_strict :: Bool
not_strict  = Bool -> Bool
not (Demand -> Bool
isStrUsedDmd (CoreBndr -> Demand
idDemandInfo CoreBndr
id))
    -- See Note [CPR for sum types]
    ([TyCoBinder]
_, Type
ret_ty) = Type -> ([TyCoBinder], Type)
splitPiTys (CoreBndr -> Type
idType CoreBndr
id)
    not_a_prod :: Bool
not_a_prod  = Maybe DataConPatContext -> Bool
forall a. Maybe a -> Bool
isNothing (FamInstEnvs -> Type -> Maybe DataConPatContext
splitArgType_maybe (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) Type
ret_ty)
    returns_sum :: Bool
returns_sum = Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl) Bool -> Bool -> Bool
&& Bool
not_a_prod

isDataStructure :: Id -> CoreExpr -> Bool
-- See Note [CPR for data structures]
isDataStructure :: CoreBndr -> Expr CoreBndr -> Bool
isDataStructure CoreBndr
id Expr CoreBndr
rhs =
  CoreBndr -> Arity
idArity CoreBndr
id Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0 Bool -> Bool -> Bool
&& Expr CoreBndr -> Bool
exprIsHNF Expr CoreBndr
rhs

-- | Returns an expandable unfolding
-- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has
-- So effectively is a constructor application.
cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr
cprDataStructureUnfolding_maybe :: CoreBndr -> Maybe (Expr CoreBndr)
cprDataStructureUnfolding_maybe CoreBndr
id = do
  -- There are only FinalPhase Simplifier runs after CPR analysis
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Activation -> Bool
activeInFinalPhase (CoreBndr -> Activation
idInlineActivation CoreBndr
id))
  Expr CoreBndr
unf <- Unfolding -> Maybe (Expr CoreBndr)
expandUnfolding_maybe (CoreBndr -> Unfolding
idUnfolding CoreBndr
id)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (CoreBndr -> Expr CoreBndr -> Bool
isDataStructure CoreBndr
id Expr CoreBndr
unf)
  Expr CoreBndr -> Maybe (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
unf

{- Note [Arity trimming for CPR signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Although it doesn't affect correctness of the analysis per se, we have to trim
CPR signatures to idArity. Here's what might happen if we don't:

  f x = if expensive
          then \y. Box y
          else \z. Box z
  g a b = f a b

The two lambdas will have a CPR type of @1m@ (so construct a product after
applied to one argument). Thus, @f@ will have a CPR signature of @2m@
(constructs a product after applied to two arguments).
But WW will never eta-expand @f@! In this case that would amount to possibly
duplicating @expensive@ work.

(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see
Note [Don't eta expand in w/w].)

So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature
from @f@'s, so it *will* be WW'd:

  f x = if expensive
          then \y. Box y
          else \z. Box z
  $wg a b = case f a b of Box x -> x
  g a b = Box ($wg a b)

And the case in @g@ can never cancel away, thus we introduced extra reboxing.
Hence we always trim the CPR signature of a binding to idArity.
-}

data AnalEnv
  = AE
  { AnalEnv -> SigEnv
ae_sigs   :: SigEnv
  -- ^ Current approximation of signatures for local ids
  , AnalEnv -> Bool
ae_virgin :: Bool
  -- ^ True only on every first iteration in a fixed-point
  -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal"
  , AnalEnv -> FamInstEnvs
ae_fam_envs :: FamInstEnvs
  -- ^ Needed when expanding type families and synonyms of product types.
  }

instance Outputable AnalEnv where
  ppr :: AnalEnv -> SDoc
ppr (AE { ae_sigs :: AnalEnv -> SigEnv
ae_sigs = SigEnv
env, ae_virgin :: AnalEnv -> Bool
ae_virgin = Bool
virgin })
    = String -> SDoc
text String
"AE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
         [ String -> SDoc
text String
"ae_virgin =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
virgin
         , String -> SDoc
text String
"ae_sigs =" SDoc -> SDoc -> SDoc
<+> SigEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr SigEnv
env ])

-- | An environment storing 'CprSig's for local Ids.
-- Puts binders with 'topCprSig' in a space-saving 'IntSet'.
-- See Note [Efficient Top sigs in SigEnv].
data SigEnv
  = SE
  { SigEnv -> UnVarSet
se_tops :: !UnVarSet
  -- ^ All these Ids have 'topCprSig'. Like a 'VarSet', but more efficient.
  , SigEnv -> VarEnv CprSig
se_sigs :: !(VarEnv CprSig)
  -- ^ Ids that have something other than 'topCprSig'.
  }

instance Outputable SigEnv where
  ppr :: SigEnv -> SDoc
ppr (SE { se_tops :: SigEnv -> UnVarSet
se_tops = UnVarSet
tops, se_sigs :: SigEnv -> VarEnv CprSig
se_sigs = VarEnv CprSig
sigs })
    = String -> SDoc
text String
"SE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
         [ String -> SDoc
text String
"se_tops =" SDoc -> SDoc -> SDoc
<+> UnVarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnVarSet
tops
         , String -> SDoc
text String
"se_sigs =" SDoc -> SDoc -> SDoc
<+> VarEnv CprSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarEnv CprSig
sigs ])

emptyAnalEnv :: FamInstEnvs -> AnalEnv
emptyAnalEnv :: FamInstEnvs -> AnalEnv
emptyAnalEnv FamInstEnvs
fam_envs
  = AE
  { ae_sigs :: SigEnv
ae_sigs = UnVarSet -> VarEnv CprSig -> SigEnv
SE UnVarSet
emptyUnVarSet VarEnv CprSig
forall a. VarEnv a
emptyVarEnv
  , ae_virgin :: Bool
ae_virgin = Bool
True
  , ae_fam_envs :: FamInstEnvs
ae_fam_envs = FamInstEnvs
fam_envs
  }

modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
modifySigEnv SigEnv -> SigEnv
f AnalEnv
env = AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = SigEnv -> SigEnv
f (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) }

lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig
-- See Note [Efficient Top sigs in SigEnv]
lookupSigEnv :: AnalEnv -> CoreBndr -> Maybe CprSig
lookupSigEnv AE{ae_sigs :: AnalEnv -> SigEnv
ae_sigs = SE UnVarSet
tops VarEnv CprSig
sigs} CoreBndr
id
  | CoreBndr
id CoreBndr -> UnVarSet -> Bool
`elemUnVarSet` UnVarSet
tops = CprSig -> Maybe CprSig
forall a. a -> Maybe a
Just CprSig
topCprSig
  | Bool
otherwise              = VarEnv CprSig -> CoreBndr -> Maybe CprSig
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv VarEnv CprSig
sigs CoreBndr
id

extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv
-- See Note [Efficient Top sigs in SigEnv]
extendSigEnv :: AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id CprSig
sig
  | CprSig -> Bool
isTopCprSig CprSig
sig
  = (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
modifySigEnv (\SigEnv
se -> SigEnv
se{se_tops :: UnVarSet
se_tops = CoreBndr -> UnVarSet -> UnVarSet
extendUnVarSet CoreBndr
id (SigEnv -> UnVarSet
se_tops SigEnv
se)}) AnalEnv
env
  | Bool
otherwise
  = (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
modifySigEnv (\SigEnv
se -> SigEnv
se{se_sigs :: VarEnv CprSig
se_sigs = VarEnv CprSig -> CoreBndr -> CprSig -> VarEnv CprSig
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv (SigEnv -> VarEnv CprSig
se_sigs SigEnv
se) CoreBndr
id CprSig
sig}) AnalEnv
env

-- | Extend an environment with the (Id, CPR sig) pairs
extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv
extendSigEnvList :: AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
extendSigEnvList AnalEnv
env [(CoreBndr, CprSig)]
ids_cprs
  = (AnalEnv -> (CoreBndr, CprSig) -> AnalEnv)
-> AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\AnalEnv
env (CoreBndr
id, CprSig
sig) -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id CprSig
sig) AnalEnv
env [(CoreBndr, CprSig)]
ids_cprs

-- | Extend an environment with the CPR sigs attached to the ids
extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv
extendSigEnvFromIds :: AnalEnv -> [CoreBndr] -> AnalEnv
extendSigEnvFromIds AnalEnv
env [CoreBndr]
ids
  = (AnalEnv -> CoreBndr -> AnalEnv)
-> AnalEnv -> [CoreBndr] -> AnalEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\AnalEnv
env CoreBndr
id -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id (CoreBndr -> CprSig
idCprInfo CoreBndr
id)) AnalEnv
env [CoreBndr]
ids

-- | Extend an environment with the same CPR sig for all ids
extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv
extendSigEnvAllSame :: AnalEnv -> [CoreBndr] -> CprSig -> AnalEnv
extendSigEnvAllSame AnalEnv
env [CoreBndr]
ids CprSig
sig
  = (AnalEnv -> CoreBndr -> AnalEnv)
-> AnalEnv -> [CoreBndr] -> AnalEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\AnalEnv
env CoreBndr
id -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id CprSig
sig) AnalEnv
env [CoreBndr]
ids

nonVirgin :: AnalEnv -> AnalEnv
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin AnalEnv
env = AnalEnv
env { ae_virgin :: Bool
ae_virgin = Bool
False }

-- | A version of 'extendSigEnv' for a binder of which we don't see the RHS
-- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders).
-- In this case, we can still look at their demand to attach CPR signatures
-- anticipating the unboxing done by worker/wrapper.
-- See Note [CPR for binders that will be unboxed].
extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv
extendSigEnvForArg :: AnalEnv -> CoreBndr -> AnalEnv
extendSigEnvForArg AnalEnv
env CoreBndr
id
  = AnalEnv -> CoreBndr -> CprSig -> AnalEnv
extendSigEnv AnalEnv
env CoreBndr
id (CprType -> CprSig
CprSig (AnalEnv -> Type -> Demand -> CprType
argCprType AnalEnv
env (CoreBndr -> Type
idType CoreBndr
id) (CoreBndr -> Demand
idDemandInfo CoreBndr
id)))

-- | Produces a 'CprType' according to how a strict argument will be unboxed.
-- Examples:
--
--   * A head-strict demand @1L@ on @Int@ would translate to @1@
--   * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@
--   * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@,
--     because the unboxing strategy would not unbox the @a@.
argCprType :: AnalEnv -> Type -> Demand -> CprType
argCprType :: AnalEnv -> Type -> Demand -> CprType
argCprType AnalEnv
env Type
arg_ty Demand
dmd = Arity -> Cpr -> CprType
CprType Arity
0 (Type -> Demand -> Cpr
go Type
arg_ty Demand
dmd)
  where
    go :: Type -> Demand -> Cpr
go Type
ty Demand
dmd
      | Unbox (DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: DataConPatContext -> [Type]
dcpc_tc_args = [Type]
tc_args }) [Demand]
ds
          <- FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand
wantToUnbox (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) Bool
no_inlineable_prag Type
ty Demand
dmd
      -- No existentials; see Note [Which types are unboxed?])
      -- Otherwise we'd need to call dataConRepInstPat here and thread a
      -- UniqSupply. So argCprType is a bit less aggressive than it could
      -- be, for the sake of coding convenience.
      , [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [CoreBndr]
dataConExTyCoVars DataCon
dc)
      , let arg_tys :: [Type]
arg_tys = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
dc [Type]
tc_args)
      = Arity -> [Cpr] -> Cpr
ConCpr (DataCon -> Arity
dataConTag DataCon
dc) ((Type -> Demand -> Cpr) -> [Type] -> [Demand] -> [Cpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Demand -> Cpr
go [Type]
arg_tys [Demand]
ds)
      | Bool
otherwise
      = Cpr
topCpr
    -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE
    -- function, we just assume that we aren't. That flag is only relevant
    -- to Note [Do not unpack class dictionaries], the few unboxing
    -- opportunities on dicts it prohibits are probably irrelevant to CPR.
    no_inlineable_prag :: Bool
no_inlineable_prag = Bool
False

{- Note [Safe abortion in the fixed-point iteration]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Fixed-point iteration may fail to terminate. But we cannot simply give up and
return the environment and code unchanged! We still need to do one additional
round, to ensure that all expressions have been traversed at least once, and any
unsound CPR annotations have been updated.

Note [Efficient Top sigs in SigEnv]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's pretty common for binders in the SigEnv to have a 'topCprSig'.
Wide records with 100 fields like in T9675 even will generate code where the
majority of binders has Top signature. To save some allocations, we store
those binders with a Top signature in a separate UnVarSet (which is an IntSet
with a convenient Var-tailored API).

Why store top signatures at all in the SigEnv? After all, when 'cprTransform'
encounters a locally-bound Id without an entry in the SigEnv, it should behave
as if that binder has a Top signature!
Well, the problem is when case binders should have a Top signatures. They always
have an unfolding and thus look to 'cprTransform' as if they bind a data
structure, Note [CPR for data structures], and thus would always have the CPR
property. So we need some mechanism to separate data structures from case
binders with a Top signature, and the UnVarSet provides that in the least
convoluted way I can think of.

Note [CPR for binders that will be unboxed]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a lambda-bound variable will be unboxed by worker/wrapper (so it must be
demanded strictly), then give it a CPR signature. Here's a concrete example
('f1' in test T10482a), assuming h is strict:

  f1 :: Int -> Int
  f1 x = case h x of
          A -> x
          B -> f1 (x-1)
          C -> x+1

If we notice that 'x' is used strictly, we can give it the CPR
property; and hence f1 gets the CPR property too.  It's sound (doesn't
change strictness) to give it the CPR property because by the time 'x'
is returned (case A above), it'll have been evaluated (by the wrapper
of 'h' in the example).

Moreover, if f itself is strict in x, then we'll pass x unboxed to
f1, and so the boxed version *won't* be available; in that case it's
very helpful to give 'x' the CPR property.

This is all done in 'extendSigEnvForArg'.

Note that

  * Whether or not something unboxes is decided by 'wantToUnbox', else we may
    get over-optimistic CPR results (e.g., from \(x :: a) -> x!).

  * If the demand unboxes deeply, we can give the binder a /nested/ CPR
    property, e.g.

      g :: (Int, Int) -> Int
      g p = case p of
        (x, y) | x < 0     -> 0
               | otherwise -> x

    `x` should have the CPR property because it will be unboxed. We do so
    by giving `p` the Nested CPR property `1(1,)`, indicating that we not only
    have `p` available unboxed, but also its field `x`. Analysis of the Case
    will then transfer the CPR property to `x`.

    Before we were able to express Nested CPR, we used to guess which field
    binders should get the CPR property.
    See Historic Note [Optimistic field binder CPR].

  * See Note [CPR examples]

Historic Note [Optimistic field binder CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This Note describes how we used to guess whether fields have the CPR property
before we were able to express Nested CPR for arguments.

Consider

  data T a = MkT a
  f :: T Int -> Int
  f x = ... (case x of
    MkT y -> y) ...

And assume we know from strictness analysis that `f` is strict in `x` and its
field `y` and we unbox both. Then we give `x` the CPR property according
to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y`
likewise will be unboxed and it should also get the CPR property. We'd
need a *nested* CPR property here for `x` to express that and unwrap one level
when we analyse the Case to give the CPR property to `y`.

Lacking Nested CPR, we have to guess a bit, by looking for

  (A) Flat CPR on the scrutinee
  (B) A variable scrutinee. Otherwise surely it can't be a parameter.
  (C) Strict demand on the field binder `y` (or it binds a strict field)

While (A) is a necessary condition to give a field the CPR property, there are
ways in which (B) and (C) are too lax, leading to unsound analysis results and
thus reboxing in the wrapper:

  (b) We could scrutinise some other variable than a parameter, like in

        g :: T Int -> Int
        g x = let z = foo x in -- assume `z` has CPR property
              case z of MkT y -> y

      Lacking Nested CPR and multiple levels of unboxing, only the outer box
      of `z` will be available and a case on `y` won't actually cancel away.
      But it's simple, and nothing terrible happens if we get it wrong. e.g.
      #10694.

  (c) A strictly used field binder doesn't mean the function is strict in it.

        h :: T Int -> Int -> Int
        h !x 0 = 0
        h  x 0 = case x of MkT y -> y

      Here, `y` is used strictly, but the field of `x` certainly is not and
      consequently will not be available unboxed.
      Why not look at the demand of `x` instead to determine whether `y` is
      unboxed? Because the 'idDemandInfo' on `x` will not have been propagated
      to its occurrence in the scrutinee when CprAnal runs directly after
      DmdAnal.

We used to give the case binder the CPR property unconditionally instead of
deriving it from the case scrutinee.
See Historical Note [Optimistic case binder CPR].

Historical Note [Optimistic case binder CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to give the case binder the CPR property unconditionally, which is too
optimistic (#19232). Here are the details:

Inside the alternative, the case binder always has the CPR property, meaning
that a case on it will successfully cancel.
Example:
  f True  x = case x of y { I# x' -> if x' ==# 3
                                     then y
                                     else I# 8 }
  f False x = I# 3
By giving 'y' the CPR property, we ensure that 'f' does too, so we get
  f b x = case fw b x of { r -> I# r }
  fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
  fw False x = 3
Of course there is the usual risk of re-boxing: we have 'x' available boxed
and unboxed, but we return the unboxed version for the wrapper to box. If the
wrapper doesn't cancel with its caller, we'll end up re-boxing something that
we did have available in boxed form.

Note [CPR for sum types]
~~~~~~~~~~~~~~~~~~~~~~~~
At the moment we do not do CPR for let-bindings that
   * non-top level
   * bind a sum type
Reason: I found that in some benchmarks we were losing let-no-escapes,
which messed it all up.  Example
   let j = \x. ....
   in case y of
        True  -> j False
        False -> j True
If we w/w this we get
   let j' = \x. ....
   in case y of
        True  -> case j' False of { (# a #) -> Just a }
        False -> case j' True of { (# a #) -> Just a }
Notice that j' is not a let-no-escape any more.

However this means in turn that the *enclosing* function
may be CPR'd (via the returned Justs).  But in the case of
sums, there may be Nothing alternatives; and that messes
up the sum-type CPR.

Conclusion: only do this for products.  It's still not
guaranteed OK for products, but sums definitely lose sometimes.

Note [CPR for thunks]
~~~~~~~~~~~~~~~~~~~~~
If the rhs is a thunk, we usually forget the CPR info, because
it is presumably shared (else it would have been inlined, and
so we'd lose sharing if w/w'd it into a function).  E.g.

        let r = case expensive of
                  (a,b) -> (b,a)
        in ...

If we marked r as having the CPR property, then we'd w/w into

        let $wr = \() -> case expensive of
                            (a,b) -> (# b, a #)
            r = case $wr () of
                  (# b,a #) -> (b,a)
        in ...

But now r is a thunk, which won't be inlined, so we are no further ahead.
But consider

        f x = let r = case expensive of (a,b) -> (b,a)
              in if foo r then r else (x,x)

Does f have the CPR property?  Well, no.

However, if the strictness analyser has figured out (in a previous
iteration) that it's strict, then we DON'T need to forget the CPR info.
Instead we can retain the CPR info and do the thunk-splitting transform
(see WorkWrap.splitThunk).

This made a big difference to PrelBase.modInt, which had something like
        modInt = \ x -> let r = ... -> I# v in
                        ...body strict in r...
r's RHS isn't a value yet; but modInt returns r in various branches, so
if r doesn't have the CPR property then neither does modInt
Another case I found in practice (in Complex.magnitude), looks like this:
                let k = if ... then I# a else I# b
                in ... body strict in k ....
(For this example, it doesn't matter whether k is returned as part of
the overall result; but it does matter that k's RHS has the CPR property.)
Left to itself, the simplifier will make a join point thus:
                let $j k = ...body strict in k...
                if ... then $j (I# a) else $j (I# b)
With thunk-splitting, we get instead
                let $j x = let k = I#x in ...body strict in k...
                in if ... then $j a else $j b
This is much better; there's a good chance the I# won't get allocated.

But what about botCpr? Consider
    lvl = error "boom"
    fac -1 = lvl
    fac 0 = 1
    fac n = n * fac (n-1)
fac won't have the CPR property here when we trim every thunk! But the
assumption is that error cases are rarely entered and we are diverging anyway,
so WW doesn't hurt.

Should we also trim CPR on DataCon application bindings?
See Note [CPR for data structures]!

Note [CPR for data structures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Long static data structures (whether top-level or not) like

  xs = x1 : xs1
  xs1 = x2 : xs2
  xs2 = x3 : xs3

should not get CPR signatures (#18154), because they

  * Never get WW'd, so their CPR signature should be irrelevant after analysis
    (in fact the signature might even be harmful for that reason)
  * Would need to be inlined/expanded to see their constructed product
  * Recording CPR on them blows up interface file sizes and is redundant with
    their unfolding. In case of Nested CPR, this blow-up can be quadratic!
    Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info
    for xs2 contains that for xs1. And so on.

Hence we don't analyse or annotate data structures in 'cprAnalBind'. To
implement this, the isDataStructure guard is triggered for bindings that satisfy

  (1) idArity id == 0 (otherwise it's a function)
  (2) exprIsHNF rhs   (otherwise it's a thunk, Note [CPR for thunks] applies)

But we can't just stop giving DataCon application bindings the CPR *property*,
for example

  fac 0 = I# 1#
  fac n = n * fac (n-1)

fac certainly has the CPR property and should be WW'd! But FloatOut will
transform the first clause to

  lvl = I# 1#
  fac 0 = lvl

If lvl doesn't have the CPR property, fac won't either. But lvl is a data
structure, and hence (see above) will not have a CPR signature. So instead, when
'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR
transformer, 'cprTransform' instead tries to get its unfolding (via
'cprDataStructureUnfolding_maybe'), and analyses that instead.

In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one
for each data declaration. They should not have CPR signatures (blow up!).

There is a perhaps surprising special case: KindRep bindings satisfy
'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same
time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is
no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll
return topCprType. And that is fine! We should refrain to look through NOINLINE
data structures in general, as a constructed product could never be exposed
after WW.

It's also worth pointing out how ad-hoc this is: If we instead had

    f1 x = x:[]
    f2 x = x : f1 x
    f3 x = x : f2 x
    ...

we still give every function an every deepening CPR signature. But it's very
uncommon to find code like this, whereas the long static data structures from
the beginning of this Note are very common because of GHC's strategy of ANF'ing
data structure RHSs.

Note [CPR examples]
~~~~~~~~~~~~~~~~~~~~
Here are some examples (stranal/should_compile/T10482a) of the
usefulness of Note [Optimistic field binder CPR].  The main
point: all of these functions can have the CPR property.

    ------- f1 -----------
    -- x is used strictly by h, so it'll be available
    -- unboxed before it is returned in the True branch

    f1 :: Int -> Int
    f1 x = case h x x of
            True  -> x
            False -> f1 (x-1)

    ------- f3 -----------
    -- h is strict in x, so x will be unboxed before it
    -- is rerturned in the otherwise case.

    data T3 = MkT3 Int Int

    f1 :: T3 -> Int
    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
                  | otherwise = x
-}