{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998


                        -----------------
                        A demand analysis
                        -----------------
-}

{-# LANGUAGE CPP #-}

module DmdAnal ( dmdAnalProgram ) where

#include "HsVersions.h"

import GhcPrelude

import DynFlags
import WwLib            ( findTypeShape, deepSplitProductType_maybe )
import Demand   -- All of it
import CoreSyn
import CoreSeq          ( seqBinds )
import Outputable
import VarEnv
import BasicTypes
import Data.List
import DataCon
import Id
import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation )
import TyCon
import Type
import Coercion         ( Coercion, coVarsOfCo )
import FamInstEnv
import Util
import Maybes           ( isJust )
import TysWiredIn
import TysPrim          ( realWorldStatePrimTy )
import ErrUtils         ( dumpIfSet_dyn )
import Name             ( getName, stableNameCmp )
import Data.Function    ( on )
import UniqSet

{-
************************************************************************
*                                                                      *
\subsection{Top level stuff}
*                                                                      *
************************************************************************
-}

dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram dflags :: DynFlags
dflags fam_envs :: FamInstEnvs
fam_envs binds :: CoreProgram
binds
  = do {
        let { binds_plus_dmds :: CoreProgram
binds_plus_dmds = CoreProgram -> CoreProgram
do_prog CoreProgram
binds } ;
        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_str_signatures
                      "Strictness signatures" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
            CoreProgram -> SDoc
dumpStrSig CoreProgram
binds_plus_dmds ;
        -- See Note [Stamp out space leaks in demand analysis]
        CoreProgram -> ()
seqBinds CoreProgram
binds_plus_dmds () -> IO CoreProgram -> IO CoreProgram
forall a b. a -> b -> b
`seq` CoreProgram -> IO CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_plus_dmds
    }
  where
    do_prog :: CoreProgram -> CoreProgram
    do_prog :: CoreProgram -> CoreProgram
do_prog binds :: CoreProgram
binds = (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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
dmdAnalTopBind (DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv DynFlags
dflags FamInstEnvs
fam_envs) CoreProgram
binds

-- Analyse a (group of) top-level binding(s)
dmdAnalTopBind :: AnalEnv
               -> CoreBind
               -> (AnalEnv, CoreBind)
dmdAnalTopBind :: AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
dmdAnalTopBind env :: AnalEnv
env (NonRec id :: CoreBndr
id rhs :: Expr CoreBndr
rhs)
  = (TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
TopLevel AnalEnv
env CoreBndr
id2 (CoreBndr -> StrictSig
idStrictness CoreBndr
id2), CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
id2 Expr CoreBndr
rhs2)
  where
    ( _, _,   rhs1 :: Expr CoreBndr
rhs1) = TopLevelFlag
-> Maybe [CoreBndr]
-> AnalEnv
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, CoreBndr, Expr CoreBndr)
dmdAnalRhsLetDown TopLevelFlag
TopLevel Maybe [CoreBndr]
forall a. Maybe a
Nothing AnalEnv
env             CleanDemand
cleanEvalDmd CoreBndr
id Expr CoreBndr
rhs
    ( _, id2 :: CoreBndr
id2, rhs2 :: Expr CoreBndr
rhs2) = TopLevelFlag
-> Maybe [CoreBndr]
-> AnalEnv
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, CoreBndr, Expr CoreBndr)
dmdAnalRhsLetDown TopLevelFlag
TopLevel Maybe [CoreBndr]
forall a. Maybe a
Nothing (AnalEnv -> AnalEnv
nonVirgin AnalEnv
env) CleanDemand
cleanEvalDmd CoreBndr
id Expr CoreBndr
rhs1
        -- Do two passes to improve CPR information
        -- See Note [CPR for thunks]
        -- See Note [Optimistic CPR in the "virgin" case]
        -- See Note [Initial CPR for strict binders]

dmdAnalTopBind env :: AnalEnv
env (Rec pairs :: [(CoreBndr, Expr CoreBndr)]
pairs)
  = (AnalEnv
env', [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
pairs')
  where
    (env' :: AnalEnv
env', _, pairs' :: [(CoreBndr, Expr CoreBndr)]
pairs')  = TopLevelFlag
-> AnalEnv
-> CleanDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix TopLevelFlag
TopLevel AnalEnv
env CleanDemand
cleanEvalDmd [(CoreBndr, Expr CoreBndr)]
pairs
                -- We get two iterations automatically
                -- c.f. the NonRec case above

{- Note [Stamp out space leaks in demand analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The demand analysis pass outputs a new copy of the Core program in
which binders have been annotated with demand and strictness
information. It's tiresome to ensure that this information is fully
evaluated everywhere that we produce it, so we just run a single
seqBinds over the output before returning it, to ensure that there are
no references holding on to the input Core program.

This makes a ~30% reduction in peak memory usage when compiling
DynFlags (cf Trac #9675 and #13426).

This is particularly important when we are doing late demand analysis,
since we don't do a seqBinds at any point thereafter. Hence code
generation would hold on to an extra copy of the Core program, via
unforced thunks in demand or strictness information; and it is the
most memory-intensive part of the compilation process, so this added
seqBinds makes a big difference in peak memory usage.
-}


{-
************************************************************************
*                                                                      *
\subsection{The analyser itself}
*                                                                      *
************************************************************************

Note [Ensure demand is strict]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important not to analyse e with a lazy demand because
a) When we encounter   case s of (a,b) ->
        we demand s with U(d1d2)... but if the overall demand is lazy
        that is wrong, and we'd need to reduce the demand on s,
        which is inconvenient
b) More important, consider
        f (let x = R in x+x), where f is lazy
   We still want to mark x as demanded, because it will be when we
   enter the let.  If we analyse f's arg with a Lazy demand, we'll
   just mark x as Lazy
c) The application rule wouldn't be right either
   Evaluating (f x) in a L demand does *not* cause
   evaluation of f in a C(L) demand!
-}

-- If e is complicated enough to become a thunk, its contents will be evaluated
-- at most once, so oneify it.
dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
dmdTransformThunkDmd :: Expr CoreBndr -> Demand -> Demand
dmdTransformThunkDmd e :: Expr CoreBndr
e
  | Expr CoreBndr -> Bool
exprIsTrivial Expr CoreBndr
e = Demand -> Demand
forall a. a -> a
id
  | Bool
otherwise       = Demand -> Demand
forall s u. JointDmd s (Use u) -> JointDmd s (Use u)
oneifyDmd

-- Do not process absent demands
-- Otherwise act like in a normal demand analysis
-- See ↦* relation in the Cardinality Analysis paper
dmdAnalStar :: AnalEnv
            -> Demand   -- This one takes a *Demand*
            -> CoreExpr -- Should obey the let/app invariatn
            -> (BothDmdArg, CoreExpr)
dmdAnalStar :: AnalEnv -> Demand -> Expr CoreBndr -> (BothDmdArg, Expr CoreBndr)
dmdAnalStar env :: AnalEnv
env dmd :: Demand
dmd e :: Expr CoreBndr
e
  | (dmd_shell :: DmdShell
dmd_shell, cd :: CleanDemand
cd) <- Demand -> (DmdShell, CleanDemand)
toCleanDmd Demand
dmd
  , (dmd_ty :: DmdType
dmd_ty, e' :: Expr CoreBndr
e')    <- AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
cd Expr CoreBndr
e
  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
    -- The argument 'e' should satisfy the let/app invariant
    -- See Note [Analysing with absent demand] in Demand.hs
    (DmdShell -> DmdType -> BothDmdArg
postProcessDmdType DmdShell
dmd_shell DmdType
dmd_ty, Expr CoreBndr
e')

-- Main Demand Analsysis machinery
dmdAnal, dmdAnal' :: AnalEnv
        -> CleanDemand         -- The main one takes a *CleanDemand*
        -> CoreExpr -> (DmdType, CoreExpr)

-- The CleanDemand is always strict and not absent
--    See Note [Ensure demand is strict]

dmdAnal :: AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal env :: AnalEnv
env d :: CleanDemand
d e :: Expr CoreBndr
e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
                  AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal' AnalEnv
env CleanDemand
d Expr CoreBndr
e

dmdAnal' :: AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal' _ _ (Lit lit :: Literal
lit)     = (DmdType
nopDmdType, Literal -> Expr CoreBndr
forall b. Literal -> Expr b
Lit Literal
lit)
dmdAnal' _ _ (Type ty :: Type
ty)     = (DmdType
nopDmdType, Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
ty)      -- Doesn't happen, in fact
dmdAnal' _ _ (Coercion co :: Coercion
co)
  = (DmdEnv -> DmdType
unitDmdType (Coercion -> DmdEnv
coercionDmdEnv Coercion
co), Coercion -> Expr CoreBndr
forall b. Coercion -> Expr b
Coercion Coercion
co)

dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Var var :: CoreBndr
var)
  = (AnalEnv -> CoreBndr -> CleanDemand -> DmdType
dmdTransform AnalEnv
env CoreBndr
var CleanDemand
dmd, CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
var)

dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Cast e :: Expr CoreBndr
e co :: Coercion
co)
  = (DmdType
dmd_ty DmdType -> BothDmdArg -> DmdType
`bothDmdType` DmdEnv -> BothDmdArg
mkBothDmdArg (Coercion -> DmdEnv
coercionDmdEnv Coercion
co), Expr CoreBndr -> Coercion -> Expr CoreBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr CoreBndr
e' Coercion
co)
  where
    (dmd_ty :: DmdType
dmd_ty, e' :: Expr CoreBndr
e') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
e

dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Tick t :: Tickish CoreBndr
t e :: Expr CoreBndr
e)
  = (DmdType
dmd_ty, Tickish CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick Tickish CoreBndr
t Expr CoreBndr
e')
  where
    (dmd_ty :: DmdType
dmd_ty, e' :: Expr CoreBndr
e') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
e

dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (App fun :: Expr CoreBndr
fun (Type ty :: Type
ty))
  = (DmdType
fun_ty, Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
fun' (Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
ty))
  where
    (fun_ty :: DmdType
fun_ty, fun' :: Expr CoreBndr
fun') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
fun

-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (App fun :: Expr CoreBndr
fun arg :: Expr CoreBndr
arg)
  = -- This case handles value arguments (type args handled above)
    -- Crucially, coercions /are/ handled here, because they are
    -- value arguments (Trac #10288)
    let
        call_dmd :: CleanDemand
call_dmd          = CleanDemand -> CleanDemand
mkCallDmd CleanDemand
dmd
        (fun_ty :: DmdType
fun_ty, fun' :: Expr CoreBndr
fun')    = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
call_dmd Expr CoreBndr
fun
        (arg_dmd :: Demand
arg_dmd, res_ty :: DmdType
res_ty) = DmdType -> (Demand, DmdType)
splitDmdTy DmdType
fun_ty
        (arg_ty :: BothDmdArg
arg_ty, arg' :: Expr CoreBndr
arg')    = AnalEnv -> Demand -> Expr CoreBndr -> (BothDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env (Expr CoreBndr -> Demand -> Demand
dmdTransformThunkDmd Expr CoreBndr
arg Demand
arg_dmd) Expr CoreBndr
arg
    in
--    pprTrace "dmdAnal:app" (vcat
--         [ text "dmd =" <+> ppr dmd
--         , text "expr =" <+> ppr (App fun arg)
--         , text "fun dmd_ty =" <+> ppr fun_ty
--         , text "arg dmd =" <+> ppr arg_dmd
--         , text "arg dmd_ty =" <+> ppr arg_ty
--         , text "res dmd_ty =" <+> ppr res_ty
--         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
    (DmdType
res_ty DmdType -> BothDmdArg -> DmdType
`bothDmdType` BothDmdArg
arg_ty, Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
fun' Expr CoreBndr
arg')

-- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@
dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Lam var :: CoreBndr
var body :: Expr CoreBndr
body)
  | CoreBndr -> Bool
isTyVar CoreBndr
var
  = let
        (body_ty :: DmdType
body_ty, body' :: Expr CoreBndr
body') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
body
    in
    (DmdType
body_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var Expr CoreBndr
body')

  | Bool
otherwise
  = let (body_dmd :: CleanDemand
body_dmd, defer_and_use :: DmdShell
defer_and_use) = CleanDemand -> (CleanDemand, DmdShell)
peelCallDmd CleanDemand
dmd
          -- body_dmd: a demand to analyze the body

        env' :: AnalEnv
env'             = AnalEnv -> CoreBndr -> AnalEnv
extendSigsWithLam AnalEnv
env CoreBndr
var
        (body_ty :: DmdType
body_ty, body' :: Expr CoreBndr
body') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env' CleanDemand
body_dmd Expr CoreBndr
body
        (lam_ty :: DmdType
lam_ty, var' :: CoreBndr
var')   = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateLamIdBndr AnalEnv
env Bool
notArgOfDfun DmdType
body_ty CoreBndr
var
    in
    (DmdShell -> DmdType -> DmdType
postProcessUnsat DmdShell
defer_and_use DmdType
lam_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var' Expr CoreBndr
body')

dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Case scrut :: Expr CoreBndr
scrut case_bndr :: CoreBndr
case_bndr ty :: Type
ty [(DataAlt dc :: DataCon
dc, bndrs :: [CoreBndr]
bndrs, rhs :: Expr CoreBndr
rhs)])
  -- Only one alternative with a product constructor
  | let tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
dc
  , Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (TyCon -> Maybe DataCon
isDataProductTyCon_maybe TyCon
tycon)
  , Just rec_tc' :: RecTcChecker
rec_tc' <- RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc (AnalEnv -> RecTcChecker
ae_rec_tc AnalEnv
env) TyCon
tycon
  = let
        env_w_tc :: AnalEnv
env_w_tc                 = AnalEnv
env { ae_rec_tc :: RecTcChecker
ae_rec_tc = RecTcChecker
rec_tc' }
        env_alt :: AnalEnv
env_alt                  = AnalEnv
-> Expr CoreBndr -> CoreBndr -> DataCon -> [CoreBndr] -> AnalEnv
extendEnvForProdAlt AnalEnv
env_w_tc Expr CoreBndr
scrut CoreBndr
case_bndr DataCon
dc [CoreBndr]
bndrs
        (rhs_ty :: DmdType
rhs_ty, rhs' :: Expr CoreBndr
rhs')           = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env_alt CleanDemand
dmd Expr CoreBndr
rhs
        (alt_ty1 :: DmdType
alt_ty1, dmds :: [Demand]
dmds)          = AnalEnv -> DmdType -> [CoreBndr] -> (DmdType, [Demand])
findBndrsDmds AnalEnv
env DmdType
rhs_ty [CoreBndr]
bndrs
        (alt_ty2 :: DmdType
alt_ty2, case_bndr_dmd :: Demand
case_bndr_dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
False DmdType
alt_ty1 CoreBndr
case_bndr
        id_dmds :: [Demand]
id_dmds                  = Demand -> [Demand] -> [Demand]
addCaseBndrDmd Demand
case_bndr_dmd [Demand]
dmds
        alt_ty3 :: DmdType
alt_ty3 | Expr CoreBndr -> DataCon -> [CoreBndr] -> Bool
io_hack_reqd Expr CoreBndr
scrut DataCon
dc [CoreBndr]
bndrs = DmdType -> DmdType
deferAfterIO DmdType
alt_ty2
                | Bool
otherwise                   = DmdType
alt_ty2

        -- Compute demand on the scrutinee
        -- See Note [Demand on scrutinee of a product case]
        scrut_dmd :: CleanDemand
scrut_dmd          = [Demand] -> CleanDemand
mkProdDmd [Demand]
id_dmds
        (scrut_ty :: DmdType
scrut_ty, scrut' :: Expr CoreBndr
scrut') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
scrut_dmd Expr CoreBndr
scrut
        res_ty :: DmdType
res_ty             = DmdType
alt_ty3 DmdType -> BothDmdArg -> DmdType
`bothDmdType` DmdType -> BothDmdArg
toBothDmdArg DmdType
scrut_ty
        case_bndr' :: CoreBndr
case_bndr'         = CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
case_bndr Demand
case_bndr_dmd
        bndrs' :: [CoreBndr]
bndrs'             = [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bndrs [Demand]
id_dmds
    in
--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
--                                   , text "dmd" <+> ppr dmd
--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
--                                   , text "id_dmds" <+> ppr id_dmds
--                                   , text "scrut_dmd" <+> ppr scrut_dmd
--                                   , text "scrut_ty" <+> ppr scrut_ty
--                                   , text "alt_ty" <+> ppr alt_ty2
--                                   , text "res_ty" <+> ppr res_ty ]) $
    (DmdType
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 [(DataCon -> AltCon
DataAlt DataCon
dc, [CoreBndr]
bndrs', Expr CoreBndr
rhs')])

dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Case scrut :: Expr CoreBndr
scrut case_bndr :: CoreBndr
case_bndr ty :: Type
ty alts :: [Alt CoreBndr]
alts)
  = let      -- Case expression with multiple alternatives
        (alt_tys :: [DmdType]
alt_tys, alts' :: [Alt CoreBndr]
alts')     = (Alt CoreBndr -> (DmdType, Alt CoreBndr))
-> [Alt CoreBndr] -> ([DmdType], [Alt CoreBndr])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (AnalEnv
-> CleanDemand
-> CoreBndr
-> Alt CoreBndr
-> (DmdType, Alt CoreBndr)
dmdAnalAlt AnalEnv
env CleanDemand
dmd CoreBndr
case_bndr) [Alt CoreBndr]
alts
        (scrut_ty :: DmdType
scrut_ty, scrut' :: Expr CoreBndr
scrut')   = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
cleanEvalDmd Expr CoreBndr
scrut
        (alt_ty :: DmdType
alt_ty, case_bndr' :: CoreBndr
case_bndr') = AnalEnv -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateBndr AnalEnv
env ((DmdType -> DmdType -> DmdType) -> DmdType -> [DmdType] -> DmdType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DmdType -> DmdType -> DmdType
lubDmdType DmdType
botDmdType [DmdType]
alt_tys) CoreBndr
case_bndr
                               -- NB: Base case is botDmdType, for empty case alternatives
                               --     This is a unit for lubDmdType, and the right result
                               --     when there really are no alternatives
        res_ty :: DmdType
res_ty               = DmdType
alt_ty DmdType -> BothDmdArg -> DmdType
`bothDmdType` DmdType -> BothDmdArg
toBothDmdArg DmdType
scrut_ty
    in
--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
--                                   , text "scrut_ty" <+> ppr scrut_ty
--                                   , text "alt_tys" <+> ppr alt_tys
--                                   , text "alt_ty" <+> ppr alt_ty
--                                   , text "res_ty" <+> ppr res_ty ]) $
    (DmdType
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')

-- Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
-- The following case handle the up variant.
--
-- It is very simple. For  let x = rhs in body
--   * Demand-analyse 'body' in the current environment
--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
--   * Demand-analyse 'rhs' in 'rhs_dmd'
--
-- This is used for a non-recursive local let without manifest lambdas.
-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Let (NonRec id :: CoreBndr
id rhs :: Expr CoreBndr
rhs) body :: Expr CoreBndr
body)
  | CoreBndr -> Expr CoreBndr -> Bool
useLetUp CoreBndr
id Expr CoreBndr
rhs
  , Maybe CoreBndr
Nothing <- Expr CoreBndr -> Maybe CoreBndr
unpackTrivial Expr CoreBndr
rhs
      -- dmdAnalRhsLetDown treats trivial right hand sides specially
      -- so if we have a trival right hand side, fall through to that.
  = (DmdType
final_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
    (body_ty :: DmdType
body_ty, body' :: Expr CoreBndr
body')   = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
body
    (body_ty' :: DmdType
body_ty', id_dmd :: Demand
id_dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
notArgOfDfun DmdType
body_ty CoreBndr
id
    id' :: CoreBndr
id'                = CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
id Demand
id_dmd

    (rhs_ty :: BothDmdArg
rhs_ty, rhs' :: Expr CoreBndr
rhs')     = AnalEnv -> Demand -> Expr CoreBndr -> (BothDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env (Expr CoreBndr -> Demand -> Demand
dmdTransformThunkDmd Expr CoreBndr
rhs Demand
id_dmd) Expr CoreBndr
rhs
    final_ty :: DmdType
final_ty           = DmdType
body_ty' DmdType -> BothDmdArg -> DmdType
`bothDmdType` BothDmdArg
rhs_ty

dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Let (NonRec id :: CoreBndr
id rhs :: Expr CoreBndr
rhs) body :: Expr CoreBndr
body)
  = (DmdType
body_ty2, 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
id2 Expr CoreBndr
rhs') Expr CoreBndr
body')
  where
    (lazy_fv :: DmdEnv
lazy_fv, id1 :: CoreBndr
id1, rhs' :: Expr CoreBndr
rhs') = TopLevelFlag
-> Maybe [CoreBndr]
-> AnalEnv
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, CoreBndr, Expr CoreBndr)
dmdAnalRhsLetDown TopLevelFlag
NotTopLevel Maybe [CoreBndr]
forall a. Maybe a
Nothing AnalEnv
env CleanDemand
dmd CoreBndr
id Expr CoreBndr
rhs
    env1 :: AnalEnv
env1                 = TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
NotTopLevel AnalEnv
env CoreBndr
id1 (CoreBndr -> StrictSig
idStrictness CoreBndr
id1)
    (body_ty :: DmdType
body_ty, body' :: Expr CoreBndr
body')     = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env1 CleanDemand
dmd Expr CoreBndr
body
    (body_ty1 :: DmdType
body_ty1, id2 :: CoreBndr
id2)      = AnalEnv -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateBndr AnalEnv
env DmdType
body_ty CoreBndr
id1
    body_ty2 :: DmdType
body_ty2             = DmdType -> DmdEnv -> DmdType
addLazyFVs DmdType
body_ty1 DmdEnv
lazy_fv -- see Note [Lazy and unleashable free variables]

        -- If the actual demand is better than the vanilla call
        -- demand, you might think that we might do better to re-analyse
        -- the RHS with the stronger demand.
        -- But (a) That seldom happens, because it means that *every* path in
        --         the body of the let has to use that stronger demand
        -- (b) It often happens temporarily in when fixpointing, because
        --     the recursive function at first seems to place a massive demand.
        --     But we don't want to go to extra work when the function will
        --     probably iterate to something less demanding.
        -- In practice, all the times the actual demand on id2 is more than
        -- the vanilla call demand seem to be due to (b).  So we don't
        -- bother to re-analyse the RHS.

dmdAnal' env :: AnalEnv
env dmd :: CleanDemand
dmd (Let (Rec pairs :: [(CoreBndr, Expr CoreBndr)]
pairs) body :: Expr CoreBndr
body)
  = let
        (env' :: AnalEnv
env', lazy_fv :: DmdEnv
lazy_fv, pairs' :: [(CoreBndr, Expr CoreBndr)]
pairs') = TopLevelFlag
-> AnalEnv
-> CleanDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix TopLevelFlag
NotTopLevel AnalEnv
env CleanDemand
dmd [(CoreBndr, Expr CoreBndr)]
pairs
        (body_ty :: DmdType
body_ty, body' :: Expr CoreBndr
body')        = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env' CleanDemand
dmd Expr CoreBndr
body
        body_ty1 :: DmdType
body_ty1                = DmdType -> [CoreBndr] -> DmdType
deleteFVs DmdType
body_ty (((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)]
pairs)
        body_ty2 :: DmdType
body_ty2                = DmdType -> DmdEnv -> DmdType
addLazyFVs DmdType
body_ty1 DmdEnv
lazy_fv -- see Note [Lazy and unleashable free variables]
    in
    DmdType
body_ty2 DmdType -> (DmdType, Expr CoreBndr) -> (DmdType, Expr CoreBndr)
forall a b. a -> b -> b
`seq`
    (DmdType
body_ty2,  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')

io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool
-- See Note [IO hack in the demand analyser]
io_hack_reqd :: Expr CoreBndr -> DataCon -> [CoreBndr] -> Bool
io_hack_reqd scrut :: Expr CoreBndr
scrut con :: DataCon
con bndrs :: [CoreBndr]
bndrs
  | (bndr :: CoreBndr
bndr:_) <- [CoreBndr]
bndrs
  , DataCon
con DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed 2
  , CoreBndr -> Type
idType CoreBndr
bndr Type -> Type -> Bool
`eqType` Type
realWorldStatePrimTy
  , (fun :: Expr CoreBndr
fun, _) <- Expr CoreBndr -> (Expr CoreBndr, [Expr CoreBndr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr CoreBndr
scrut
  = case Expr CoreBndr
fun of
      Var f :: CoreBndr
f -> Bool -> Bool
not (CoreBndr -> Bool
isPrimOpId CoreBndr
f)
      _     -> Bool
True
  | Bool
otherwise
  = Bool
False

dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)
dmdAnalAlt :: AnalEnv
-> CleanDemand
-> CoreBndr
-> Alt CoreBndr
-> (DmdType, Alt CoreBndr)
dmdAnalAlt env :: AnalEnv
env dmd :: CleanDemand
dmd case_bndr :: CoreBndr
case_bndr (con :: AltCon
con,bndrs :: [CoreBndr]
bndrs,rhs :: Expr CoreBndr
rhs)
  | [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
bndrs    -- Literals, DEFAULT, and nullary constructors
  , (rhs_ty :: DmdType
rhs_ty, rhs' :: Expr CoreBndr
rhs') <- AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
rhs
  = (DmdType
rhs_ty, (AltCon
con, [], Expr CoreBndr
rhs'))

  | Bool
otherwise     -- Non-nullary data constructors
  , (rhs_ty :: DmdType
rhs_ty, rhs' :: Expr CoreBndr
rhs') <- AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env CleanDemand
dmd Expr CoreBndr
rhs
  , (alt_ty :: DmdType
alt_ty, dmds :: [Demand]
dmds) <- AnalEnv -> DmdType -> [CoreBndr] -> (DmdType, [Demand])
findBndrsDmds AnalEnv
env DmdType
rhs_ty [CoreBndr]
bndrs
  , let case_bndr_dmd :: Demand
case_bndr_dmd = DmdType -> CoreBndr -> Demand
findIdDemand DmdType
alt_ty CoreBndr
case_bndr
        id_dmds :: [Demand]
id_dmds       = Demand -> [Demand] -> [Demand]
addCaseBndrDmd Demand
case_bndr_dmd [Demand]
dmds
  = (DmdType
alt_ty, (AltCon
con, [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bndrs [Demand]
id_dmds, Expr CoreBndr
rhs'))


{- Note [IO hack in the demand analyser]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There's a hack here for I/O operations.  Consider

     case foo x s of { (# s', r #) -> y }

Is this strict in 'y'? Often not! If foo x s performs some observable action
(including raising an exception with raiseIO#, modifying a mutable variable, or
even ending the program normally), then we must not force 'y' (which may fail
to terminate) until we have performed foo x s.

Hackish solution: spot the IO-like situation and add a virtual branch,
as if we had
     case foo x s of
        (# s, r #) -> y
        other      -> return ()
So the 'y' isn't necessarily going to be evaluated

A more complete example (Trac #148, #1592) where this shows up is:
     do { let len = <expensive> ;
        ; when (...) (exitWith ExitSuccess)
        ; print len }

However, consider
  f x s = case getMaskingState# s of
            (# s, r #) ->
          case x of I# x2 -> ...

Here it is terribly sad to make 'f' lazy in 's'.  After all,
getMaskingState# is not going to diverge or throw an exception!  This
situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle
(on an MVar not an Int), and made a material difference.

So if the scrutinee is a primop call, we *don't* apply the
state hack:
  - If it is a simple, terminating one like getMaskingState,
    applying the hack is over-conservative.
  - If the primop is raise# then it returns bottom, so
    the case alternatives are already discarded.
  - If the primop can raise a non-IO exception, like
    divide by zero or seg-fault (eg writing an array
    out of bounds) then we don't mind evaluating 'x' first.

Note [Demand on the scrutinee of a product case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When figuring out the demand on the scrutinee of a product case,
we use the demands of the case alternative, i.e. id_dmds.
But note that these include the demand on the case binder;
see Note [Demand on case-alternative binders] in Demand.hs.
This is crucial. Example:
   f x = case x of y { (a,b) -> k y a }
If we just take scrut_demand = U(L,A), then we won't pass x to the
worker, so the worker will rebuild
     x = (a, absent-error)
and that'll crash.

Note [Aggregated demand for cardinality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use different strategies for strictness and usage/cardinality to
"unleash" demands captured on free variables by bindings. Let us
consider the example:

f1 y = let {-# NOINLINE h #-}
           h = y
       in  (h, h)

We are interested in obtaining cardinality demand U1 on |y|, as it is
used only in a thunk, and, therefore, is not going to be updated any
more. Therefore, the demand on |y|, captured and unleashed by usage of
|h| is U1. However, if we unleash this demand every time |h| is used,
and then sum up the effects, the ultimate demand on |y| will be U1 +
U1 = U. In order to avoid it, we *first* collect the aggregate demand
on |h| in the body of let-expression, and only then apply the demand
transformer:

transf[x](U) = {y |-> U1}

so the resulting demand on |y| is U1.

The situation is, however, different for strictness, where this
aggregating approach exhibits worse results because of the nature of
|both| operation for strictness. Consider the example:

f y c =
  let h x = y |seq| x
   in case of
        True  -> h True
        False -> y

It is clear that |f| is strict in |y|, however, the suggested analysis
will infer from the body of |let| that |h| is used lazily (as it is
used in one branch only), therefore lazy demand will be put on its
free variable |y|. Conversely, if the demand on |h| is unleashed right
on the spot, we will get the desired result, namely, that |f| is
strict in |y|.


************************************************************************
*                                                                      *
                    Demand transformer
*                                                                      *
************************************************************************
-}

dmdTransform :: AnalEnv         -- The strictness environment
             -> Id              -- The function
             -> CleanDemand     -- The demand on the function
             -> DmdType         -- The demand type of the function in this context
        -- Returned DmdEnv includes the demand on
        -- this function plus demand on its free variables

dmdTransform :: AnalEnv -> CoreBndr -> CleanDemand -> DmdType
dmdTransform env :: AnalEnv
env var :: CoreBndr
var dmd :: CleanDemand
dmd
  | CoreBndr -> Bool
isDataConWorkId CoreBndr
var                          -- Data constructor
  = Int -> StrictSig -> CleanDemand -> DmdType
dmdTransformDataConSig (CoreBndr -> Int
idArity CoreBndr
var) (CoreBndr -> StrictSig
idStrictness CoreBndr
var) CleanDemand
dmd

  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DmdTxDictSel (AnalEnv -> DynFlags
ae_dflags AnalEnv
env),
    Just _ <- CoreBndr -> Maybe Class
isClassOpId_maybe CoreBndr
var -- Dictionary component selector
  = StrictSig -> CleanDemand -> DmdType
dmdTransformDictSelSig (CoreBndr -> StrictSig
idStrictness CoreBndr
var) CleanDemand
dmd

  | CoreBndr -> Bool
isGlobalId CoreBndr
var                               -- Imported function
  = let res :: DmdType
res = StrictSig -> CleanDemand -> DmdType
dmdTransformSig (CoreBndr -> StrictSig
idStrictness CoreBndr
var) CleanDemand
dmd in
--    pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
    DmdType
res

  | Just (sig :: StrictSig
sig, top_lvl :: TopLevelFlag
top_lvl) <- AnalEnv -> CoreBndr -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv AnalEnv
env CoreBndr
var  -- Local letrec bound thing
  , let fn_ty :: DmdType
fn_ty = StrictSig -> CleanDemand -> DmdType
dmdTransformSig StrictSig
sig CleanDemand
dmd
  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
    if TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
    then DmdType
fn_ty   -- Don't record top level things
    else DmdType -> CoreBndr -> Demand -> DmdType
addVarDmd DmdType
fn_ty CoreBndr
var (CleanDemand -> Demand
mkOnceUsedDmd CleanDemand
dmd)

  | Bool
otherwise                                    -- Local non-letrec-bound thing
  = DmdEnv -> DmdType
unitDmdType (CoreBndr -> Demand -> DmdEnv
forall a. CoreBndr -> a -> VarEnv a
unitVarEnv CoreBndr
var (CleanDemand -> Demand
mkOnceUsedDmd CleanDemand
dmd))

{-
************************************************************************
*                                                                      *
\subsection{Bindings}
*                                                                      *
************************************************************************
-}

-- Recursive bindings
dmdFix :: TopLevelFlag
       -> AnalEnv                            -- Does not include bindings for this binding
       -> CleanDemand
       -> [(Id,CoreExpr)]
       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info

dmdFix :: TopLevelFlag
-> AnalEnv
-> CleanDemand
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
dmdFix top_lvl :: TopLevelFlag
top_lvl env :: AnalEnv
env let_dmd :: CleanDemand
let_dmd orig_pairs :: [(CoreBndr, Expr CoreBndr)]
orig_pairs
  = Int
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
loop 1 [(CoreBndr, Expr CoreBndr)]
initial_pairs
  where
    bndrs :: [CoreBndr]
bndrs = ((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)]
orig_pairs

    -- See Note [Initialising strictness]
    initial_pairs :: [(CoreBndr, Expr CoreBndr)]
initial_pairs | AnalEnv -> Bool
ae_virgin AnalEnv
env = [(CoreBndr -> StrictSig -> CoreBndr
setIdStrictness CoreBndr
id StrictSig
botSig, Expr CoreBndr
rhs) | (id :: CoreBndr
id, rhs :: Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
orig_pairs ]
                  | Bool
otherwise     = [(CoreBndr, Expr CoreBndr)]
orig_pairs

    -- If fixed-point iteration does not yield a result we use this instead
    -- See Note [Safe abortion in the fixed-point iteration]
    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
    abort :: (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
abort = (AnalEnv
env, DmdEnv
lazy_fv', [(CoreBndr, Expr CoreBndr)]
zapped_pairs)
      where (lazy_fv :: DmdEnv
lazy_fv, pairs' :: [(CoreBndr, Expr CoreBndr)]
pairs') = Bool
-> [(CoreBndr, Expr CoreBndr)]
-> (DmdEnv, [(CoreBndr, Expr CoreBndr)])
step Bool
True ([(CoreBndr, Expr CoreBndr)] -> [(CoreBndr, Expr CoreBndr)]
zapIdStrictness [(CoreBndr, Expr CoreBndr)]
orig_pairs)
            -- Note [Lazy and unleashable free variables]
            non_lazy_fvs :: DmdEnv
non_lazy_fvs = [DmdEnv] -> DmdEnv
forall a. [VarEnv a] -> VarEnv a
plusVarEnvList ([DmdEnv] -> DmdEnv) -> [DmdEnv] -> DmdEnv
forall a b. (a -> b) -> a -> b
$ ((CoreBndr, Expr CoreBndr) -> DmdEnv)
-> [(CoreBndr, Expr CoreBndr)] -> [DmdEnv]
forall a b. (a -> b) -> [a] -> [b]
map (StrictSig -> DmdEnv
strictSigDmdEnv (StrictSig -> DmdEnv)
-> ((CoreBndr, Expr CoreBndr) -> StrictSig)
-> (CoreBndr, Expr CoreBndr)
-> DmdEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> StrictSig
idStrictness (CoreBndr -> StrictSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> StrictSig
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'
            lazy_fv' :: DmdEnv
lazy_fv'     = DmdEnv
lazy_fv DmdEnv -> DmdEnv -> DmdEnv
forall a. VarEnv a -> VarEnv a -> VarEnv a
`plusVarEnv` (Demand -> Demand) -> DmdEnv -> DmdEnv
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (Demand -> Demand -> Demand
forall a b. a -> b -> a
const Demand
topDmd) DmdEnv
non_lazy_fvs
            zapped_pairs :: [(CoreBndr, Expr CoreBndr)]
zapped_pairs = [(CoreBndr, Expr CoreBndr)] -> [(CoreBndr, Expr CoreBndr)]
zapIdStrictness [(CoreBndr, Expr CoreBndr)]
pairs'

    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
    -- annotation does not change any more.
    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
    loop :: Int
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
loop n :: Int
n pairs :: [(CoreBndr, Expr CoreBndr)]
pairs
      | Bool
found_fixpoint = (AnalEnv
final_anal_env, DmdEnv
lazy_fv, [(CoreBndr, Expr CoreBndr)]
pairs')
      | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 10        = (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
abort
      | Bool
otherwise      = Int
-> [(CoreBndr, Expr CoreBndr)]
-> (AnalEnv, DmdEnv, [(CoreBndr, Expr CoreBndr)])
loop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) [(CoreBndr, Expr CoreBndr)]
pairs'
      where
        found_fixpoint :: Bool
found_fixpoint    = ((CoreBndr, Expr CoreBndr) -> StrictSig)
-> [(CoreBndr, Expr CoreBndr)] -> [StrictSig]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> StrictSig
idStrictness (CoreBndr -> StrictSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> StrictSig
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' [StrictSig] -> [StrictSig] -> Bool
forall a. Eq a => a -> a -> Bool
== ((CoreBndr, Expr CoreBndr) -> StrictSig)
-> [(CoreBndr, Expr CoreBndr)] -> [StrictSig]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> StrictSig
idStrictness (CoreBndr -> StrictSig)
-> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> (CoreBndr, Expr CoreBndr)
-> StrictSig
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
        first_round :: Bool
first_round       = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
        (lazy_fv :: DmdEnv
lazy_fv, pairs' :: [(CoreBndr, Expr CoreBndr)]
pairs') = Bool
-> [(CoreBndr, Expr CoreBndr)]
-> (DmdEnv, [(CoreBndr, Expr CoreBndr)])
step Bool
first_round [(CoreBndr, Expr CoreBndr)]
pairs
        final_anal_env :: AnalEnv
final_anal_env    = TopLevelFlag -> AnalEnv -> [CoreBndr] -> AnalEnv
extendAnalEnvs TopLevelFlag
top_lvl AnalEnv
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)]
pairs')

    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
    step :: Bool
-> [(CoreBndr, Expr CoreBndr)]
-> (DmdEnv, [(CoreBndr, Expr CoreBndr)])
step first_round :: Bool
first_round pairs :: [(CoreBndr, Expr CoreBndr)]
pairs = (DmdEnv
lazy_fv, [(CoreBndr, Expr CoreBndr)]
pairs')
      where
        -- In all but the first iteration, delete the virgin flag
        start_env :: AnalEnv
start_env | Bool
first_round = AnalEnv
env
                  | Bool
otherwise   = AnalEnv -> AnalEnv
nonVirgin AnalEnv
env

        start :: (AnalEnv, DmdEnv)
start = (TopLevelFlag -> AnalEnv -> [CoreBndr] -> AnalEnv
extendAnalEnvs TopLevelFlag
top_lvl AnalEnv
start_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)]
pairs), DmdEnv
emptyDmdEnv)

        ((_,lazy_fv :: DmdEnv
lazy_fv), pairs' :: [(CoreBndr, Expr CoreBndr)]
pairs') = ((AnalEnv, DmdEnv)
 -> (CoreBndr, Expr CoreBndr)
 -> ((AnalEnv, DmdEnv), (CoreBndr, Expr CoreBndr)))
-> (AnalEnv, DmdEnv)
-> [(CoreBndr, Expr CoreBndr)]
-> ((AnalEnv, DmdEnv), [(CoreBndr, Expr CoreBndr)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (AnalEnv, DmdEnv)
-> (CoreBndr, Expr CoreBndr)
-> ((AnalEnv, DmdEnv), (CoreBndr, Expr CoreBndr))
my_downRhs (AnalEnv, DmdEnv)
start [(CoreBndr, Expr CoreBndr)]
pairs
                -- mapAccumL: Use the new signature to do the next pair
                -- The occurrence analyser has arranged them in a good order
                -- so this can significantly reduce the number of iterations needed

        my_downRhs :: (AnalEnv, DmdEnv)
-> (CoreBndr, Expr CoreBndr)
-> ((AnalEnv, DmdEnv), (CoreBndr, Expr CoreBndr))
my_downRhs (env :: AnalEnv
env, lazy_fv :: DmdEnv
lazy_fv) (id :: CoreBndr
id,rhs :: Expr CoreBndr
rhs)
          = ((AnalEnv
env', DmdEnv
lazy_fv'), (CoreBndr
id', Expr CoreBndr
rhs'))
          where
            (lazy_fv1 :: DmdEnv
lazy_fv1, id' :: CoreBndr
id', rhs' :: Expr CoreBndr
rhs') = TopLevelFlag
-> Maybe [CoreBndr]
-> AnalEnv
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, CoreBndr, Expr CoreBndr)
dmdAnalRhsLetDown TopLevelFlag
top_lvl ([CoreBndr] -> Maybe [CoreBndr]
forall a. a -> Maybe a
Just [CoreBndr]
bndrs) AnalEnv
env CleanDemand
let_dmd CoreBndr
id Expr CoreBndr
rhs
            lazy_fv' :: DmdEnv
lazy_fv'              = (Demand -> Demand -> Demand) -> DmdEnv -> DmdEnv -> DmdEnv
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C Demand -> Demand -> Demand
bothDmd DmdEnv
lazy_fv DmdEnv
lazy_fv1
            env' :: AnalEnv
env'                  = TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
top_lvl AnalEnv
env CoreBndr
id (CoreBndr -> StrictSig
idStrictness CoreBndr
id')


    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
    zapIdStrictness :: [(CoreBndr, Expr CoreBndr)] -> [(CoreBndr, Expr CoreBndr)]
zapIdStrictness pairs :: [(CoreBndr, Expr CoreBndr)]
pairs = [(CoreBndr -> StrictSig -> CoreBndr
setIdStrictness CoreBndr
id StrictSig
nopSig, Expr CoreBndr
rhs) | (id :: CoreBndr
id, rhs :: Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
pairs ]

{-
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, for two reasons:

 * To get information on used free variables (both lazy and strict!)
   (see Note [Lazy and unleashable free variables])
 * To ensure that all expressions have been traversed at least once, and any left-over
   strictness annotations have been updated.

This final iteration does not add the variables to the strictness signature
environment, which effectively assigns them 'nopSig' (see "getStrictness")

-}

-- Trivial RHS
-- See Note [Demand analysis for trivial right-hand sides]
dmdAnalTrivialRhs ::
    AnalEnv -> Id -> CoreExpr -> Var ->
    (DmdEnv, Id, CoreExpr)
dmdAnalTrivialRhs :: AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> CoreBndr
-> (DmdEnv, CoreBndr, Expr CoreBndr)
dmdAnalTrivialRhs env :: AnalEnv
env id :: CoreBndr
id rhs :: Expr CoreBndr
rhs fn :: CoreBndr
fn
  = (DmdEnv
fn_fv, AnalEnv -> CoreBndr -> StrictSig -> CoreBndr
set_idStrictness AnalEnv
env CoreBndr
id StrictSig
fn_str, Expr CoreBndr
rhs)
  where
    fn_str :: StrictSig
fn_str = AnalEnv -> CoreBndr -> StrictSig
getStrictness AnalEnv
env CoreBndr
fn
    fn_fv :: DmdEnv
fn_fv | CoreBndr -> Bool
isLocalId CoreBndr
fn = CoreBndr -> Demand -> DmdEnv
forall a. CoreBndr -> a -> VarEnv a
unitVarEnv CoreBndr
fn Demand
topDmd
          | Bool
otherwise    = DmdEnv
emptyDmdEnv
    -- Note [Remember to demand the function itself]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- fn_fv: don't forget to produce a demand for fn itself
    -- Lacking this caused Trac #9128
    -- The demand is very conservative (topDmd), but that doesn't
    -- matter; trivial bindings are usually inlined, so it only
    -- kicks in for top-level bindings and NOINLINE bindings

-- Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
-- dmdAnalRhsLetDown implements the Down variant:
--  * assuming a demand of <L,U>
--  * looking at the definition
--  * determining a strictness signature
--
-- It is used for toplevel definition, recursive definitions and local
-- non-recursive definitions that have manifest lambdas.
-- Local non-recursive definitions without a lambda are handled with LetUp.
--
-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnalRhsLetDown :: TopLevelFlag
           -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
           -> AnalEnv -> CleanDemand
           -> Id -> CoreExpr
           -> (DmdEnv, Id, CoreExpr)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
dmdAnalRhsLetDown :: TopLevelFlag
-> Maybe [CoreBndr]
-> AnalEnv
-> CleanDemand
-> CoreBndr
-> Expr CoreBndr
-> (DmdEnv, CoreBndr, Expr CoreBndr)
dmdAnalRhsLetDown top_lvl :: TopLevelFlag
top_lvl rec_flag :: Maybe [CoreBndr]
rec_flag env :: AnalEnv
env let_dmd :: CleanDemand
let_dmd id :: CoreBndr
id rhs :: Expr CoreBndr
rhs
  | Just fn :: CoreBndr
fn <- Expr CoreBndr -> Maybe CoreBndr
unpackTrivial Expr CoreBndr
rhs   -- See Note [Demand analysis for trivial right-hand sides]
  = AnalEnv
-> CoreBndr
-> Expr CoreBndr
-> CoreBndr
-> (DmdEnv, CoreBndr, Expr CoreBndr)
dmdAnalTrivialRhs AnalEnv
env CoreBndr
id Expr CoreBndr
rhs CoreBndr
fn

  | Bool
otherwise
  = (DmdEnv
lazy_fv, CoreBndr
id', [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
bndrs' Expr CoreBndr
body')
  where
    (bndrs :: [CoreBndr]
bndrs, body :: Expr CoreBndr
body, body_dmd :: CleanDemand
body_dmd)
       = case CoreBndr -> Maybe Int
isJoinId_maybe CoreBndr
id of
           Just join_arity :: Int
join_arity  -- See Note [Demand analysis for join points]
                   | (bndrs :: [CoreBndr]
bndrs, body :: Expr CoreBndr
body) <- Int -> Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity Expr CoreBndr
rhs
                   -> ([CoreBndr]
bndrs, Expr CoreBndr
body, CleanDemand
let_dmd)

           Nothing | (bndrs :: [CoreBndr]
bndrs, body :: Expr CoreBndr
body) <- Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr CoreBndr
rhs
                   -> ([CoreBndr]
bndrs, Expr CoreBndr
body, AnalEnv -> Expr CoreBndr -> CleanDemand
mkBodyDmd AnalEnv
env Expr CoreBndr
body)

    env_body :: AnalEnv
env_body         = (AnalEnv -> CoreBndr -> AnalEnv)
-> AnalEnv -> [CoreBndr] -> AnalEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' AnalEnv -> CoreBndr -> AnalEnv
extendSigsWithLam AnalEnv
env [CoreBndr]
bndrs
    (body_ty :: DmdType
body_ty, body' :: Expr CoreBndr
body') = AnalEnv -> CleanDemand -> Expr CoreBndr -> (DmdType, Expr CoreBndr)
dmdAnal AnalEnv
env_body CleanDemand
body_dmd Expr CoreBndr
body
    body_ty' :: DmdType
body_ty'         = DmdType -> DmdType
removeDmdTyArgs DmdType
body_ty -- zap possible deep CPR info
    (DmdType rhs_fv :: DmdEnv
rhs_fv rhs_dmds :: [Demand]
rhs_dmds rhs_res :: DmdResult
rhs_res, bndrs' :: [CoreBndr]
bndrs')
                     = AnalEnv -> Bool -> DmdType -> [CoreBndr] -> (DmdType, [CoreBndr])
annotateLamBndrs AnalEnv
env (CoreBndr -> Bool
isDFunId CoreBndr
id) DmdType
body_ty' [CoreBndr]
bndrs
    sig_ty :: StrictSig
sig_ty           = DmdType -> StrictSig
mkStrictSig (DmdEnv -> [Demand] -> DmdResult -> DmdType
mkDmdType DmdEnv
sig_fv [Demand]
rhs_dmds DmdResult
rhs_res')
    id' :: CoreBndr
id'              = AnalEnv -> CoreBndr -> StrictSig -> CoreBndr
set_idStrictness AnalEnv
env CoreBndr
id StrictSig
sig_ty
        -- See Note [NOINLINE and strictness]


    -- See Note [Aggregated demand for cardinality]
    rhs_fv1 :: DmdEnv
rhs_fv1 = case Maybe [CoreBndr]
rec_flag of
                Just bs :: [CoreBndr]
bs -> DmdEnv -> DmdEnv
reuseEnv (DmdEnv -> [CoreBndr] -> DmdEnv
forall a. VarEnv a -> [CoreBndr] -> VarEnv a
delVarEnvList DmdEnv
rhs_fv [CoreBndr]
bs)
                Nothing -> DmdEnv
rhs_fv

    -- See Note [Lazy and unleashable free variables]
    (lazy_fv :: DmdEnv
lazy_fv, sig_fv :: DmdEnv
sig_fv) = Bool -> DmdEnv -> (DmdEnv, DmdEnv)
splitFVs Bool
is_thunk DmdEnv
rhs_fv1

    rhs_res' :: DmdResult
rhs_res'  = Bool -> Bool -> DmdResult -> DmdResult
trimCPRInfo Bool
trim_all Bool
trim_sums DmdResult
rhs_res
    trim_all :: Bool
trim_all  = Bool
is_thunk Bool -> Bool -> Bool
&& Bool
not_strict
    trim_sums :: Bool
trim_sums = Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl) -- See Note [CPR for sum types]

    -- See Note [CPR for thunks]
    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
       =  TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl  -- Top level and recursive things don't
       Bool -> Bool -> Bool
|| Maybe [CoreBndr] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [CoreBndr]
rec_flag     -- get their demandInfo set at all
       Bool -> Bool -> Bool
|| Bool -> Bool
not (Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd (CoreBndr -> Demand
idDemandInfo CoreBndr
id) Bool -> Bool -> Bool
|| AnalEnv -> Bool
ae_virgin AnalEnv
env)
          -- See Note [Optimistic CPR in the "virgin" case]

mkBodyDmd :: AnalEnv -> CoreExpr -> CleanDemand
-- See Note [Product demands for function body]
mkBodyDmd :: AnalEnv -> Expr CoreBndr -> CleanDemand
mkBodyDmd env :: AnalEnv
env body :: Expr CoreBndr
body
  = case FamInstEnvs
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitProductType_maybe (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) (Expr CoreBndr -> Type
exprType Expr CoreBndr
body) of
       Nothing            -> CleanDemand
cleanEvalDmd
       Just (dc :: DataCon
dc, _, _, _) -> Int -> CleanDemand
cleanEvalProdDmd (DataCon -> Int
dataConRepArity DataCon
dc)

unpackTrivial :: CoreExpr -> Maybe Id
-- Returns (Just v) if the arg is really equal to v, modulo
-- casts, type applications etc
-- See Note [Demand analysis for trivial right-hand sides]
unpackTrivial :: Expr CoreBndr -> Maybe CoreBndr
unpackTrivial (Var v :: CoreBndr
v)                 = CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just CoreBndr
v
unpackTrivial (Cast e :: Expr CoreBndr
e _)              = Expr CoreBndr -> Maybe CoreBndr
unpackTrivial Expr CoreBndr
e
unpackTrivial (Lam v :: CoreBndr
v e :: Expr CoreBndr
e) | CoreBndr -> Bool
isTyVar CoreBndr
v   = Expr CoreBndr -> Maybe CoreBndr
unpackTrivial Expr CoreBndr
e
unpackTrivial (App e :: Expr CoreBndr
e a :: Expr CoreBndr
a) | Expr CoreBndr -> Bool
forall b. Expr b -> Bool
isTypeArg Expr CoreBndr
a = Expr CoreBndr -> Maybe CoreBndr
unpackTrivial Expr CoreBndr
e
unpackTrivial _                       = Maybe CoreBndr
forall a. Maybe a
Nothing

-- | If given the RHS of a let-binding, this 'useLetUp' determines
-- whether we should process the binding up (body before rhs) or
-- down (rhs before body).
--
-- We use LetDown if there is a chance to get a useful strictness signature.
-- This is the case when there are manifest value lambdas or the binding is a
-- join point (hence always acts like a function, not a value).
useLetUp :: Var -> CoreExpr -> Bool
useLetUp :: CoreBndr -> Expr CoreBndr -> Bool
useLetUp f :: CoreBndr
f _         | CoreBndr -> Bool
isJoinId CoreBndr
f = Bool
False
useLetUp f :: CoreBndr
f (Lam v :: CoreBndr
v e :: Expr CoreBndr
e) | CoreBndr -> Bool
isTyVar CoreBndr
v  = CoreBndr -> Expr CoreBndr -> Bool
useLetUp CoreBndr
f Expr CoreBndr
e
useLetUp _ (Lam _ _)              = Bool
False
useLetUp _ _                      = Bool
True


{- Note [Demand analysis for join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   g :: (Int,Int) -> Int
   g (p,q) = p+q

   f :: T -> Int -> Int
   f x p = g (join j y = (p,y)
              in case x of
                   A -> j 3
                   B -> j 4
                   C -> (p,7))

If j was a vanilla function definition, we'd analyse its body with
evalDmd, and think that it was lazy in p.  But for join points we can
do better!  We know that j's body will (if called at all) be evaluated
with the demand that consumes the entire join-binding, in this case
the argument demand from g.  Whizzo!  g evaluates both components of
its argument pair, so p will certainly be evaluated if j is called.

For f to be strict in p, we need /all/ paths to evaluate p; in this
case the C branch does so too, so we are fine.  So, as usual, we need
to transport demands on free variables to the call site(s).  Compare
Note [Lazy and unleashable free variables].

The implementation is easy.  When analysing a join point, we can
analyse its body with the demand from the entire join-binding (written
let_dmd here).

Another win for join points!  Trac #13543.

Note [Demand analysis for trivial right-hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
        foo = plusInt |> co
where plusInt is an arity-2 function with known strictness.  Clearly
we want plusInt's strictness to propagate to foo!  But because it has
no manifest lambdas, it won't do so automatically, and indeed 'co' might
have type (Int->Int->Int) ~ T, so we *can't* eta-expand.  So we have a
special case for right-hand sides that are "trivial", namely variables,
casts, type applications, and the like.

Note that this can mean that 'foo' has an arity that is smaller than that
indicated by its demand info.  e.g. if co :: (Int->Int->Int) ~ T, then
foo's arity will be zero (see Note [exprArity invariant] in CoreArity),
but its demand signature will be that of plusInt. A small example is the
test case of Trac #8963.


Note [Product demands for function body]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This example comes from shootout/binary_trees:

    Main.check' = \ b z ds. case z of z' { I# ip ->
                                case ds_d13s of
                                  Main.Nil -> z'
                                  Main.Node s14k s14l s14m ->
                                    Main.check' (not b)
                                      (Main.check' b
                                         (case b {
                                            False -> I# (-# s14h s14k);
                                            True  -> I# (+# s14h s14k)
                                          })
                                         s14l)
                                     s14m   }   }   }

Here we *really* want to unbox z, even though it appears to be used boxed in
the Nil case.  Partly the Nil case is not a hot path.  But more specifically,
the whole function gets the CPR property if we do.

So for the demand on the body of a RHS we use a product demand if it's
a product type.

************************************************************************
*                                                                      *
\subsection{Strictness signatures and types}
*                                                                      *
************************************************************************
-}

unitDmdType :: DmdEnv -> DmdType
unitDmdType :: DmdEnv -> DmdType
unitDmdType dmd_env :: DmdEnv
dmd_env = DmdEnv -> [Demand] -> DmdResult -> DmdType
DmdType DmdEnv
dmd_env [] DmdResult
topRes

coercionDmdEnv :: Coercion -> DmdEnv
coercionDmdEnv :: Coercion -> DmdEnv
coercionDmdEnv co :: Coercion
co = (CoreBndr -> Demand) -> VarEnv CoreBndr -> DmdEnv
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (Demand -> CoreBndr -> Demand
forall a b. a -> b -> a
const Demand
topDmd) (UniqSet CoreBndr -> VarEnv CoreBndr
forall a. UniqSet a -> UniqFM a
getUniqSet (UniqSet CoreBndr -> VarEnv CoreBndr)
-> UniqSet CoreBndr -> VarEnv CoreBndr
forall a b. (a -> b) -> a -> b
$ Coercion -> UniqSet CoreBndr
coVarsOfCo Coercion
co)
                    -- The VarSet from coVarsOfCo is really a VarEnv Var

addVarDmd :: DmdType -> Var -> Demand -> DmdType
addVarDmd :: DmdType -> CoreBndr -> Demand -> DmdType
addVarDmd (DmdType fv :: DmdEnv
fv ds :: [Demand]
ds res :: DmdResult
res) var :: CoreBndr
var dmd :: Demand
dmd
  = DmdEnv -> [Demand] -> DmdResult -> DmdType
DmdType ((Demand -> Demand -> Demand)
-> DmdEnv -> CoreBndr -> Demand -> DmdEnv
forall a. (a -> a -> a) -> VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv_C Demand -> Demand -> Demand
bothDmd DmdEnv
fv CoreBndr
var Demand
dmd) [Demand]
ds DmdResult
res

addLazyFVs :: DmdType -> DmdEnv -> DmdType
addLazyFVs :: DmdType -> DmdEnv -> DmdType
addLazyFVs dmd_ty :: DmdType
dmd_ty lazy_fvs :: DmdEnv
lazy_fvs
  = DmdType
dmd_ty DmdType -> BothDmdArg -> DmdType
`bothDmdType` DmdEnv -> BothDmdArg
mkBothDmdArg DmdEnv
lazy_fvs
        -- Using bothDmdType (rather than just both'ing the envs)
        -- is vital.  Consider
        --      let f = \x -> (x,y)
        --      in  error (f 3)
        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L
        -- demand with the bottom coming up from 'error'
        --
        -- I got a loop in the fixpointer without this, due to an interaction
        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was
        --      letrec f n x
        --          = letrec g y = x `fatbar`
        --                         letrec h z = z + ...g...
        --                         in h (f (n-1) x)
        --      in ...
        -- In the initial iteration for f, f=Bot
        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it
        -- places on its free variables.  Suppose it places none.  Then the
        --      x `fatbar` ...call to h...
        -- will give a x->V demand for x.  That turns into a L demand for x,
        -- which floats out of the defn for h.  Without the modifyEnv, that
        -- L demand doesn't get both'd with the Bot coming up from the inner
        -- call to f.  So we just get an L demand for x for g.

{-
Note [Do not strictify the argument dictionaries of a dfun]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker can tie recursive knots involving dfuns, so we do the
conservative thing and refrain from strictifying a dfun's argument
dictionaries.
-}

setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]
setBndrsDemandInfo :: [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo (b :: CoreBndr
b:bs :: [CoreBndr]
bs) (d :: Demand
d:ds :: [Demand]
ds)
  | CoreBndr -> Bool
isTyVar CoreBndr
b = CoreBndr
b CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bs (Demand
dDemand -> [Demand] -> [Demand]
forall a. a -> [a] -> [a]
:[Demand]
ds)
  | Bool
otherwise = CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
b Demand
d CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr] -> [Demand] -> [CoreBndr]
setBndrsDemandInfo [CoreBndr]
bs [Demand]
ds
setBndrsDemandInfo [] ds :: [Demand]
ds = ASSERT( null ds ) []
setBndrsDemandInfo bs :: [CoreBndr]
bs _  = String -> SDoc -> [CoreBndr]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "setBndrsDemandInfo" ([CoreBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreBndr]
bs)

annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
-- The returned env has the var deleted
-- The returned var is annotated with demand info
-- according to the result demand of the provided demand type
-- No effect on the argument demands
annotateBndr :: AnalEnv -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateBndr env :: AnalEnv
env dmd_ty :: DmdType
dmd_ty var :: CoreBndr
var
  | CoreBndr -> Bool
isId CoreBndr
var  = (DmdType
dmd_ty', CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
var Demand
dmd)
  | Bool
otherwise = (DmdType
dmd_ty, CoreBndr
var)
  where
    (dmd_ty' :: DmdType
dmd_ty', dmd :: Demand
dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
False DmdType
dmd_ty CoreBndr
var

annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])
annotateLamBndrs :: AnalEnv -> Bool -> DmdType -> [CoreBndr] -> (DmdType, [CoreBndr])
annotateLamBndrs env :: AnalEnv
env args_of_dfun :: Bool
args_of_dfun ty :: DmdType
ty bndrs :: [CoreBndr]
bndrs = (DmdType -> CoreBndr -> (DmdType, CoreBndr))
-> DmdType -> [CoreBndr] -> (DmdType, [CoreBndr])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumR DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotate DmdType
ty [CoreBndr]
bndrs
  where
    annotate :: DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotate dmd_ty :: DmdType
dmd_ty bndr :: CoreBndr
bndr
      | CoreBndr -> Bool
isId CoreBndr
bndr = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateLamIdBndr AnalEnv
env Bool
args_of_dfun DmdType
dmd_ty CoreBndr
bndr
      | Bool
otherwise = (DmdType
dmd_ty, CoreBndr
bndr)

annotateLamIdBndr :: AnalEnv
                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
                  -> DmdType    -- Demand type of body
                  -> Id         -- Lambda binder
                  -> (DmdType,  -- Demand type of lambda
                      Id)       -- and binder annotated with demand

annotateLamIdBndr :: AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, CoreBndr)
annotateLamIdBndr env :: AnalEnv
env arg_of_dfun :: Bool
arg_of_dfun dmd_ty :: DmdType
dmd_ty id :: CoreBndr
id
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
  = ASSERT( isId id )
    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
    (DmdType
final_ty, CoreBndr -> Demand -> CoreBndr
setIdDemandInfo CoreBndr
id Demand
dmd)
  where
      -- Watch out!  See note [Lambda-bound unfoldings]
    final_ty :: DmdType
final_ty = case Unfolding -> Maybe (Expr CoreBndr)
maybeUnfoldingTemplate (CoreBndr -> Unfolding
idUnfolding CoreBndr
id) of
                 Nothing  -> DmdType
main_ty
                 Just unf :: Expr CoreBndr
unf -> DmdType
main_ty DmdType -> BothDmdArg -> DmdType
`bothDmdType` BothDmdArg
unf_ty
                          where
                             (unf_ty :: BothDmdArg
unf_ty, _) = AnalEnv -> Demand -> Expr CoreBndr -> (BothDmdArg, Expr CoreBndr)
dmdAnalStar AnalEnv
env Demand
dmd Expr CoreBndr
unf

    main_ty :: DmdType
main_ty = Demand -> DmdType -> DmdType
addDemand Demand
dmd DmdType
dmd_ty'
    (dmd_ty' :: DmdType
dmd_ty', dmd :: Demand
dmd) = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
arg_of_dfun DmdType
dmd_ty CoreBndr
id

deleteFVs :: DmdType -> [Var] -> DmdType
deleteFVs :: DmdType -> [CoreBndr] -> DmdType
deleteFVs (DmdType fvs :: DmdEnv
fvs dmds :: [Demand]
dmds res :: DmdResult
res) bndrs :: [CoreBndr]
bndrs
  = DmdEnv -> [Demand] -> DmdResult -> DmdType
DmdType (DmdEnv -> [CoreBndr] -> DmdEnv
forall a. VarEnv a -> [CoreBndr] -> VarEnv a
delVarEnvList DmdEnv
fvs [CoreBndr]
bndrs) [Demand]
dmds DmdResult
res

{-
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.

The difficulty with this is that we need the strictness type to
look at the body... but we now need the body to calculate the demand
on the variable, so we can decide whether its strictness type should
have a CPR in it or not.  Simple solution:
        a) use strictness info from the previous iteration
        b) make sure we do at least 2 iterations, by doing a second
           round for top-level non-recs.  Top level recs will get at
           least 2 iterations except for totally-bottom functions
           which aren't very interesting anyway.

NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.

Note [Optimistic CPR in the "virgin" case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Demand and strictness info are initialized by top elements. However,
this prevents from inferring a CPR property in the first pass of the
analyser, so we keep an explicit flag ae_virgin in the AnalEnv
datatype.

We can't start with 'not-demanded' (i.e., top) because then consider
        f x = let
                  t = ... I# x
              in
              if ... then t else I# y else f x'

In the first iteration we'd have no demand info for x, so assume
not-demanded; then we'd get TopRes for f's CPR info.  Next iteration
we'd see that t was demanded, and so give it the CPR property, but by
now f has TopRes, so it will stay TopRes.  Instead, by checking the
ae_virgin flag at the first time round, we say 'yes t is demanded' the
first time.

However, this does mean that for non-recursive bindings we must
iterate twice to be sure of not getting over-optimistic CPR info,
in the case where t turns out to be not-demanded.  This is handled
by dmdAnalTopBind.


Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The strictness analyser used to have a HACK which ensured that NOINLNE
things were not strictness-analysed.  The reason was unsafePerformIO.
Left to itself, the strictness analyser would discover this strictness
for unsafePerformIO:
        unsafePerformIO:  C(U(AV))
But then consider this sub-expression
        unsafePerformIO (\s -> let r = f x in
                               case writeIORef v r s of (# s1, _ #) ->
                               (# s1, r #)
The strictness analyser will now find that r is sure to be eval'd,
and may then hoist it out.  This makes tests/lib/should_run/memo002
deadlock.

Solving this by making all NOINLINE things have no strictness info is overkill.
In particular, it's overkill for runST, which is perfectly respectable.
Consider
        f x = runST (return x)
This should be strict in x.

So the new plan is to define unsafePerformIO using the 'lazy' combinator:

        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)

Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
magically NON-STRICT, and is inlined after strictness analysis.  So
unsafePerformIO will look non-strict, and that's what we want.

Now we don't need the hack in the strictness analyser.  HOWEVER, this
decision does mean that even a NOINLINE function is not entirely
opaque: some aspect of its implementation leaks out, notably its
strictness.  For example, if you have a function implemented by an
error stub, but which has RULES, you may want it not to be eliminated
in favour of error!

Note [Lazy and unleashable free variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We put the strict and once-used FVs in the DmdType of the Id, so
that at its call sites we unleash demands on its strict fvs.
An example is 'roll' in imaginary/wheel-sieve2
Something like this:
        roll x = letrec
                     go y = if ... then roll (x-1) else x+1
                 in
                 go ms
We want to see that roll is strict in x, which is because
go is called.   So we put the DmdEnv for x in go's DmdType.

Another example:

        f :: Int -> Int -> Int
        f x y = let t = x+1
            h z = if z==0 then t else
                  if z==1 then x+1 else
                  x + h (z-1)
        in h y

Calling h does indeed evaluate x, but we can only see
that if we unleash a demand on x at the call site for t.

Incidentally, here's a place where lambda-lifting h would
lose the cigar --- we couldn't see the joint strictness in t/x

        ON THE OTHER HAND

We don't want to put *all* the fv's from the RHS into the
DmdType. Because

 * it makes the strictness signatures larger, and hence slows down fixpointing

and

 * it is useless information at the call site anyways:
   For lazy, used-many times fv's we will never get any better result than
   that, no matter how good the actual demand on the function at the call site
   is (unless it is always absent, but then the whole binder is useless).

Therefore we exclude lazy multiple-used fv's from the environment in the
DmdType.

But now the signature lies! (Missing variables are assumed to be absent.) To
make up for this, the code that analyses the binding keeps the demand on those
variable separate (usually called "lazy_fv") and adds it to the demand of the
whole binding later.

What if we decide _not_ to store a strictness signature for a binding at all, as
we do when aborting a fixed-point iteration? The we risk losing the information
that the strict variables are being used. In that case, we take all free variables
mentioned in the (unsound) strictness signature, conservatively approximate the
demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".


Note [Lambda-bound unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We allow a lambda-bound variable to carry an unfolding, a facility that is used
exclusively for join points; see Note [Case binders and join points].  If so,
we must be careful to demand-analyse the RHS of the unfolding!  Example
   \x. \y{=Just x}. <body>
Then if <body> uses 'y', then transitively it uses 'x', and we must not
forget that fact, otherwise we might make 'x' absent when it isn't.


************************************************************************
*                                                                      *
\subsection{Strictness signatures}
*                                                                      *
************************************************************************
-}

type DFunFlag = Bool  -- indicates if the lambda being considered is in the
                      -- sequence of lambdas at the top of the RHS of a dfun
notArgOfDfun :: DFunFlag
notArgOfDfun :: Bool
notArgOfDfun = Bool
False

data AnalEnv
  = AE { AnalEnv -> DynFlags
ae_dflags :: DynFlags
       , AnalEnv -> SigEnv
ae_sigs   :: SigEnv
       , AnalEnv -> Bool
ae_virgin :: Bool    -- True on first iteration only
                              -- See Note [Initialising strictness]
       , AnalEnv -> RecTcChecker
ae_rec_tc :: RecTcChecker
       , AnalEnv -> FamInstEnvs
ae_fam_envs :: FamInstEnvs
 }

        -- We use the se_env to tell us whether to
        -- record info about a variable in the DmdEnv
        -- We do so if it's a LocalId, but not top-level
        --
        -- The DmdEnv gives the demand on the free vars of the function
        -- when it is given enough args to satisfy the strictness signature

type SigEnv = VarEnv (StrictSig, TopLevelFlag)

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 "AE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
         [ String -> SDoc
text "ae_virgin =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
virgin
         , String -> SDoc
text "ae_sigs =" SDoc -> SDoc -> SDoc
<+> SigEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr SigEnv
env ])

emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv dflags :: DynFlags
dflags fam_envs :: FamInstEnvs
fam_envs
    = AE :: DynFlags
-> SigEnv -> Bool -> RecTcChecker -> FamInstEnvs -> AnalEnv
AE { ae_dflags :: DynFlags
ae_dflags = DynFlags
dflags
         , ae_sigs :: SigEnv
ae_sigs = SigEnv
emptySigEnv
         , ae_virgin :: Bool
ae_virgin = Bool
True
         , ae_rec_tc :: RecTcChecker
ae_rec_tc = RecTcChecker
initRecTc
         , ae_fam_envs :: FamInstEnvs
ae_fam_envs = FamInstEnvs
fam_envs
         }

emptySigEnv :: SigEnv
emptySigEnv :: SigEnv
emptySigEnv = SigEnv
forall a. VarEnv a
emptyVarEnv

-- | Extend an environment with the strictness IDs attached to the id
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [CoreBndr] -> AnalEnv
extendAnalEnvs top_lvl :: TopLevelFlag
top_lvl env :: AnalEnv
env vars :: [CoreBndr]
vars
  = AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = TopLevelFlag -> SigEnv -> [CoreBndr] -> SigEnv
extendSigEnvs TopLevelFlag
top_lvl (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) [CoreBndr]
vars }

extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
extendSigEnvs :: TopLevelFlag -> SigEnv -> [CoreBndr] -> SigEnv
extendSigEnvs top_lvl :: TopLevelFlag
top_lvl sigs :: SigEnv
sigs vars :: [CoreBndr]
vars
  = SigEnv -> [(CoreBndr, (StrictSig, TopLevelFlag))] -> SigEnv
forall a. VarEnv a -> [(CoreBndr, a)] -> VarEnv a
extendVarEnvList SigEnv
sigs [ (CoreBndr
var, (CoreBndr -> StrictSig
idStrictness CoreBndr
var, TopLevelFlag
top_lvl)) | CoreBndr
var <- [CoreBndr]
vars]

extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
extendAnalEnv :: TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv top_lvl :: TopLevelFlag
top_lvl env :: AnalEnv
env var :: CoreBndr
var sig :: StrictSig
sig
  = AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = TopLevelFlag -> SigEnv -> CoreBndr -> StrictSig -> SigEnv
extendSigEnv TopLevelFlag
top_lvl (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) CoreBndr
var StrictSig
sig }

extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
extendSigEnv :: TopLevelFlag -> SigEnv -> CoreBndr -> StrictSig -> SigEnv
extendSigEnv top_lvl :: TopLevelFlag
top_lvl sigs :: SigEnv
sigs var :: CoreBndr
var sig :: StrictSig
sig = SigEnv -> CoreBndr -> (StrictSig, TopLevelFlag) -> SigEnv
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv SigEnv
sigs CoreBndr
var (StrictSig
sig, TopLevelFlag
top_lvl)

lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv :: AnalEnv -> CoreBndr -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv env :: AnalEnv
env id :: CoreBndr
id = SigEnv -> CoreBndr -> Maybe (StrictSig, TopLevelFlag)
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) CoreBndr
id

getStrictness :: AnalEnv -> Id -> StrictSig
getStrictness :: AnalEnv -> CoreBndr -> StrictSig
getStrictness env :: AnalEnv
env fn :: CoreBndr
fn
  | CoreBndr -> Bool
isGlobalId CoreBndr
fn                        = CoreBndr -> StrictSig
idStrictness CoreBndr
fn
  | Just (sig :: StrictSig
sig, _) <- AnalEnv -> CoreBndr -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv AnalEnv
env CoreBndr
fn = StrictSig
sig
  | Bool
otherwise                            = StrictSig
nopSig

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

extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
-- Extend the AnalEnv when we meet a lambda binder
extendSigsWithLam :: AnalEnv -> CoreBndr -> AnalEnv
extendSigsWithLam env :: AnalEnv
env id :: CoreBndr
id
  | CoreBndr -> Bool
isId CoreBndr
id
  , Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd (CoreBndr -> Demand
idDemandInfo CoreBndr
id) Bool -> Bool -> Bool
|| AnalEnv -> Bool
ae_virgin AnalEnv
env
       -- See Note [Optimistic CPR in the "virgin" case]
       -- See Note [Initial CPR for strict binders]
  , Just (dc :: DataCon
dc,_,_,_) <- FamInstEnvs
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitProductType_maybe (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) (Type
 -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion))
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Type
idType CoreBndr
id
  = TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
NotTopLevel AnalEnv
env CoreBndr
id (Int -> StrictSig
cprProdSig (DataCon -> Int
dataConRepArity DataCon
dc))

  | Bool
otherwise
  = AnalEnv
env

extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv
-- See Note [CPR in a product case alternative]
extendEnvForProdAlt :: AnalEnv
-> Expr CoreBndr -> CoreBndr -> DataCon -> [CoreBndr] -> AnalEnv
extendEnvForProdAlt env :: AnalEnv
env scrut :: Expr CoreBndr
scrut case_bndr :: CoreBndr
case_bndr dc :: DataCon
dc bndrs :: [CoreBndr]
bndrs
  = (AnalEnv -> (CoreBndr, StrictnessMark) -> AnalEnv)
-> AnalEnv -> [(CoreBndr, StrictnessMark)] -> AnalEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' AnalEnv -> (CoreBndr, StrictnessMark) -> AnalEnv
do_con_arg AnalEnv
env1 [(CoreBndr, StrictnessMark)]
ids_w_strs
  where
    env1 :: AnalEnv
env1 = TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
NotTopLevel AnalEnv
env CoreBndr
case_bndr StrictSig
case_bndr_sig

    ids_w_strs :: [(CoreBndr, StrictnessMark)]
ids_w_strs    = (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreBndr -> Bool
isId [CoreBndr]
bndrs [CoreBndr] -> [StrictnessMark] -> [(CoreBndr, StrictnessMark)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc
    case_bndr_sig :: StrictSig
case_bndr_sig = Int -> StrictSig
cprProdSig (DataCon -> Int
dataConRepArity DataCon
dc)
    fam_envs :: FamInstEnvs
fam_envs      = AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env

    do_con_arg :: AnalEnv -> (CoreBndr, StrictnessMark) -> AnalEnv
do_con_arg env :: AnalEnv
env (id :: CoreBndr
id, str :: StrictnessMark
str)
       | let is_strict :: Bool
is_strict = Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd (CoreBndr -> Demand
idDemandInfo CoreBndr
id) Bool -> Bool -> Bool
|| StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str
       , AnalEnv -> Bool
ae_virgin AnalEnv
env Bool -> Bool -> Bool
|| (Bool
is_var_scrut Bool -> Bool -> Bool
&& Bool
is_strict)  -- See Note [CPR in a product case alternative]
       , Just (dc :: DataCon
dc,_,_,_) <- FamInstEnvs
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitProductType_maybe FamInstEnvs
fam_envs (Type
 -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion))
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Type
idType CoreBndr
id
       = TopLevelFlag -> AnalEnv -> CoreBndr -> StrictSig -> AnalEnv
extendAnalEnv TopLevelFlag
NotTopLevel AnalEnv
env CoreBndr
id (Int -> StrictSig
cprProdSig (DataCon -> Int
dataConRepArity DataCon
dc))
       | Bool
otherwise
       = AnalEnv
env

    is_var_scrut :: Bool
is_var_scrut = Expr CoreBndr -> Bool
forall b. Expr b -> Bool
is_var Expr CoreBndr
scrut
    is_var :: Expr b -> Bool
is_var (Cast e :: Expr b
e _) = Expr b -> Bool
is_var Expr b
e
    is_var (Var v :: CoreBndr
v)    = CoreBndr -> Bool
isLocalId CoreBndr
v
    is_var _          = Bool
False

findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
-- Return the demands on the Ids in the [Var]
findBndrsDmds :: AnalEnv -> DmdType -> [CoreBndr] -> (DmdType, [Demand])
findBndrsDmds env :: AnalEnv
env dmd_ty :: DmdType
dmd_ty bndrs :: [CoreBndr]
bndrs
  = DmdType -> [CoreBndr] -> (DmdType, [Demand])
go DmdType
dmd_ty [CoreBndr]
bndrs
  where
    go :: DmdType -> [CoreBndr] -> (DmdType, [Demand])
go dmd_ty :: DmdType
dmd_ty []  = (DmdType
dmd_ty, [])
    go dmd_ty :: DmdType
dmd_ty (b :: CoreBndr
b:bs :: [CoreBndr]
bs)
      | CoreBndr -> Bool
isId CoreBndr
b    = let (dmd_ty1 :: DmdType
dmd_ty1, dmds :: [Demand]
dmds) = DmdType -> [CoreBndr] -> (DmdType, [Demand])
go DmdType
dmd_ty [CoreBndr]
bs
                        (dmd_ty2 :: DmdType
dmd_ty2, dmd :: Demand
dmd)  = AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd AnalEnv
env Bool
False DmdType
dmd_ty1 CoreBndr
b
                    in (DmdType
dmd_ty2, Demand
dmd Demand -> [Demand] -> [Demand]
forall a. a -> [a] -> [a]
: [Demand]
dmds)
      | Bool
otherwise = DmdType -> [CoreBndr] -> (DmdType, [Demand])
go DmdType
dmd_ty [CoreBndr]
bs

findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
-- See Note [Trimming a demand to a type] in Demand.hs
findBndrDmd :: AnalEnv -> Bool -> DmdType -> CoreBndr -> (DmdType, Demand)
findBndrDmd env :: AnalEnv
env arg_of_dfun :: Bool
arg_of_dfun dmd_ty :: DmdType
dmd_ty id :: CoreBndr
id
  = (DmdType
dmd_ty', Demand
dmd')
  where
    dmd' :: Demand
dmd' = DynFlags -> Demand -> Demand
killUsageDemand (AnalEnv -> DynFlags
ae_dflags AnalEnv
env) (Demand -> Demand) -> Demand -> Demand
forall a b. (a -> b) -> a -> b
$
           Demand -> Demand
strictify (Demand -> Demand) -> Demand -> Demand
forall a b. (a -> b) -> a -> b
$
           Demand -> TypeShape -> Demand
trimToType Demand
starting_dmd (FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs Type
id_ty)

    (dmd_ty' :: DmdType
dmd_ty', starting_dmd :: Demand
starting_dmd) = DmdType -> CoreBndr -> (DmdType, Demand)
peelFV DmdType
dmd_ty CoreBndr
id

    id_ty :: Type
id_ty = CoreBndr -> Type
idType CoreBndr
id

    strictify :: Demand -> Demand
strictify dmd :: Demand
dmd
      | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DictsStrict (AnalEnv -> DynFlags
ae_dflags AnalEnv
env)
             -- We never want to strictify a recursive let. At the moment
             -- annotateBndr is only call for non-recursive lets; if that
             -- changes, we need a RecFlag parameter and another guard here.
      , Bool -> Bool
not Bool
arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]
      = Type -> Demand -> Demand
strictifyDictDmd Type
id_ty Demand
dmd
      | Bool
otherwise
      = Demand
dmd

    fam_envs :: FamInstEnvs
fam_envs = AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env

set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
set_idStrictness :: AnalEnv -> CoreBndr -> StrictSig -> CoreBndr
set_idStrictness env :: AnalEnv
env id :: CoreBndr
id sig :: StrictSig
sig
  = CoreBndr -> StrictSig -> CoreBndr
setIdStrictness CoreBndr
id (DynFlags -> StrictSig -> StrictSig
killUsageSig (AnalEnv -> DynFlags
ae_dflags AnalEnv
env) StrictSig
sig)

dumpStrSig :: CoreProgram -> SDoc
dumpStrSig :: CoreProgram -> SDoc
dumpStrSig binds :: CoreProgram
binds = [SDoc] -> SDoc
vcat ((CoreBndr -> SDoc) -> [CoreBndr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> SDoc
printId [CoreBndr]
ids)
  where
  ids :: [CoreBndr]
ids = (CoreBndr -> CoreBndr -> Ordering) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name -> Name -> Ordering
stableNameCmp (Name -> Name -> Ordering)
-> (CoreBndr -> Name) -> CoreBndr -> CoreBndr -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName) ((CoreBind -> [CoreBndr]) -> CoreProgram -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [CoreBndr]
forall b. Bind b -> [b]
getIds CoreProgram
binds)
  getIds :: Bind b -> [b]
getIds (NonRec i :: b
i _) = [ b
i ]
  getIds (Rec bs :: [(b, Expr b)]
bs)     = ((b, Expr b) -> b) -> [(b, Expr b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> b
forall a b. (a, b) -> a
fst [(b, Expr b)]
bs
  printId :: CoreBndr -> SDoc
printId id :: CoreBndr
id | CoreBndr -> Bool
isExportedId CoreBndr
id = CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
id SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> StrictSig -> SDoc
pprIfaceStrictSig (CoreBndr -> StrictSig
idStrictness CoreBndr
id)
             | Bool
otherwise       = SDoc
empty

{- Note [CPR in a product case alternative]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a case alternative for a product type, we want to give some of the
binders the CPR property.  Specifically

 * The case binder; 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.

 * Any strict binders with product type, can use
   Note [Initial CPR for strict binders].  But we can go a little
   further. Consider

      data T = MkT !Int Int

      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))
                   | otherwise = x

   For $wf2 we are going to unbox the MkT *and*, since it is strict, the
   first argument of the MkT; see Note [Add demands for strict constructors]
   in WwLib. But then we don't want box it up again when returning it! We want
   'f2' to have the CPR property, so we give 'x' the CPR property.

 * It's a bit delicate because if this case is scrutinising something other
   than an argument the original function, we really don't have the unboxed
   version available.  E.g
      g v = case foo v of
              MkT x y | y>0       -> ...
                      | otherwise -> x
   Here we don't have the unboxed 'x' available.  Hence the
   is_var_scrut test when making use of the strictness annotation.
   Slightly ad-hoc, because even if the scrutinee *is* a variable it
   might not be a onre of the arguments to the original function, or a
   sub-component thereof.  But it's simple, and nothing terrible
   happens if we get it wrong.  e.g. Trac #10694.


Note [Initial CPR for strict binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CPR is initialized for a lambda binder in an optimistic manner, i.e,
if the binder is used strictly and at least some of its components as
a product are used, which is checked by the value of the absence
demand.

If the binder is marked demanded with a strict demand, 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.

Note that

  * We only want to do this for something that definitely
    has product type, else we may get over-optimistic CPR results
    (e.g. from \x -> x!).

  * See Note [CPR examples]

Note [CPR examples]
~~~~~~~~~~~~~~~~~~~~
Here are some examples (stranal/should_compile/T10482a) of the
usefulness of Note [CPR in a product case alternative].  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)


    ------- f2 -----------
    -- x is a strict field of MkT2, so we'll pass it unboxed
    -- to $wf2, so it's available unboxed.  This depends on
    -- the case expression analysing (a subcomponent of) one
    -- of the original arguments to the function, so it's
    -- a bit more delicate.

    data T2 = MkT2 !Int Int

    f2 :: T2 -> Int
    f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
                  | otherwise = x


    ------- 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


    ------- f4 -----------
    -- Just like f2, but MkT4 can't unbox its strict
    -- argument automatically, as f2 can

    data family Foo a
    newtype instance Foo Int = Foo Int

    data T4 a = MkT4 !(Foo a) Int

    f4 :: T4 Int -> Int
    f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
                          | otherwise = v


Note [Initialising strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See section 9.2 (Finding fixpoints) of the paper.

Our basic plan is to initialise the strictness of each Id in a
recursive group to "bottom", and find a fixpoint from there.  However,
this group B might be inside an *enclosing* recursive group A, in
which case we'll do the entire fixpoint shebang on for each iteration
of A. This can be illustrated by the following example:

Example:

  f [] = []
  f (x:xs) = let g []     = f xs
                 g (y:ys) = y+1 : g ys
              in g (h x)

At each iteration of the fixpoint for f, the analyser has to find a
fixpoint for the enclosed function g. In the meantime, the demand
values for g at each iteration for f are *greater* than those we
encountered in the previous iteration for f. Therefore, we can begin
the fixpoint for g not with the bottom value but rather with the
result of the previous analysis. I.e., when beginning the fixpoint
process for g, we can start from the demand signature computed for g
previously and attached to the binding occurrence of g.

To speed things up, we initialise each iteration of A (the enclosing
one) from the result of the last one, which is neatly recorded in each
binder.  That way we make use of earlier iterations of the fixpoint
algorithm. (Cunning plan.)

But on the *first* iteration we want to *ignore* the current strictness
of the Id, and start from "bottom".  Nowadays the Id can have a current
strictness, because interface files record strictness for nested bindings.
To know when we are in the first iteration, we look at the ae_virgin
field of the AnalEnv.


Note [Final Demand Analyser run]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some of the information that the demand analyser determines is not always
preserved by the simplifier.  For example, the simplifier will happily rewrite
  \y [Demand=1*U] let x = y in x + x
to
  \y [Demand=1*U] y + y
which is quite a lie.

The once-used information is (currently) only used by the code
generator, though.  So:

 * We zap the used-once info in the worker-wrapper;
   see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's
   not reliable, it's better not to have it at all.

 * Just before TidyCore, we add a pass of the demand analyser,
      but WITHOUT subsequent worker/wrapper and simplifier,
   right before TidyCore.  See SimplCore.getCoreToDo.

   This way, correct information finds its way into the module interface
   (strictness signatures!) and the code generator (single-entry thunks!)

Note that, in contrast, the single-call information (C1(..)) /can/ be
relied upon, as the simplifier tends to be very careful about not
duplicating actual function calls.

Also see #11731.
-}