module GHC.Stg.Make
  ( MkStgRhs (..)
  , mkTopStgRhs
  , mkStgRhs
  , mkStgRhsCon_maybe
  , mkTopStgRhsCon_maybe
  )
where

import GHC.Prelude
import GHC.Unit.Module

import GHC.Core.DataCon
import GHC.Core.Type (Type)

import GHC.Stg.Syntax
import GHC.Stg.Utils (stripStgTicksTop)

import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.CostCentre
import GHC.Types.Demand    ( isAtMostOnceDmd )
import GHC.Types.Tickish

-- Represents the RHS of a binding for use with mk(Top)StgRhs and
-- mk(Top)StgRhsCon_maybe.
data MkStgRhs = MkStgRhs
  { MkStgRhs -> [Id]
rhs_args :: [Id]     -- ^ Empty for thunks
  , MkStgRhs -> StgExpr
rhs_expr :: StgExpr  -- ^ RHS expression
  , MkStgRhs -> Type
rhs_type :: Type     -- ^ RHS type (only used in the JS backend: layering violation)
  , MkStgRhs -> Bool
rhs_is_join :: !Bool -- ^ Is it a RHS for a join-point?
  }


-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
            -> Bool -> Module -> CollectedCCs
            -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
-> Bool
-> Module
-> CollectedCCs
-> Id
-> MkStgRhs
-> (StgRhs, CollectedCCs)
mkTopStgRhs Module -> DataCon -> [StgArg] -> Bool
allow_toplevel_con_app Bool
opt_AutoSccsOnIndividualCafs Module
this_mod CollectedCCs
ccs Id
bndr mk_rhs :: MkStgRhs
mk_rhs@(MkStgRhs [Id]
bndrs StgExpr
rhs Type
typ Bool
_)
  -- try to make a StgRhsCon first
  | Just StgRhs
rhs_con <- (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
mkTopStgRhsCon_maybe (Module -> DataCon -> [StgArg] -> Bool
allow_toplevel_con_app Module
this_mod) MkStgRhs
mk_rhs
  = ( StgRhs
rhs_con, CollectedCCs
ccs )

  | Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs)
  = -- The list of arguments is non-empty, so not CAF
    ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> Type
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
dontCareCCS
                    UpdateFlag
ReEntrant
                    [Id]
[BinderP 'Vanilla]
bndrs StgExpr
rhs Type
typ
    , CollectedCCs
ccs )

  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
  | Bool
opt_AutoSccsOnIndividualCafs
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> Type
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
caf_ccs
                    UpdateFlag
upd_flag [] StgExpr
rhs Type
typ
    , CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC CostCentre
caf_cc CostCentreStack
caf_ccs CollectedCCs
ccs )

  | Bool
otherwise
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> Type
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
all_cafs_ccs
                    UpdateFlag
upd_flag [] StgExpr
rhs Type
typ
    , CollectedCCs
ccs )

  where
    upd_flag :: UpdateFlag
upd_flag | Demand -> Bool
isAtMostOnceDmd (Id -> Demand
idDemandInfo Id
bndr) = UpdateFlag
SingleEntry
             | Bool
otherwise                           = UpdateFlag
Updatable

    -- CAF cost centres generated for -fcaf-all
    caf_cc :: CostCentre
caf_cc = Id -> Module -> CostCentre
mkAutoCC Id
bndr Module
modl
    caf_ccs :: CostCentreStack
caf_ccs = CostCentre -> CostCentreStack
mkSingletonCCS CostCentre
caf_cc
           -- careful: the binder might be :Main.main,
           -- which doesn't belong to module mod_name.
           -- bug #249, tests prof001, prof002
    modl :: Module
modl | Just Module
m <- Name -> Maybe Module
nameModule_maybe (Id -> Name
idName Id
bndr) = Module
m
         | Bool
