{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998


This module contains "tidying" code for *nested* expressions, bindings, rules.
The code for *top-level* bindings is in GHC.Iface.Tidy.
-}


module GHC.Core.Tidy (
        tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs
    ) where

import GHC.Prelude

import GHC.Core
import GHC.Core.Type

import GHC.Core.Seq ( seqUnfolding )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand ( zapDmdEnvSig, isStrUsedDmd )
import GHC.Core.Coercion ( tidyCo )
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Unique (getUnique)
import GHC.Types.Unique.FM
import GHC.Types.Name hiding (tidyNameOcc)
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Data.Maybe
import GHC.Utils.Misc
import Data.List (mapAccumL)
import GHC.Utils.Outputable
import GHC.Types.RepType (typePrimRep)
import GHC.Utils.Panic
import GHC.Types.Basic (isMarkedCbv, CbvMark (..))
import GHC.Core.Utils (shouldUseCbvForId)

{-
************************************************************************
*                                                                      *
\subsection{Tidying expressions, rules}
*                                                                      *
************************************************************************
-}

tidyBind :: TidyEnv
         -> CoreBind
         ->  (TidyEnv, CoreBind)

tidyBind :: TidyEnv -> CoreBind -> (TidyEnv, CoreBind)
tidyBind TidyEnv
env (NonRec Id
bndr Expr Id
rhs)
  = -- pprTrace "tidyBindNonRec" (ppr bndr) $
    let cbv_bndr :: Id
cbv_bndr = (HasDebugCallStack => Id -> Expr Id -> Id
Id -> Expr Id -> Id
tidyCbvInfoLocal Id
bndr Expr Id
rhs)
        (TidyEnv
env', Id
bndr') = TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id)
tidyLetBndr TidyEnv
env TidyEnv
env Id
cbv_bndr
        tidy_rhs :: Expr Id
tidy_rhs = (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
rhs)
    in (TidyEnv
env', Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' Expr Id
tidy_rhs)

tidyBind TidyEnv
env (Rec [(Id, Expr Id)]
prs)
  = -- pprTrace "tidyBindRec" (ppr $ map fst prs) $
    let
       cbv_bndrs :: [Id]
cbv_bndrs = ((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ((\(Id
bnd,Expr Id
rhs) -> HasDebugCallStack => Id -> Expr Id -> Id
Id -> Expr Id -> Id
tidyCbvInfoLocal Id
bnd Expr Id
rhs)) [(Id, Expr Id)]
prs
       ([Id]
_bndrs, [Expr Id]
rhss)  = [(Id, Expr Id)] -> ([Id], [Expr Id])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
prs
       (TidyEnv
env', [Id]
bndrs') = (TidyEnv -> Id -> (TidyEnv, Id))
-> TidyEnv -> [Id] -> (TidyEnv, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id)
tidyLetBndr TidyEnv
env') TidyEnv
env [Id]
cbv_bndrs
    in
    (Expr Id -> Expr Id) -> [Expr Id] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env') [Expr Id]
rhss [Expr Id]
-> ([Expr Id] -> (TidyEnv, CoreBind)) -> (TidyEnv, CoreBind)
forall a b. a -> (a -> b) -> b
=: \ [Expr Id]
rhss' ->
    (TidyEnv
env', [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [Expr Id]
rhss'))


-- Note [Attaching CBV Marks to ids]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- See Note [CBV Function Ids] for the *why*.
-- Before tidy, we turn all worker functions into worker like ids.
-- This way we can later tell if we can assume the existence of a wrapper. This also applies to
-- specialized versions of functions generated by SpecConstr for which we, in a sense,
-- consider the unspecialized version to be the wrapper.
-- During tidy we take the demands on the arguments for these ids and compute
-- CBV (call-by-value) semantics for each individual argument.
-- The marks themselves then are put onto the function id itself.
-- This means the code generator can get the full calling convention by only looking at the function
-- itself without having to inspect the RHS.
--
-- The actual logic is in computeCbvInfo and takes:
-- * The function id
-- * The functions rhs
-- And gives us back the function annotated with the marks.
-- We call it in:
-- * tidyTopPair for top level bindings
-- * tidyBind for local bindings.
--
-- Not that we *have* to look at the untidied rhs.
-- During tidying some knot-tying occurs which can blow up
-- if we look at the post-tidy types of the arguments here.
-- However we only care if the types are unlifted and that doesn't change during tidy.
-- so we can just look at the untidied types.
--
-- If the id is boot-exported we don't use a cbv calling convention via marks,
-- as the boot file won't contain them. Which means code calling boot-exported
-- ids might expect these ids to have a vanilla calling convention even if we
-- determine a different one here.
-- To be able to avoid this we pass a set of boot exported ids for this module around.
-- For non top level ids we can skip this. Local ids are never boot-exported
-- as boot files don't have unfoldings. So there this isn't a concern.
-- See also Note [CBV Function Ids]


-- See Note [CBV Function Ids]
tidyCbvInfoTop :: HasDebugCallStack => NameSet -> Id -> CoreExpr -> Id
tidyCbvInfoTop :: HasDebugCallStack => NameSet -> Id -> Expr Id -> Id
tidyCbvInfoTop NameSet
boot_exports Id
id Expr Id
rhs
  -- Can't change calling convention for boot exported things
  | Name -> NameSet -> Bool
elemNameSet (Id -> Name
idName Id
id) NameSet
boot_exports = Id
id
  | Bool
otherwise = HasCallStack => Id -> Expr Id -> Id
Id -> Expr Id -> Id
computeCbvInfo Id
id Expr Id
rhs

-- See Note [CBV Function Ids]
tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id
tidyCbvInfoLocal :: HasDebugCallStack => Id -> Expr Id -> Id
tidyCbvInfoLocal Id
id Expr Id
rhs = HasCallStack => Id -> Expr Id -> Id
Id -> Expr Id -> Id
computeCbvInfo Id
id Expr Id
rhs

-- | For a binding we:
-- * Look at the args
-- * Mark any argument as call-by-value if:
--   - It's argument to a worker and demanded strictly
--   - Unless it's an unlifted type already
-- * Update the id
-- See Note [CBV Function Ids]
-- See Note [Attaching CBV Marks to ids]

computeCbvInfo :: HasCallStack
               => Id            -- The function
               -> CoreExpr      -- It's RHS
               -> Id
-- computeCbvInfo fun_id rhs = fun_id
computeCbvInfo :: HasCallStack => Id -> Expr Id -> Id
computeCbvInfo Id
fun_id Expr Id
rhs
  | Bool
is_wkr_like Bool -> Bool -> Bool
|| Maybe JoinArity -> Bool
forall a. Maybe a -> Bool
isJust Maybe JoinArity
mb_join_id
  , [Id] -> Bool
forall {t :: * -> *}. Foldable t => t Id -> Bool
valid_unlifted_worker [Id]
val_args
  = -- pprTrace "computeCbvInfo"
    --   (text "fun" <+> ppr fun_id $$
    --     text "arg_tys" <+> ppr (map idType val_args) $$

    --     text "prim_rep" <+> ppr (map typePrimRep_maybe $ map idType val_args) $$
    --     text "rrarg" <+> ppr (map isRuntimeVar val_args) $$
    --     text "cbv_marks" <+> ppr cbv_marks $$
    --     text "out_id" <+> ppr cbv_bndr $$
    --     ppr rhs)
    Id
cbv_bndr

  | Bool
otherwise = Id
fun_id
  where
    mb_join_id :: Maybe JoinArity
mb_join_id  = Id -> Maybe JoinArity
isJoinId_maybe Id
fun_id
    is_wkr_like :: Bool
is_wkr_like = Id -> Bool
isWorkerLikeId Id
fun_id

    val_args :: [Id]
val_args = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isId [Id]
lam_bndrs
    -- When computing CbvMarks, we limit the arity of join points to
    -- the JoinArity, because that's the arity we are going to use
    -- when calling it. There may be more lambdas than that on the RHS.
    lam_bndrs :: [Id]
lam_bndrs | Just JoinArity
join_arity <- Maybe JoinArity
mb_join_id
              = ([Id], Expr Id) -> [Id]
forall a b. (a, b) -> a
fst (([Id], Expr Id) -> [Id]) -> ([Id], Expr Id) -> [Id]
forall a b. (a -> b) -> a -> b
$ JoinArity -> Expr Id -> ([Id], Expr Id)
forall b. JoinArity -> Expr b -> ([b], Expr b)
collectNBinders JoinArity
join_arity Expr Id
rhs
              | Bool
otherwise
              = ([Id], Expr Id) -> [Id]
forall a b. (a, b) -> a
fst (([Id], Expr Id) -> [Id]) -> ([Id], Expr Id) -> [Id]
forall a b. (a -> b) -> a -> b
$ Expr Id -> ([Id], Expr Id)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr Id
rhs

    cbv_marks :: [CbvMark]
cbv_marks = -- assert: CBV marks are only set during tidy so none should be present already.
                Bool -> SDoc -> [CbvMark] -> [CbvMark]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> ([CbvMark] -> Bool) -> Maybe [CbvMark] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True [CbvMark] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe [CbvMark] -> Bool) -> Maybe [CbvMark] -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fun_id)
                          (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Maybe [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Maybe [CbvMark] -> SDoc) -> Maybe [CbvMark] -> SDoc
forall a b. (a -> b) -> a -> b
$ Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fun_id) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Id
rhs) ([CbvMark] -> [CbvMark]) -> [CbvMark] -> [CbvMark]
forall a b. (a -> b) -> a -> b
$
                (Id -> CbvMark) -> [Id] -> [CbvMark]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CbvMark
mkMark [Id]
val_args

    cbv_bndr :: Id
cbv_bndr | (CbvMark -> Bool) -> [CbvMark] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CbvMark -> Bool
isMarkedCbv [CbvMark]
cbv_marks
             = [CbvMark]
cbv_marks [CbvMark] -> Id -> Id
forall a b. [a] -> b -> b
`seqList` Id -> [CbvMark] -> Id
setIdCbvMarks Id
fun_id [CbvMark]
cbv_marks
               -- seqList: avoid retaining the original rhs

             | Bool
otherwise
             = -- pprTraceDebug "computeCbvInfo: Worker seems to take unboxed tuple/sum types!"
               --    (ppr fun_id <+> ppr rhs)
               Id -> Id
asNonWorkerLikeId Id
fun_id

    -- We don't set CBV marks on functions which take unboxed tuples or sums as
    -- arguments.  Doing so would require us to compute the result of unarise
    -- here in order to properly determine argument positions at runtime.
    --
    -- In practice this doesn't matter much. Most "interesting" functions will
    -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed
    -- sums are rarely used. But we could change this in the future and support
    -- unboxed sums/tuples as well.
    valid_unlifted_worker :: t Id -> Bool
valid_unlifted_worker t Id
args =
      -- pprTrace "valid_unlifted" (ppr fun_id $$ ppr args) $
      (Id -> Bool) -> t Id -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isSingleUnarisedArg t Id
args

    isSingleUnarisedArg :: Id -> Bool
isSingleUnarisedArg Id
v
      | Type -> Bool
isUnboxedSumType Type
ty = Bool
False
      | Type -> Bool
isUnboxedTupleType Type
ty = [PrimRep] -> Bool
forall a. [a] -> Bool
isSimplePrimRep (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty)
      | Bool
otherwise = [PrimRep] -> Bool
forall a. [a] -> Bool
isSimplePrimRep (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty)
      where
        ty :: Type
ty = Id -> Type
idType Id
v
        isSimplePrimRep :: [a] -> Bool
isSimplePrimRep []  = Bool
True
        isSimplePrimRep [a
_] = Bool
True
        isSimplePrimRep [a]
_   = Bool
False

    mkMark :: Id -> CbvMark
mkMark Id
arg
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Bool
shouldUseCbvForId Id
arg = CbvMark
NotMarkedCbv
      -- We can only safely use cbv for strict arguments
      | (Demand -> Bool
isStrUsedDmd (Id -> Demand
idDemandInfo Id
arg))
      , Bool -> Bool
not (Id -> Bool
isDeadEndId Id
fun_id) = CbvMark
MarkedCbv
      | Bool
otherwise = CbvMark
NotMarkedCbv


------------  Expressions  --------------
tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
tidyExpr :: TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env (Var Id
v)       = Id -> Expr Id
forall b. Id -> Expr b
Var (TidyEnv -> Id -> Id
tidyVarOcc TidyEnv
env Id
v)
tidyExpr TidyEnv
env (Type Type
ty)     = Type -> Expr Id
forall b. Type -> Expr b
Type (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty)
tidyExpr TidyEnv
env (Coercion Coercion
co) = Coercion -> Expr Id
forall b. Coercion -> Expr b
Coercion (TidyEnv -> Coercion -> Coercion
tidyCo TidyEnv
env Coercion
co)
tidyExpr TidyEnv
_   (Lit Literal
lit)     = Literal -> Expr Id
forall b. Literal -> Expr b
Lit Literal
lit
tidyExpr TidyEnv
env (App Expr Id
f Expr Id
a)     = Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
f) (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
a)
tidyExpr TidyEnv
env (Tick CoreTickish
t Expr Id
e)    = CoreTickish -> Expr Id -> Expr Id
forall b. CoreTickish -> Expr b -> Expr b
Tick (TidyEnv -> CoreTickish -> CoreTickish
tidyTickish TidyEnv
env CoreTickish
t) (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
e)
tidyExpr TidyEnv
env (Cast Expr Id
e Coercion
co)   = Expr Id -> Coercion -> Expr Id
forall b. Expr b -> Coercion -> Expr b
Cast (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
e) (TidyEnv -> Coercion -> Coercion
tidyCo TidyEnv
env Coercion
co)

tidyExpr TidyEnv
env (Let CoreBind
b Expr Id
e)
  = TidyEnv -> CoreBind -> (TidyEnv, CoreBind)
tidyBind TidyEnv
env CoreBind
b      (TidyEnv, CoreBind) -> ((TidyEnv, CoreBind) -> Expr Id) -> Expr Id
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', CoreBind
b') ->
    CoreBind -> Expr Id -> Expr Id
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
b' (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
e)