otherwise = Module
this_mod

    -- default CAF cost centre
    (CostCentre
_, CostCentreStack
all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod

-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
-- see Note [Cost-centre initialization plan].
mkStgRhs :: Id -> MkStgRhs -> StgRhs
mkStgRhs :: Id -> MkStgRhs -> StgRhs
mkStgRhs Id
bndr mk_rhs :: MkStgRhs
mk_rhs@(MkStgRhs [Id]
bndrs StgExpr
rhs Type
typ Bool
is_join)
  -- try to make a StgRhsCon first
  | Just StgRhs
rhs_con <- MkStgRhs -> Maybe StgRhs
mkStgRhsCon_maybe MkStgRhs
mk_rhs
  = StgRhs
rhs_con

  | Bool
otherwise
  = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> Type
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
upd_flag [Id]
[BinderP 'Vanilla]
bndrs StgExpr
rhs Type
typ
  where
    upd_flag :: UpdateFlag
upd_flag | Bool
is_join                             = UpdateFlag
JumpedTo
             | Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs)                    = UpdateFlag
ReEntrant
             | Demand -> Bool
isAtMostOnceDmd (Id -> Demand
idDemandInfo Id
bndr) = UpdateFlag
SingleEntry
             | Bool
otherwise                           = UpdateFlag
Updatable

  {-
    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
    well; and making these into simple non-updatable thunks breaks other
    assumptions (namely that they will be entered only once).

    upd_flag | isPAP env rhs  = ReEntrant
             | otherwise      = Updatable

-- Detect thunks which will reduce immediately to PAPs, and make them
-- non-updatable.  This has several advantages:
--
--         - the non-updatable thunk behaves exactly like the PAP,
--
--         - the thunk is more efficient to enter, because it is
--           specialised to the task.
--
--         - we save one update frame, one stg_update_PAP, one update
--           and lots of PAP_enters.
--
--         - in the case where the thunk is top-level, we save building
--           a black hole and furthermore the thunk isn't considered to
--           be a CAF any more, so it doesn't appear in any SRTs.
--
-- We do it here, because the arity information is accurate, and we need
-- to do it before the SRT pass to save the SRT entries associated with
-- any top-level PAPs.

isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
                              where
                                 arity = stgArity f (lookupBinding env f)
isPAP env _               = False

-}

{- ToDo:
          upd = if isOnceDem dem
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
                     Updatable)
                else Updatable
        -- For now we forbid SingleEntry CAFs; they tickle the
        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
        -- and I don't understand why.  There's only one SE_CAF (well,
        -- only one that tickled a great gaping bug in an earlier attempt
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}


-- | Try to make a non top-level StgRhsCon if appropriate
mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs
mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs
mkStgRhsCon_maybe (MkStgRhs [Id]
bndrs StgExpr
rhs Type
typ Bool
is_join)
  | [] <- [Id]
bndrs
  , Bool -> Bool
not Bool
is_join
  , ([StgTickish]
ticks, StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [[PrimRep]]
_) <- (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) StgExpr
rhs
  = StgRhs -> Maybe StgRhs
forall a. a -> Maybe a
Just (CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> StgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs pass
StgRhsCon CostCentreStack
currentCCS DataCon
con ConstructorNumber
mn [StgTickish]
ticks [StgArg]
args Type
typ)

  | Bool
otherwise = Maybe StgRhs
forall a. Maybe a
Nothing


-- | Try to make a top-level StgRhsCon if appropriate
mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
mkTopStgRhsCon_maybe DataCon -> [StgArg] -> Bool
allow_static_con_app (MkStgRhs [Id]
bndrs StgExpr
rhs Type
typ Bool
is_join)
  | [] <- [Id]
bndrs
  , Bool -> Bool
not Bool
is_join -- shouldn't happen at top-level
  , ([StgTickish]
ticks, StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [[PrimRep]]
_) <- (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) StgExpr
rhs
  , DataCon -> [StgArg] -> Bool
allow_static_con_app DataCon
con [StgArg]
args
  = StgRhs -> Maybe StgRhs
forall a. a -> Maybe a
Just (CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> StgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs pass
StgRhsCon CostCentreStack
dontCareCCS DataCon
con ConstructorNumber
mn [StgTickish]
ticks [StgArg]
args Type
typ)

  | Bool
otherwise = Maybe StgRhs
forall a. Maybe a
Nothing