tidyExpr TidyEnv
env (Case Expr Id
e Id
b Type
ty [Alt Id]
alts)
  = TidyEnv -> Id -> (TidyEnv, Id)
tidyBndr TidyEnv
env Id
b  (TidyEnv, Id) -> ((TidyEnv, Id) -> Expr Id) -> Expr Id
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', Id
b) ->
    Expr Id -> Id -> Type -> [Alt Id] -> Expr Id
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env Expr Id
e) Id
b (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty)
         ((Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Alt Id -> Alt Id
tidyAlt TidyEnv
env') [Alt Id]
alts)

tidyExpr TidyEnv
env (Lam Id
b Expr Id
e)
  = TidyEnv -> Id -> (TidyEnv, Id)
tidyBndr TidyEnv
env Id
b      (TidyEnv, Id) -> ((TidyEnv, Id) -> Expr Id) -> Expr Id
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', Id
b) ->
    Id -> Expr Id -> Expr Id
forall b. b -> Expr b -> Expr b
Lam Id
b (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
e)

------------  Case alternatives  --------------
tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt
tidyAlt :: TidyEnv -> Alt Id -> Alt Id
tidyAlt TidyEnv
env (Alt AltCon
con [Id]
vs Expr Id
rhs)
  = TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
env [Id]
vs    (TidyEnv, [Id]) -> ((TidyEnv, [Id]) -> Alt Id) -> Alt Id
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', [Id]
vs) ->
    (AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
vs (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env' Expr Id
rhs))

------------  Tickish  --------------
tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish
tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish
tidyTickish TidyEnv
env (Breakpoint XBreakpoint 'TickishPassCore
ext JoinArity
ix [XTickishId 'TickishPassCore]
ids)
  = XBreakpoint 'TickishPassCore
-> JoinArity -> [XTickishId 'TickishPassCore] -> CoreTickish
forall (pass :: TickishPass).
XBreakpoint pass
-> JoinArity -> [XTickishId pass] -> GenTickish pass
Breakpoint XBreakpoint 'TickishPassCore
ext JoinArity
ix ((Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Id -> Id
tidyVarOcc TidyEnv
env) [Id]
[XTickishId 'TickishPassCore]
ids)
tidyTickish TidyEnv
_   CoreTickish
other_tickish       = CoreTickish
other_tickish

------------  Rules  --------------
tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
_   [] = []
tidyRules TidyEnv
env (CoreRule
rule : [CoreRule]
rules)
  = TidyEnv -> CoreRule -> CoreRule
tidyRule TidyEnv
env CoreRule
rule           CoreRule -> (CoreRule -> [CoreRule]) -> [CoreRule]
forall a b. a -> (a -> b) -> b
=: \ CoreRule
rule ->
    TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
env [CoreRule]
rules         [CoreRule] -> ([CoreRule] -> [CoreRule]) -> [CoreRule]
forall a b. a -> (a -> b) -> b
=: \ [CoreRule]
rules ->
    (CoreRule
rule CoreRule -> [CoreRule] -> [CoreRule]
forall a. a -> [a] -> [a]
: [CoreRule]
rules)

tidyRule :: TidyEnv -> CoreRule -> CoreRule
tidyRule :: TidyEnv -> CoreRule -> CoreRule
tidyRule TidyEnv
_   rule :: CoreRule
rule@(BuiltinRule {}) = CoreRule
rule
tidyRule TidyEnv
env rule :: CoreRule
rule@(Rule { ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
bndrs, ru_args :: CoreRule -> [Expr Id]
ru_args = [Expr Id]
args, ru_rhs :: CoreRule -> Expr Id
ru_rhs = Expr Id
rhs,
                          ru_fn :: CoreRule -> Name
ru_fn = Name
fn, ru_rough :: CoreRule -> [Maybe Name]
ru_rough = [Maybe Name]
mb_ns })
  = TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
env [Id]
bndrs         (TidyEnv, [Id]) -> ((TidyEnv, [Id]) -> CoreRule) -> CoreRule
forall a b. a -> (a -> b) -> b
=: \ (TidyEnv
env', [Id]
bndrs) ->
    (Expr Id -> Expr Id) -> [Expr Id] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
env') [Expr Id]
args    [Expr Id] -> ([Expr Id] -> CoreRule) -> CoreRule
forall a b. a -> (a -> b) -> b
=: \ [Expr Id]
args ->
    CoreRule
rule { ru_bndrs = bndrs, ru_args = args,
           ru_rhs   = tidyExpr env' rhs,
           ru_fn    = tidyNameOcc env fn,
           ru_rough = map (fmap (tidyNameOcc env')) mb_ns }

{-
************************************************************************
*                                                                      *
\subsection{Tidying non-top-level binders}
*                                                                      *
************************************************************************
-}

tidyNameOcc :: TidyEnv -> Name -> Name
-- In rules and instances, we have Names, and we must tidy them too
-- Fortunately, we can lookup in the VarEnv with a name
tidyNameOcc :: TidyEnv -> Name -> Name
tidyNameOcc (TidyOccEnv
_, VarEnv Id
var_env) Name
n = case VarEnv Id -> Unique -> Maybe Id
forall key elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly VarEnv Id
var_env (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
n) of
                                Maybe Id
Nothing -> Name
n
                                Just Id
v  -> Id -> Name
idName Id
v

tidyVarOcc :: TidyEnv -> Var -> Var
tidyVarOcc :: TidyEnv -> Id -> Id
tidyVarOcc (TidyOccEnv
_, VarEnv Id
var_env) Id
v = VarEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Id
var_env Id
v Maybe Id -> Id -> Id
forall a. Maybe a -> a -> a
`orElse` Id
v

-- tidyBndr is used for lambda and case binders
tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyBndr TidyEnv
env Id
var
  | Id -> Bool
isTyCoVar Id
var = TidyEnv -> Id -> (TidyEnv, Id)
tidyVarBndr TidyEnv
env Id
var
  | Bool
otherwise     = TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr TidyEnv
env Id
var

tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyBndrs :: TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
env [Id]
vars = (TidyEnv -> Id -> (TidyEnv, Id))
-> TidyEnv -> [Id] -> (TidyEnv, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL TidyEnv -> Id -> (TidyEnv, Id)
tidyBndr TidyEnv
env [Id]
vars

-- Non-top-level variables, not covars
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr env :: TidyEnv
env@(TidyOccEnv
tidy_env, VarEnv Id
var_env) Id
id
  = -- Do this pattern match strictly, otherwise we end up holding on to
    -- stuff in the OccName.
    case TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName TidyOccEnv
tidy_env (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
id) of { (TidyOccEnv
tidy_env', OccName
occ') ->
    let
        -- Give the Id a fresh print-name, *and* rename its type
        -- The SrcLoc isn't important now,
        -- though we could extract it from the Id
        --
        ty' :: Type
ty'      = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Id -> Type
idType Id
id)
        mult' :: Type
mult'    = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Id -> Type
idMult Id
id)
        name' :: Name
name'    = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Id -> Unique
idUnique Id
id) OccName
occ' SrcSpan
noSrcSpan
        id' :: Id
id'      = HasDebugCallStack => Name -> Type -> Type -> IdInfo -> Id
Name -> Type -> Type -> IdInfo -> Id
mkLocalIdWithInfo Name
name' Type
mult' Type
ty' IdInfo
new_info
        var_env' :: VarEnv Id
var_env' = VarEnv Id -> Id -> Id -> VarEnv Id
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv Id
var_env Id
id Id
id'

        -- Note [Tidy IdInfo]
        new_info :: IdInfo
new_info = IdInfo
vanillaIdInfo IdInfo -> OccInfo -> IdInfo
`setOccInfo` IdInfo -> OccInfo
occInfo IdInfo
old_info
                                 IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unf
                                  -- see Note [Preserve OneShotInfo]
                                 IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo` IdInfo -> OneShotInfo
oneShotInfo IdInfo
old_info
        old_info :: IdInfo
old_info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
        old_unf :: Unfolding
old_unf  = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
old_info
        new_unf :: Unfolding
new_unf  = Unfolding -> Unfolding
trimUnfolding Unfolding
old_unf  -- See Note [Preserve evaluatedness]
    in
    ((TidyOccEnv
tidy_env', VarEnv Id
var_env'), Id
id')
   }

tidyLetBndr :: TidyEnv         -- Knot-tied version for unfoldings
            -> TidyEnv         -- The one to extend
            -> Id -> (TidyEnv, Id)
-- Used for local (non-top-level) let(rec)s
-- Just like tidyIdBndr above, but with more IdInfo
tidyLetBndr :: TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id)
tidyLetBndr TidyEnv
rec_tidy_env env :: TidyEnv
env@(TidyOccEnv
tidy_env, VarEnv Id
var_env) Id
id
  = case TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName TidyOccEnv
tidy_env (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
id) of { (TidyOccEnv
tidy_env', OccName
occ') ->
    let
        ty' :: Type
ty'      = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Id -> Type
idType Id
id)
        mult' :: Type
mult'    = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Id -> Type
idMult Id
id)
        name' :: Name
name'    = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Id -> Unique
idUnique Id
id) OccName
occ' SrcSpan
noSrcSpan
        details :: IdDetails
details  = Id -> IdDetails
idDetails Id
id
        id' :: Id
id'      = IdDetails -> Name -> Type -> Type -> IdInfo -> Id
mkLocalVar IdDetails
details Name
name' Type
mult' Type
ty' IdInfo
new_info
        var_env' :: VarEnv Id
var_env' = VarEnv Id -> Id -> Id -> VarEnv Id
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv Id
var_env Id
id Id
id'

        -- Note [Tidy IdInfo]
        -- We need to keep around any interesting strictness and
        -- demand info because later on we may need to use it when
        -- converting to A-normal form.
        -- eg.
        --      f (g x),  where f is strict in its argument, will be converted
        --      into  case (g x) of z -> f z  by CorePrep, but only if f still
        --      has its strictness info.
        --
        -- Similarly for the demand info - on a let binder, this tells
        -- CorePrep to turn the let into a case.
        -- But: Remove the usage demand here
        --      (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Opt.WorkWrap)
        --
        -- Similarly arity info for eta expansion in CorePrep
        -- Don't attempt to recompute arity here; this is just tidying!
        -- Trying to do so led to #17294
        --
        -- Set inline-prag info so that we preserve it across
        -- separate compilation boundaries
        old_info :: IdInfo
old_info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
        new_info :: IdInfo
new_info = IdInfo
vanillaIdInfo
                    IdInfo -> OccInfo -> IdInfo
`setOccInfo`        IdInfo -> OccInfo
occInfo IdInfo
old_info
                    IdInfo -> JoinArity -> IdInfo
`setArityInfo`      IdInfo -> JoinArity
arityInfo IdInfo
old_info
                    IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo`     DmdSig -> DmdSig
zapDmdEnvSig (IdInfo -> DmdSig
dmdSigInfo IdInfo
old_info)
                    IdInfo -> Demand -> IdInfo
`setDemandInfo`     IdInfo -> Demand
demandInfo IdInfo
old_info
                    IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` IdInfo -> InlinePragma
inlinePragInfo IdInfo
old_info
                    IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  Unfolding
new_unf

        old_unf :: Unfolding
old_unf = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
old_info
        new_unf :: Unfolding
new_unf = TidyEnv -> Unfolding -> Unfolding
tidyNestedUnfolding TidyEnv
rec_tidy_env Unfolding
old_unf

    in
    ((TidyOccEnv
tidy_env', VarEnv Id
var_env'), Id
id') }

------------ Unfolding  --------------
tidyNestedUnfolding :: TidyEnv -> Unfolding -> Unfolding
tidyNestedUnfolding :: TidyEnv -> Unfolding -> Unfolding
tidyNestedUnfolding TidyEnv
_ Unfolding
NoUnfolding   = Unfolding
NoUnfolding
tidyNestedUnfolding TidyEnv
_ Unfolding
BootUnfolding = Unfolding
BootUnfolding
tidyNestedUnfolding TidyEnv
_ (OtherCon {}) = Unfolding
evaldUnfolding

tidyNestedUnfolding TidyEnv
tidy_env df :: Unfolding
df@(DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_args :: Unfolding -> [Expr Id]
df_args = [Expr Id]
args })
  = Unfolding
df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
  where
    (TidyEnv
tidy_env', [Id]
bndrs') = TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
tidy_env [Id]
bndrs

tidyNestedUnfolding TidyEnv
tidy_env
    unf :: Unfolding
unf@(CoreUnfolding { uf_tmpl :: Unfolding -> Expr Id
uf_tmpl = Expr Id
unf_rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_cache :: Unfolding -> UnfoldingCache
uf_cache = UnfoldingCache
cache })
  | UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
  = Unfolding -> Unfolding
seqIt (Unfolding -> Unfolding) -> Unfolding -> Unfolding
forall a b. (a -> b) -> a -> b
$ Unfolding
unf { uf_tmpl = tidyExpr tidy_env unf_rhs }    -- Preserves OccInfo
            -- This seqIt avoids a space leak: otherwise the uf_cache
            -- field may retain a reference to the pre-tidied
            -- expression forever (GHC.CoreToIface doesn't look at
            -- them)

  -- Discard unstable unfoldings, but see Note [Preserve evaluatedness]
  | UnfoldingCache -> Bool
uf_is_value UnfoldingCache
cache = Unfolding
evaldUnfolding
  | Bool
otherwise = Unfolding
noUnfolding

  where
    seqIt :: Unfolding -> Unfolding
seqIt Unfolding
unf = Unfolding -> ()
seqUnfolding Unfolding
unf () -> Unfolding -> Unfolding
forall a b. a -> b -> b
`seq` Unfolding
unf

{-
Note [Tidy IdInfo]
~~~~~~~~~~~~~~~~~~
All nested Ids now have the same IdInfo, namely vanillaIdInfo, which
should save some space; except that we preserve occurrence info for
two reasons:

  (a) To make printing tidy core nicer

  (b) Because we tidy RULES and unfoldings, which may then propagate
      via --make into the compilation of the next module, and we want
      the benefit of that occurrence analysis when we use the rule or
      or inline the function.  In particular, it's vital not to lose
      loop-breaker info, else we get an infinite inlining loop

Note that tidyLetBndr puts more IdInfo back.

Note [Preserve evaluatedness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data T = MkT !Bool
  ....(case v of MkT y ->
       let z# = case y of
                  True -> 1#
                  False -> 2#
       in ...)

The z# binding is ok because the RHS is ok-for-speculation,
but Lint will complain unless it can *see* that.  So we
preserve the evaluated-ness on 'y' in tidyBndr.

(Another alternative would be to tidy unboxed lets into cases,
but that seems more indirect and surprising.)

Note [Preserve OneShotInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We keep the OneShotInfo because we want it to propagate into the interface.
Not all OneShotInfo is determined by a compiler analysis; some is added by a
call of GHC.Exts.oneShot, which is then discarded before the end of the
optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we
must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make.

This applies to lambda binders only, hence it is stored in IfaceLamBndr.
-}

(=:) :: a -> (a -> b) -> b
a
m =: :: forall a b. a -> (a -> b) -> b
=: a -> b
k = a
m a -> b -> b
forall a b. a -> b -> b
`seq` a -> b
k a
m