{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

{-
(c) The University of Glasgow, 1994-2006


Core pass to saturate constructors and PrimOps
-}

module GHC.CoreToStg.Prep
   ( CorePrepConfig (..)
   , CorePrepPgmConfig (..)
   , corePrepPgm
   , corePrepExpr
   )
where

import GHC.Prelude

import GHC.Platform

import GHC.Driver.Flags

import GHC.Unit

import GHC.Builtin.Names
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim

import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.Lint    ( EndPassConfig(..), endPassIO )
import GHC.Core
import GHC.Core.Subst
import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal

import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.FastString
import GHC.Data.Graph.UnVar

import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Utils.Monad  ( mapAccumLM )
import GHC.Utils.Logger

import GHC.Types.Demand
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Types.Basic
import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import GHC.Types.Literal
import GHC.Types.Tickish
import GHC.Types.Unique.Supply

import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import Data.ByteString.Builder.Prim

import Control.Monad

{-
Note [CorePrep Overview]
~~~~~~~~~~~~~~~~~~~~~~~~

The goal of this pass is to prepare for code generation.

1.  Saturate constructor and primop applications.

2.  Convert to A-normal form; that is, function arguments
    are always variables.

    * Use case for strict arguments:
        f E ==> case E of x -> f x
        (where f is strict)

    * Use let for non-trivial lazy arguments
        f E ==> let x = E in f x
        (were f is lazy and x is non-trivial)

3.  Similarly, convert any unboxed lets into cases.
    [I'm experimenting with leaving 'ok-for-speculation'
     rhss in let-form right up to this point.]

4.  Ensure that *value* lambdas only occur as the RHS of a binding
    (The code generator can't deal with anything else.)
    Type lambdas are ok, however, because the code gen discards them.

5.  ANF-isation results in additional bindings that can obscure values.
    We float these out; see Note [Floating in CorePrep].

6.  Clone all local Ids.  See Note [Cloning in CorePrep]

7.  Give each dynamic CCall occurrence a fresh unique; this is
    rather like the cloning step above.

8.  Inject bindings for the "implicit" Ids:
        * Constructor wrappers
        * Constructor workers
    We want curried definitions for all of these in case they
    aren't inlined by some caller.

 9. Convert bignum literals into their core representation.

10. Uphold tick consistency while doing this: We move ticks out of
    (non-type) applications where we can, and make sure that we
    annotate according to scoping rules when floating.

11. Collect cost centres (including cost centres in unfoldings) if we're in
    profiling mode. We have to do this here because we won't have unfoldings
    after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].

12. Eliminate some magic Ids, specifically
     runRW# (\s. e)  ==>  e[readWorldId/s]
             lazy e  ==>  e (see Note [lazyId magic] in GHC.Types.Id.Make)
         noinline e  ==>  e
           nospec e  ==>  e
     ToDo:  keepAlive# ...
    This is done in cpeApp

This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.

Note [CorePrep invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Here is the syntax of the Core produced by CorePrep:

    Trivial expressions
       arg ::= lit     |  var
            |  arg ty  |  /\a. arg
            |  co      |  arg |> co

    Applications
       app ::= lit  |  var  |  app arg  |  app ty  |  app co  |  app |> co

    Expressions
       body ::= app
             |  let(rec) x = rhs in body     -- Boxed only
             |  case body of pat -> body
             |  /\a. body | /\c. body
             |  body |> co

    Right hand sides (only place where value lambdas can occur)
       rhs ::= /\a.rhs  |  \x.rhs  |  body

We define a synonym for each of these non-terminals.  Functions
with the corresponding name produce a result in that syntax.

Note [Cloning in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~
In CorePrep we
* Always clone non-CoVar Ids, so each has a unique Unique
* Sometimes clone CoVars and TyVars

We always clone non-CoVarIds, for three reasons

1. Things associated with labels in the final code must be truly unique in
   order to avoid labels being shadowed in the final output.

2. Even binders without info tables like function arguments or alternative
   bound binders must be unique at least in their type/unique combination.
   We only emit a single declaration for each binder when compiling to C
   so if binders are not unique we would either get duplicate declarations
   or misstyped variables. The later happend in #22402.

3. We heavily use unique-keyed maps in the backend which can go wrong when
   ids with the same unique are meant to represent the same variable.

Generally speaking we don't clone TyVars or CoVars. The code gen doesn't need
that (they are erased), and doing so would be tiresome because then we'd need
to substitute in types and coercions.  But sometimes need to: see
Note [Cloning CoVars and TyVars]

Note [Cloning CoVars and TyVars]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Normally we don't need to clone TyVars and CoVars, but there is one occasion
when we do (see #24463).  When we have
    case unsafeEqualityProof ... of UnsafeRefl g -> ...
we try to float it, using UnsafeEqualityCase.
Why?  See (U3) in Note [Implementing unsafeCoerce]

Alas, floating it widens the scope of `g`, and that led to catastrophe in
#24463, when two identically-named g's shadowed.

Solution: clone `g`; see `cpCloneCoVarBndr`.

BUT once we clone `g` we must apply the cloning substitution to all types
and coercions.  But that in turn means that, given a binder like
   /\ (a :: kind |> g). blah
we must substitute in a's kind, and hence need to substitute for `a`
itself in `blah`.

So our plan is:
  * Maintain a full Subst in `cpe_subst`

  * Clone a CoVar when we we meet an `isUnsafeEqualityCase`;
    otherwise TyVar/CoVar binders are never cloned.

  * So generally the TCvSubst is empty

  * Apply the substitution to type and coercion arguments in Core; but
    happily `substTy` has a no-op short-cut for an empty TCvSubst, so this
    is usually very cheap.

  * In `cpCloneBndr`, for a tyvar/covar binder, check for an empty substitution;
    in that case just do nothing
-}

type CpeArg  = CoreExpr    -- Non-terminal 'arg'
type CpeApp  = CoreExpr    -- Non-terminal 'app'
type CpeBody = CoreExpr    -- Non-terminal 'body'
type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'

{-
************************************************************************
*                                                                      *
                Top level stuff
*                                                                      *
************************************************************************
-}

data CorePrepPgmConfig = CorePrepPgmConfig
  { CorePrepPgmConfig -> EndPassConfig
cpPgm_endPassConfig     :: !EndPassConfig
  , CorePrepPgmConfig -> Bool
cpPgm_generateDebugInfo :: !Bool
  }

corePrepPgm :: Logger
            -> CorePrepConfig
            -> CorePrepPgmConfig
            -> Module -> ModLocation -> CoreProgram -> [TyCon]
            -> IO CoreProgram
corePrepPgm :: Logger
-> CorePrepConfig
-> CorePrepPgmConfig
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm Logger
logger CorePrepConfig
cp_cfg CorePrepPgmConfig
pgm_cfg
            Module
this_mod ModLocation
mod_loc CoreProgram
binds [TyCon]
data_tycons =
    Logger
-> SDoc -> (CoreProgram -> ()) -> IO CoreProgram -> IO CoreProgram
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CorePrep"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
               (\CoreProgram
a -> CoreProgram
a CoreProgram -> () -> ()
forall a b. [a] -> b -> b
`seqList` ()) (IO CoreProgram -> IO CoreProgram)
-> IO CoreProgram -> IO CoreProgram
forall a b. (a -> b) -> a -> b
$ do
    us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
    let initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
cp_cfg

    let
        implicit_binds = Bool -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers
          (CorePrepPgmConfig -> Bool
cpPgm_generateDebugInfo CorePrepPgmConfig
pgm_cfg)
          ModLocation
mod_loc [TyCon]
data_tycons
            -- NB: we must feed mkImplicitBinds through corePrep too
            -- so that they are suitably cloned and eta-expanded

        binds_out = UniqSupply -> UniqSM CoreProgram -> CoreProgram
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM CoreProgram -> CoreProgram)
-> UniqSM CoreProgram -> CoreProgram
forall a b. (a -> b) -> a -> b
$ do
                      floats1 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
binds
                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
                      return (deFloatTop (floats1 `zipFloats` floats2))

    endPassIO logger (cpPgm_endPassConfig pgm_cfg)
              binds_out []
    return binds_out

corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr
corePrepExpr :: Logger -> CorePrepConfig -> CpeRhs -> IO CpeRhs
corePrepExpr Logger
logger CorePrepConfig
config CpeRhs
expr = do
    Logger -> SDoc -> (CpeRhs -> ()) -> IO CpeRhs -> IO CpeRhs
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CorePrep [expr]") (\CpeRhs
e -> CpeRhs
e CpeRhs -> () -> ()
forall a b. a -> b -> b
`seq` ()) (IO CpeRhs -> IO CpeRhs) -> IO CpeRhs -> IO CpeRhs
forall a b. (a -> b) -> a -> b
$ do
      us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
      let initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
config
      let new_expr = UniqSupply -> UniqSM CpeRhs -> CpeRhs
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (CorePrepEnv -> CpeRhs -> UniqSM CpeRhs
cpeBodyNF CorePrepEnv
initialCorePrepEnv CpeRhs
expr)
      putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)
      return new_expr

corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
-- Note [Floating out of top level bindings]
corePrepTopBinds :: CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
binds
  = CorePrepEnv -> CoreProgram -> UniqSM Floats
go CorePrepEnv
initialCorePrepEnv CoreProgram
binds
  where
    go :: CorePrepEnv -> CoreProgram -> UniqSM Floats
go CorePrepEnv
_   []             = Floats -> UniqSM Floats
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return Floats
emptyFloats
    go CorePrepEnv
env (CoreBind
bind : CoreProgram
binds) = do (env', floats, maybe_new_bind)
                                 <- TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
TopLevel CorePrepEnv
env CoreBind
bind
                               massert (isNothing maybe_new_bind)
                                 -- Only join points get returned this way by
                                 -- cpeBind, and no join point may float to top
                               floatss <- go env' binds
                               return (floats `zipFloats` floatss)

mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind]
-- See Note [Data constructor workers]
-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy
mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers Bool
generate_debug_info ModLocation
mod_loc [TyCon]
data_tycons
  = [ InVar -> CpeRhs -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
id (Name -> CpeRhs -> CpeRhs
tick_it (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con) (InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
id))
                                -- The ice is thin here, but it works
    | TyCon
tycon <- [TyCon]
data_tycons,     -- CorePrep will eta-expand it
      DataCon
data_con <- TyCon -> [DataCon]
tyConDataCons TyCon
tycon,
      let id :: InVar
id = DataCon -> InVar
dataConWorkId DataCon
data_con
    ]
 where
   -- If we want to generate debug info, we put a source note on the
   -- worker. This is useful, especially for heap profiling.
   tick_it :: Name -> CpeRhs -> CpeRhs
tick_it Name
name
     | Bool -> Bool
not Bool
generate_debug_info               = CpeRhs -> CpeRhs
forall a. a -> a
id
     | RealSrcSpan RealSrcSpan
span Maybe BufSpan
_ <- Name -> SrcSpan
nameSrcSpan Name
name = RealSrcSpan -> CpeRhs -> CpeRhs
tick RealSrcSpan
span
     | Just String
file <- ModLocation -> Maybe String
ml_hs_file ModLocation
mod_loc       = RealSrcSpan -> CpeRhs -> CpeRhs
tick (String -> RealSrcSpan
span1 String
file)
     | Bool
otherwise                             = RealSrcSpan -> CpeRhs -> CpeRhs
tick (String -> RealSrcSpan
span1 String
"???")
     where tick :: RealSrcSpan -> CpeRhs -> CpeRhs
tick RealSrcSpan
span  = CoreTickish -> CpeRhs -> CpeRhs
forall b. CoreTickish -> Expr b -> Expr b
Tick (CoreTickish -> CpeRhs -> CpeRhs)
-> CoreTickish -> CpeRhs -> CpeRhs
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> LexicalFastString -> CoreTickish
forall (pass :: TickishPass).
RealSrcSpan -> LexicalFastString -> GenTickish pass
SourceNote RealSrcSpan
span (LexicalFastString -> CoreTickish)
-> LexicalFastString -> CoreTickish
forall a b. (a -> b) -> a -> b
$
             FastString -> LexicalFastString
LexicalFastString (FastString -> LexicalFastString)
-> FastString -> LexicalFastString
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
           span1 :: String -> RealSrcSpan
span1 String
file = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
file) Int
1 Int
1

{- Note [Floating in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ANFisation risks producing a lot of nested lets that obscures values:
  let v = (:) (f 14) [] in e
  ==> { ANF in CorePrep }
  let v = let sat = f 14 in (:) sat [] in e
Here, `v` is not a value anymore, and we'd allocate a thunk closure for `v` that
allocates a thunk for `sat` and then allocates the cons cell.
Hence we carry around a bunch of floated bindings with us so that we again
expose the values:
  let v = let sat = f 14 in (:) sat [] in e
  ==> { Float sat }
  let sat = f 14 in
  let v = (:) sat [] in e
(We will not do this transformation if `v` does not become a value afterwards;
see Note [wantFloatLocal].)
If `v` is bound at the top-level, we might even float `sat` to top-level;
see Note [Floating out of top level bindings].
For nested let bindings, we have to keep in mind Note [Core letrec invariant]
and may exploit strict contexts; see Note [wantFloatLocal].

There are 3 main categories of floats, encoded in the `FloatingBind` type:

  * `Float`: A floated binding, as `sat` above.
    These come in different flavours as described by their `FloatInfo` and
    `BindInfo`, which captures how far the binding can be floated and whether or
    not we want to case-bind. See Note [BindInfo and FloatInfo].
  * `UnsafeEqualityCase`: Used for floating around unsafeEqualityProof bindings;
    see (U3) of Note [Implementing unsafeCoerce].
    It's exactly a `Float` that is `CaseBound` and `LazyContextFloatable`
    (see `mkNonRecFloat`), but one that has a non-DEFAULT Case alternative to
    bind the unsafe coercion field of the Refl constructor.
  * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep].

It is quite essential that CorePrep *does not* rearrange the order in which
evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers
the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does
not attempt to reorder the telescope of Floats or float out out of non-floated
binding sites (such as Case alts) in the first place; for that it would have to
do some kind of data dependency analysis.

Note [Floating out of top level bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NB: we do need to float out of top-level bindings
Consider        x = length [True,False]
We want to get
                s1 = False : []
                s2 = True  : s1
                x  = length s2

We return a *list* of bindings, because we may start with
        x* = f (g y)
where x is demanded, in which case we want to finish with
        a = g y
        x* = f a
And then x will actually end up case-bound

Note [Join points and floating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Join points can float out of other join points but not out of value bindings:

  let z =
    let  w = ... in -- can float
    join k = ... in -- can't float
    ... jump k ...
  join j x1 ... xn =
    let  y = ... in -- can float (but don't want to)
    join h = ... in -- can float (but not much point)
    ... jump h ...
  in ...

Here, the jump to h remains valid if h is floated outward, but the jump to k
does not.

We don't float *out* of join points. It would only be safe to float out of
nullary join points (or ones where the arguments are all either type arguments
or dead binders). Nullary join points aren't ever recursive, so they're always
effectively one-shot functions, which we don't float out of. We *could* float
join points from nullary join points, but there's no clear benefit at this
stage.

Note [Data constructor workers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Create any necessary "implicit" bindings for data con workers.  We
create the rather strange (non-recursive!) binding

        $wC = \x y -> $wC x y

i.e. a curried constructor that allocates.  This means that we can
treat the worker for a constructor like any other function in the rest
of the compiler.  The point here is that CoreToStg will generate a
StgConApp for the RHS, rather than a call to the worker (which would
give a loop).  As Lennart says: the ice is thin here, but it works.

Hmm.  Should we create bindings for dictionary constructors?  They are
always fully applied, and the bindings are just there to support
partial applications. But it's easier to let them through.


Note [Dead code in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Imagine that we got an input program like this (see #4962):

  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
  f x = (g True (Just x) + g () (Just x), g)
    where
      g :: Show a => a -> Maybe Int -> Int
      g _ Nothing = x
      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown

After specialisation and SpecConstr, we would get something like this:

  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
    where
      {-# RULES g $dBool = g$Bool
                g $dUnit = g$Unit #-}
      g = ...
      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
      g$Bool = ...
      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
      g$Unit = ...
      g$Bool_True_Just = ...
      g$Unit_Unit_Just = ...

Note that the g$Bool and g$Unit functions are actually dead code: they
are only kept alive by the occurrence analyser because they are
referred to by the rules of g, which is being kept alive by the fact
that it is used (unspecialised) in the returned pair.

However, at the CorePrep stage there is no way that the rules for g
will ever fire, and it really seems like a shame to produce an output
program that goes to the trouble of allocating a closure for the
unreachable g$Bool and g$Unit functions.

The way we fix this is to:
 * In cloneBndr, drop all unfoldings/rules

 * In deFloatTop, run a simple dead code analyser on each top-level
   RHS to drop the dead local bindings.

The reason we don't just OccAnal the whole output of CorePrep is that
the tidier ensures that all top-level binders are GlobalIds, so they
don't show up in the free variables any longer. So if you run the
occurrence analyser on the output of CoreTidy (or later) you e.g. turn
this program:

  Rec {
  f = ... f ...
  }

Into this one:

  f = ... f ...

(Since f is not considered to be free in its own RHS.)


Note [keepAlive# magic]
~~~~~~~~~~~~~~~~~~~~~~~
When interacting with foreign code, it is often necessary for the user to
extend the lifetime of a heap object beyond the lifetime that would be apparent
from the on-heap references alone. For instance, a program like:

  foreign import safe "hello" hello :: ByteArray# -> IO ()

  callForeign :: IO ()
  callForeign = IO $ \s0 ->
    case newByteArray# n# s0 of (# s1, barr #) ->
      unIO hello barr s1

As-written this program is susceptible to memory-unsafety since there are
no references to `barr` visible to the garbage collector. Consequently, if a
garbage collection happens during the execution of the C function `hello`, it
may be that the array is freed while in use by the foreign function.

To address this, we introduced a new primop, keepAlive#, which "scopes over"
the computation needing the kept-alive value:

  keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b).
                a -> State# RealWorld -> (State# RealWorld -> b) -> b

When entered, an application (keepAlive# x s k) will apply `k` to the state
token, evaluating it to WHNF. However, during the course of this evaluation
will *guarantee* that `x` is considered to be alive.

There are a few things to note here:

 - we are RuntimeRep-polymorphic in the value to be kept-alive. This is
   necessary since we will often (but not always) be keeping alive something
   unlifted (like a ByteArray#)

 - we are RuntimeRep-polymorphic in the result value since the result may take
   many forms (e.g. a boxed value, a raw state token, or a (# State s, result #).

We implement this operation by desugaring to touch# during CorePrep (see
GHC.CoreToStg.Prep.cpeApp). Specifically,

  keepAlive# x s0 k

is transformed to:

  case k s0 of r ->
  case touch# x realWorld# of s1 ->
    r

Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a
pointer to `x` and entering `k s0`. This compilation strategy is safe
because we do no optimization on STG that would drop or re-order the
continuation containing the `touch#`. However, if we were to become more
aggressive in our STG pipeline then we would need to revisit this.

Beyond this CorePrep transformation, there is very little special about
keepAlive#. However, we did explore (and eventually gave up on)
an optimisation which would allow unboxing of constructed product results,
which we describe below.


Lost optimisation: CPR unboxing
--------------------------------
One unfortunate property of this approach is that the simplifier is unable to
unbox the result of a keepAlive# expression. For instance, consider the program:

  case keepAlive# arr s0 (
         \s1 -> case peekInt arr s1 of
                  (# s2, r #) -> I# r
  ) of
    I# x -> ...

This is a surprisingly common pattern, previously used, e.g., in
GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around
with optimising this away by pushing strict contexts (like the
`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can
recover unboxing, it can also unfortunately in general change the asymptotic
memory (namely stack) behavior of the program. For instance, consider

  writeN =
    ...
      case keepAlive# x s0 (\s1 -> something s1) of
        (# s2, x #) ->
          writeN ...

As it is tail-recursive, this program will run in constant space. However, if
we push outer case into the continuation we get:

  writeN =

      case keepAlive# x s0 (\s1 ->
        case something s1 of
          (# s2, x #) ->
            writeN ...
      ) of
        ...

Which ends up building a stack which is linear in the recursion depth. For this
reason, we ended up giving up on this optimisation.


Historical note: touch# and its inadequacy
------------------------------------------
Prior to the introduction of `keepAlive#` we instead addressed the need for
lifetime extension with the `touch#` primop:

    touch# :: a -> State# s -> State# s

This operation would ensure that the `a` value passed as the first argument was
considered "alive" at the time the primop application is entered.

For instance, the user might modify `callForeign` as:

  callForeign :: IO ()
  callForeign s0 = IO $ \s0 ->
    case newByteArray# n# s0 of (# s1, barr #) ->
    case unIO hello barr s1 of (# s2, () #) ->
    case touch# barr s2 of s3 ->
      (# s3, () #)

However, in #14346 we discovered that this primop is insufficient in the
presence of simplification. For instance, consider a program like:

  callForeign :: IO ()
  callForeign s0 = IO $ \s0 ->
    case newByteArray# n# s0 of (# s1, barr #) ->
    case unIO (forever $ hello barr) s1 of (# s2, () #) ->
    case touch# barr s2 of s3 ->
      (# s3, () #)

In this case the Simplifier may realize that (forever $ hello barr)
will never return and consequently that the `touch#` that follows is dead code.
As such, it will be dropped, resulting in memory unsoundness.
This unsoundness lead to the introduction of keepAlive#.



Other related tickets:

 - #15544
 - #17760
 - #14375
 - #15260
 - #18061

************************************************************************
*                                                                      *
                The main code
*                                                                      *
************************************************************************
-}

cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
        -> UniqSM (CorePrepEnv,
                   Floats,         -- Floating value bindings
                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float
                                   -- Nothing <=> added bind' to floats instead
cpeBind :: TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (NonRec InVar
bndr CpeRhs
rhs)
  | Bool -> Bool
not (InVar -> Bool
isJoinId InVar
bndr)
  = do { (env1, bndr1) <- CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneBndr CorePrepEnv
env InVar
bndr
       ; let dmd         = InVar -> Demand
idDemandInfo InVar
bndr
             is_unlifted = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (InVar -> Type
idType InVar
bndr)
       ; (floats, rhs1) <- cpePair top_lvl NonRecursive
                                   dmd is_unlifted
                                   env bndr1 rhs
       -- See Note [Inlining in CorePrep]
       ; let triv_rhs = CpeRhs -> Bool
exprIsTrivial CpeRhs
rhs1
             env2    | Bool
triv_rhs  = CorePrepEnv -> InVar -> CpeRhs -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
env1 InVar
bndr CpeRhs
rhs1
                     | Bool
otherwise = CorePrepEnv
env1
             floats1 | Bool
triv_rhs, Name -> Bool
isInternalName (InVar -> Name
idName InVar
bndr)
                     = Floats
floats
                     | Bool
otherwise
                     = Floats -> FloatingBind -> Floats
snocFloat Floats
floats FloatingBind
new_float

             new_float = CorePrepEnv -> Bool -> InVar -> CpeRhs -> FloatingBind
mkNonRecFloat CorePrepEnv
env Bool
is_unlifted InVar
bndr1 CpeRhs
rhs1

       ; return (env2, floats1, Nothing) }

  | Bool
otherwise -- A join point; see Note [Join points and floating]
  = Bool
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl)) (UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
 -> UniqSM (CorePrepEnv, Floats, Maybe CoreBind))
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a b. (a -> b) -> a -> b
$ -- can't have top-level join point
    do { (_, bndr1) <- CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneBndr CorePrepEnv
env InVar
bndr
       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
       ; return (extendCorePrepEnv env bndr bndr2,
                 emptyFloats,
                 Just (NonRec bndr2 rhs1)) }

cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (Rec [(InVar, CpeRhs)]
pairs)
  | Bool -> Bool
not (InVar -> Bool
isJoinId ([InVar] -> InVar
forall a. HasCallStack => [a] -> a
head [InVar]
bndrs))
  = do { (env, bndrs1) <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bndrs
       ; let env' = CorePrepEnv -> [InVar] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [InVar]
bndrs1
       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
                           bndrs1 rhss

       ; let (zipManyFloats -> floats, rhss1) = unzip stuff
             -- Glom all floats into the Rec, *except* FloatStrings; see
             -- see Note [ANF-ising literal string arguments], Wrinkle (FS1)
             is_lit (Float (NonRec InVar
_ CpeRhs
rhs) BindInfo
CaseBound FloatInfo
TopLvlFloatable) = CpeRhs -> Bool
exprIsTickedString CpeRhs
rhs
             is_lit FloatingBind
_                                                = Bool
False
             (string_floats, top) = partitionOL is_lit (fs_binds floats)
                 -- Strings will *always* be in `top_floats` (we made sure of
                 -- that in `snocOL`), so that's the only field we need to
                 -- partition.
             floats'   = Floats
floats { fs_binds = top }
             all_pairs = (FloatingBind -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)])
-> [(InVar, CpeRhs)] -> OrdList FloatingBind -> [(InVar, CpeRhs)]
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
add_float ([InVar]
bndrs1 [InVar] -> [CpeRhs] -> [(InVar, CpeRhs)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CpeRhs]
rhss1) (Floats -> OrdList FloatingBind
getFloats Floats
floats')
       -- use env below, so that we reset cpe_rec_ids
       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
                 snocFloat (emptyFloats { fs_binds = string_floats })
                           (Float (Rec all_pairs) LetBound TopLvlFloatable),
                 Nothing) }

  | Bool
otherwise -- See Note [Join points and floating]
  = do { (env, bndrs1) <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bndrs
       ; let env' = CorePrepEnv -> [InVar] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [InVar]
bndrs1
       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss

       ; let bndrs2 = ((InVar, CpeRhs) -> InVar) -> [(InVar, CpeRhs)] -> [InVar]
forall a b. (a -> b) -> [a] -> [b]
map (InVar, CpeRhs) -> InVar
forall a b. (a, b) -> a
fst [(InVar, CpeRhs)]
pairs1
       -- use env below, so that we reset cpe_rec_ids
       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
                 emptyFloats,
                 Just (Rec pairs1)) }
  where
    ([InVar]
bndrs, [CpeRhs]
rhss) = [(InVar, CpeRhs)] -> ([InVar], [CpeRhs])
forall a b. [(a, b)] -> ([a], [b])
unzip [(InVar, CpeRhs)]
pairs

    -- Flatten all the floats, and the current
    -- group into a single giant Rec
    add_float :: FloatingBind -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
add_float (Float CoreBind
bind BindInfo
bound FloatInfo
_) [(InVar, CpeRhs)]
prs2
      | BindInfo
bound BindInfo -> BindInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= BindInfo
CaseBound
      Bool -> Bool -> Bool
|| (InVar -> Bool) -> [InVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (InVar -> Bool) -> InVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Type -> Bool) -> (InVar -> Type) -> InVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InVar -> Type
idType) (CoreBind -> [InVar]
forall b. Bind b -> [b]
bindersOf CoreBind
bind)
           -- The latter check is hit in -O0 (i.e., flavours quick, devel2)
           -- for dictionary args which haven't been floated out yet, #24102.
           -- They are preferably CaseBound, but since they are lifted we may
           -- just as well put them in the Rec, in contrast to lifted bindings.
      = case CoreBind
bind of
          NonRec InVar
x CpeRhs
e -> (InVar
x,CpeRhs
e) (InVar, CpeRhs) -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
forall a. a -> [a] -> [a]
: [(InVar, CpeRhs)]
prs2
          Rec [(InVar, CpeRhs)]
prs1 -> [(InVar, CpeRhs)]
prs1 [(InVar, CpeRhs)] -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
forall a. [a] -> [a] -> [a]
++ [(InVar, CpeRhs)]
prs2
    add_float FloatingBind
f [(InVar, CpeRhs)]
_ = String -> SDoc -> [(InVar, CpeRhs)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cpeBind" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
f)


---------------
cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
        -> CorePrepEnv -> OutId -> CoreExpr
        -> UniqSM (Floats, CpeRhs)
-- Used for all bindings
-- The binder is already cloned, hence an OutId
cpePair :: TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> InVar
-> CpeRhs
-> UniqSM (Floats, CpeRhs)
cpePair TopLevelFlag
top_lvl RecFlag
is_rec Demand
dmd Bool
is_unlifted CorePrepEnv
env InVar
bndr CpeRhs
rhs
  = Bool -> UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (InVar -> Bool
isJoinId InVar
bndr)) (UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs))
-> UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a b. (a -> b) -> a -> b
$ -- those should use cpeJoinPair
    do { (floats1, rhs1) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeRhsE CorePrepEnv
env CpeRhs
rhs

       -- See if we are allowed to float this stuff out of the RHS
       ; let dec = Floats -> CpeRhs -> FloatDecision
want_float_from_rhs Floats
floats1 CpeRhs
rhs1
       ; (floats2, rhs2) <- executeFloatDecision dec floats1 rhs1

       -- Make the arity match up
       ; (floats3, rhs3)
            <- if manifestArity rhs1 <= arity
               then return (floats2, cpeEtaExpand arity rhs2)
               else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
                               -- Note [Silly extra arguments]
                    (do { v <- newVar (idType bndr)
                        ; let float = CorePrepEnv -> Bool -> InVar -> CpeRhs -> FloatingBind
mkNonRecFloat CorePrepEnv
env Bool
False InVar
v CpeRhs
rhs2
                        ; return ( snocFloat floats2 float
                                 , cpeEtaExpand arity (Var v)) })

        -- Wrap floating ticks
       ; let (floats4, rhs4) = wrapTicks floats3 rhs3

       ; return (floats4, rhs4) }
  where
    arity :: Int
arity = InVar -> Int
idArity InVar
bndr        -- We must match this arity

    want_float_from_rhs :: Floats -> CpeRhs -> FloatDecision
want_float_from_rhs Floats
floats CpeRhs
rhs
      | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Floats -> FloatDecision
wantFloatTop Floats
floats
      | Bool
otherwise          = RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision
wantFloatLocal RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CpeRhs
rhs

{- Note [Silly extra arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we had this
        f{arity=1} = \x\y. e
We *must* match the arity on the Id, so we have to generate
        f' = \x\y. e
        f  = \x. f' x

It's a bizarre case: why is the arity on the Id wrong?  Reason
(in the days of __inline_me__):
        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
When InlineMe notes go away this won't happen any more.  But
it seems good for CorePrep to be robust.
-}

---------------
cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
            -> UniqSM (JoinId, CpeRhs)
-- Used for all join bindings
-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils
cpeJoinPair :: CorePrepEnv -> InVar -> CpeRhs -> UniqSM (InVar, CpeRhs)
cpeJoinPair CorePrepEnv
env InVar
bndr CpeRhs
rhs
  = Bool -> UniqSM (InVar, CpeRhs) -> UniqSM (InVar, CpeRhs)
forall a. HasCallStack => Bool -> a -> a
assert (InVar -> Bool
isJoinId InVar
bndr) (UniqSM (InVar, CpeRhs) -> UniqSM (InVar, CpeRhs))
-> UniqSM (InVar, CpeRhs) -> UniqSM (InVar, CpeRhs)
forall a b. (a -> b) -> a -> b
$
    do { let JoinPoint Int
join_arity = InVar -> JoinPointHood
idJoinPointHood InVar
bndr
             ([InVar]
bndrs, CpeRhs
body)        = Int -> CpeRhs -> ([InVar], CpeRhs)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity CpeRhs
rhs

       ; (env', bndrs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bndrs

       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts
                                      -- with a lambda

       ; let rhs'  = [InVar] -> CpeRhs -> CpeRhs
mkCoreLams [InVar]
bndrs' CpeRhs
body'
             bndr' = InVar
bndr InVar -> Unfolding -> InVar
`setIdUnfolding` Unfolding
evaldUnfolding
                          InVar -> Int -> InVar
`setIdArity` (InVar -> Bool) -> [InVar] -> Int
forall a. (a -> Bool) -> [a] -> Int
count InVar -> Bool
isId [InVar]
bndrs
                            -- See Note [Arity and join points]

       ; return (bndr', rhs') }

{-
Note [Arity and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Up to now, we've allowed a join point to have an arity greater than its join
arity (minus type arguments), since this is what's useful for eta expansion.
However, for code gen purposes, its arity must be exactly the number of value
arguments it will be called with, and it must have exactly that many value
lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:

  join j x y z = \w -> ... in ...
    =>
  join j x y z = (let f = \w -> ... in f) in ...

This is also what happens with Note [Silly extra arguments]. Note that it's okay
for us to mess with the arity because a join point is never exported.
-}

-- ---------------------------------------------------------------------------
--              CpeRhs: produces a result satisfying CpeRhs
-- ---------------------------------------------------------------------------

cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- If
--      e  ===>  (bs, e')
-- then
--      e = let bs in e'        (semantically, that is!)
--
-- For example
--      f (g x)   ===>   ([v = g x], f v)

cpeRhsE :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeRhsE CorePrepEnv
env (Type Type
ty)
  = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Type -> CpeRhs
forall b. Type -> Expr b
Type (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty))
cpeRhsE CorePrepEnv
env (Coercion Coercion
co)
  = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Coercion -> CpeRhs
forall b. Coercion -> Expr b
Coercion (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co))
cpeRhsE CorePrepEnv
env expr :: CpeRhs
expr@(Lit Literal
lit)
  | LitNumber LitNumType
LitNumBigNat Integer
i <- Literal
lit
    = CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
cpeBigNatLit CorePrepEnv
env Integer
i
  | Bool
otherwise = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeRhs
expr)
cpeRhsE CorePrepEnv
env expr :: CpeRhs
expr@(Var {})  = CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeApp CorePrepEnv
env CpeRhs
expr
cpeRhsE CorePrepEnv
env expr :: CpeRhs
expr@(App {})  = CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeApp CorePrepEnv
env CpeRhs
expr

cpeRhsE CorePrepEnv
env (Let CoreBind
bind CpeRhs
body)
  = do { (env', bind_floats, maybe_bind') <- TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
NotTopLevel CorePrepEnv
env CoreBind
bind
       ; (body_floats, body') <- cpeRhsE env' body
       ; let expr' = case Maybe CoreBind
maybe_bind' of Just CoreBind
bind' -> CoreBind -> CpeRhs -> CpeRhs
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' CpeRhs
body'
                                         Maybe CoreBind
Nothing    -> CpeRhs
body'
       ; return (bind_floats `appFloats` body_floats, expr') }

cpeRhsE CorePrepEnv
env (Tick CoreTickish
tickish CpeRhs
expr)
  -- Pull out ticks if they are allowed to be floated.
  | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish
  = do { (floats, body) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeRhsE CorePrepEnv
env CpeRhs
expr
         -- See [Floating Ticks in CorePrep]
       ; return (FloatTick tickish `consFloat` floats, body) }
  | Bool
otherwise
  = do { body <- CorePrepEnv -> CpeRhs -> UniqSM CpeRhs
cpeBodyNF CorePrepEnv
env CpeRhs
expr
       ; return (emptyFloats, mkTick tickish' body) }
  where
    tickish' :: CoreTickish
tickish' | Breakpoint XBreakpoint 'TickishPassCore
ext Int
n [XTickishId 'TickishPassCore]
fvs Module
modl <- CoreTickish
tickish
             -- See also 'substTickish'
             = XBreakpoint 'TickishPassCore
-> Int -> [XTickishId 'TickishPassCore] -> Module -> CoreTickish
forall (pass :: TickishPass).
XBreakpoint pass
-> Int -> [XTickishId pass] -> Module -> GenTickish pass
Breakpoint XBreakpoint 'TickishPassCore
ext Int
n ((InVar -> InVar) -> [InVar] -> [InVar]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => CpeRhs -> InVar
CpeRhs -> InVar
getIdFromTrivialExpr (CpeRhs -> InVar) -> (InVar -> CpeRhs) -> InVar -> InVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CorePrepEnv -> InVar -> CpeRhs
lookupCorePrepEnv CorePrepEnv
env) [InVar]
[XTickishId 'TickishPassCore]
fvs) Module
modl
             | Bool
otherwise
             = CoreTickish
tickish

cpeRhsE CorePrepEnv
env (Cast CpeRhs
expr Coercion
co)
   = do { (floats, expr') <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeRhsE CorePrepEnv
env CpeRhs
expr
        ; return (floats, Cast expr' (cpSubstCo env co)) }

cpeRhsE CorePrepEnv
env expr :: CpeRhs
expr@(Lam {})
   = do { let ([InVar]
bndrs,CpeRhs
body) = CpeRhs -> ([InVar], CpeRhs)
forall b. Expr b -> ([b], Expr b)
collectBinders CpeRhs
expr
        ; (env', bndrs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bndrs
        ; body' <- cpeBodyNF env' body
        ; return (emptyFloats, mkLams bndrs' body') }

cpeRhsE CorePrepEnv
env (Case CpeRhs
scrut InVar
bndr Type
_ alts :: [Alt InVar]
alts@[Alt AltCon
con [InVar
covar] CpeRhs
_])
  -- See (U3) in Note [Implementing unsafeCoerce]
  -- We need make the Case float, otherwise we get
  --   let x = case ... of UnsafeRefl co ->
  --           let y = expr in
  --           K y
  --   in f x
  -- instead of
  --   case ... of UnsafeRefl co ->
  --   let y = expr in
  --   let x = K y
  --   in f x
  -- Note that `x` is a value here. This is visible in the GHCi debugger tests
  -- (such as `print003`).
  | Just CpeRhs
rhs <- CpeRhs -> InVar -> [Alt InVar] -> Maybe CpeRhs
isUnsafeEqualityCase CpeRhs
scrut InVar
bndr [Alt InVar]
alts
  = do { (floats_scrut, scrut) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeBody CorePrepEnv
env CpeRhs
scrut

       ; (env, bndr')  <- cpCloneBndr env bndr
       ; (env, covar') <- cpCloneCoVarBndr env covar
                          -- Important: here we clone the CoVar
                          -- See Note [Cloning CoVars and TyVars]

         -- Up until here this should do exactly the same as the regular code
         -- path of `cpeRhsE Case{}`.
       ; (floats_rhs, rhs) <- cpeBody env rhs
         -- ... but we want to float `floats_rhs` as in (U3) so that rhs' might
         -- become a value
       ; let case_float = CpeRhs -> InVar -> AltCon -> [InVar] -> FloatingBind
UnsafeEqualityCase CpeRhs
scrut InVar
bndr' AltCon
con [InVar
covar']
         -- NB: It is OK to "evaluate" the proof eagerly.
         --     Usually there's the danger that we float the unsafeCoerce out of
         --     a branching Case alt. Not so here, because the regular code path
         --     for `cpeRhsE Case{}` will not float out of alts.
             floats = Floats -> FloatingBind -> Floats
snocFloat Floats
floats_scrut FloatingBind
case_float Floats -> Floats -> Floats
`appFloats` Floats
floats_rhs
       ; return (floats, rhs) }

cpeRhsE CorePrepEnv
env (Case CpeRhs
scrut InVar
bndr Type
_ [Alt (DataAlt DataCon
dc) [InVar
token_out, InVar
res] CpeRhs
rhs])
  -- See item (SEQ4) of Note [seq# magic]. We want to match
  --   case seq# @a @RealWorld <ok-to-discard> s of (# s', _ #) -> rhs[s']
  -- and simplify to rhs[s]. Triggers in T15226.
  | DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
  , (Var InVar
f,[CpeRhs
_ty1, CpeRhs
_ty2, CpeRhs
arg, Var InVar
token_in]) <- CpeRhs -> (CpeRhs, [CpeRhs])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CpeRhs
scrut
  , InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqHashKey
  , CpeRhs -> Bool
exprOkToDiscard CpeRhs
arg
      -- ok-to-discard, because we want to discard the evaluation of `arg`.
      -- ok-to-discard includes ok-for-spec, but *also* CanFail primops such as
      -- `quotInt# 1# 0#`, but not ThrowsException primops.
      -- See Note [Classifying primop effects]
      -- and Note [Transformations affected by primop effects] for why this is
      -- the correct choice.
  , Var InVar
token_in' <- CorePrepEnv -> InVar -> CpeRhs
lookupCorePrepEnv CorePrepEnv
env InVar
token_in
  , InVar -> Bool
isDeadBinder InVar
res, InVar -> Bool
isDeadBinder InVar
bndr
      -- Check that bndr and res are dead
      -- We can rely on `isDeadBinder res`, despite the fact that the Simplifier
      -- often zaps the OccInfo on case-alternative binders (see Note [DataAlt occ info]
      -- in GHC.Core.Opt.Simplify.Iteration) because the scrutinee is not a
      -- variable, and in that case the zapping doesn't happen; see that Note.
  = CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeRhsE (CorePrepEnv -> InVar -> InVar -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env InVar
token_out InVar
token_in') CpeRhs
rhs

cpeRhsE CorePrepEnv
env (Case CpeRhs
scrut InVar
bndr Type
ty [Alt InVar]
alts)
  = do { (floats, scrut') <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeBody CorePrepEnv
env CpeRhs
scrut
       ; (env', bndr2) <- cpCloneBndr env bndr
       ; let alts'
               | CorePrepConfig -> Bool
cp_catchNonexhaustiveCases (CorePrepConfig -> Bool) -> CorePrepConfig -> Bool
forall a b. (a -> b) -> a -> b
$ CorePrepEnv -> CorePrepConfig
cpe_config CorePrepEnv
env
                 -- Suppose the alternatives do not cover all the data constructors of the type.
                 -- That may be fine: perhaps an earlier case has dealt with the missing cases.
                 -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag
                 -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases
                 -- (This alternative will only be taken if there is a bug in GHC.)
               , Bool -> Bool
not ([Alt InVar] -> Bool
forall b. [Alt b] -> Bool
altsAreExhaustive [Alt InVar]
alts)
               = [Alt InVar] -> Maybe CpeRhs -> [Alt InVar]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault [Alt InVar]
alts (CpeRhs -> Maybe CpeRhs
forall a. a -> Maybe a
Just CpeRhs
err)
               | Bool
otherwise = [Alt InVar]
alts
               where err :: CpeRhs
err = Type -> String -> CpeRhs
mkImpossibleExpr Type
ty String
"cpeRhsE: missing case alternative"
       ; alts'' <- mapM (sat_alt env') alts'

       ; case alts'' of
           [Alt AltCon
DEFAULT [InVar]
_ CpeRhs
rhs] -- See Note [Flatten case-binds]
             | let is_unlifted :: Bool
is_unlifted = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (InVar -> Type
idType InVar
bndr2)
             , let float :: FloatingBind
float = Bool -> InVar -> CpeRhs -> FloatingBind
mkCaseFloat Bool
is_unlifted InVar
bndr2 CpeRhs
scrut'
             -> (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> FloatingBind -> Floats
snocFloat Floats
floats FloatingBind
float, CpeRhs
rhs)
           [Alt InVar]
_ -> (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeRhs -> InVar -> Type -> [Alt InVar] -> CpeRhs
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeRhs
scrut' InVar
bndr2 (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty) [Alt InVar]
alts'') }
  where
    sat_alt :: CorePrepEnv -> Alt InVar -> UniqSM (Alt InVar)
sat_alt CorePrepEnv
env (Alt AltCon
con [InVar]
bs CpeRhs
rhs)
       = do { (env2, bs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bs
            ; rhs' <- cpeBodyNF env2 rhs
            ; return (Alt con bs' rhs') }

-- ---------------------------------------------------------------------------
--              CpeBody: produces a result satisfying CpeBody
-- ---------------------------------------------------------------------------

-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without
-- producing any floats (any generated floats are immediately
-- let-bound using 'wrapBinds').  Generally you want this, esp.
-- when you've reached a binding form (e.g., a lambda) and
-- floating any further would be incorrect.
cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
cpeBodyNF :: CorePrepEnv -> CpeRhs -> UniqSM CpeRhs
cpeBodyNF CorePrepEnv
env CpeRhs
expr
  = do { (floats, body) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeBody CorePrepEnv
env CpeRhs
expr
       ; return (wrapBinds floats body) }

-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce
-- a list of 'Floats' which are being propagated upwards.  In
-- fact, this function is used in only two cases: to
-- implement 'cpeBodyNF' (which is what you usually want),
-- and in the case when a let-binding is in a case scrutinee--here,
-- we can always float out:
--
--      case (let x = y in z) of ...
--      ==> let x = y in case z of ...
--
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeBody CorePrepEnv
env CpeRhs
expr
  = do { (floats1, rhs) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeRhsE CorePrepEnv
env CpeRhs
expr
       ; (floats2, body) <- rhsToBody rhs
       ; return (floats1 `appFloats` floats2, body) }

--------
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
-- Remove top level lambdas by let-binding

rhsToBody :: CpeRhs -> UniqSM (Floats, CpeRhs)
rhsToBody (Tick CoreTickish
t CpeRhs
expr)
  | CoreTickish -> TickishScoping
forall (pass :: TickishPass). GenTickish pass -> TickishScoping
tickishScoped CoreTickish
t TickishScoping -> TickishScoping -> Bool
forall a. Eq a => a -> a -> Bool
== TickishScoping
NoScope  -- only float out of non-scoped annotations
  = do { (floats, expr') <- CpeRhs -> UniqSM (Floats, CpeRhs)
rhsToBody CpeRhs
expr
       ; return (floats, mkTick t expr') }

rhsToBody (Cast CpeRhs
e Coercion
co)
        -- You can get things like
        --      case e of { p -> coerce t (\s -> ...) }
  = do { (floats, e') <- CpeRhs -> UniqSM (Floats, CpeRhs)
rhsToBody CpeRhs
e
       ; return (floats, Cast e' co) }

rhsToBody expr :: CpeRhs
expr@(Lam {})   -- See Note [No eta reduction needed in rhsToBody]
  | (InVar -> Bool) -> [InVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all InVar -> Bool
isTyVar [InVar]
bndrs           -- Type lambdas are ok
  = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeRhs
expr)
  | Bool
otherwise                   -- Some value lambdas
  = do { let rhs :: CpeRhs
rhs = Int -> CpeRhs -> CpeRhs
cpeEtaExpand (CpeRhs -> Int
exprArity CpeRhs
expr) CpeRhs
expr
       ; fn <- Type -> UniqSM InVar
newVar (HasDebugCallStack => CpeRhs -> Type
CpeRhs -> Type
exprType CpeRhs
rhs)
       ; let float = CoreBind -> BindInfo -> FloatInfo -> FloatingBind
Float (InVar -> CpeRhs -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
fn CpeRhs
rhs) BindInfo
LetBound FloatInfo
TopLvlFloatable
       ; return (unitFloat float, Var fn) }
  where
    ([InVar]
bndrs,CpeRhs
_) = CpeRhs -> ([InVar], CpeRhs)
forall b. Expr b -> ([b], Expr b)
collectBinders CpeRhs
expr

rhsToBody CpeRhs
expr = (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeRhs
expr)


{- Note [No eta reduction needed in rhsToBody]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Historical note.  In the olden days we used to have a Prep-specific
eta-reduction step in rhsToBody:
  rhsToBody expr@(Lam {})
    | Just no_lam_result <- tryEtaReducePrep bndrs body
    = return (emptyFloats, no_lam_result)

The goal was to reduce
        case x of { p -> \xs. map f xs }
    ==> case x of { p -> map f }

to avoid allocating a lambda.  Of course, we'd allocate a PAP
instead, which is hardly better, but that's the way it was.

Now we simply don't bother with this. It doesn't seem to be a win,
and it's extra work.
-}

-- ---------------------------------------------------------------------------
--              CpeApp: produces a result satisfying CpeApp
-- ---------------------------------------------------------------------------

data ArgInfo = AIApp  CoreArg -- NB: Not a CpeApp yet
             | AICast Coercion
             | AITick CoreTickish

instance Outputable ArgInfo where
  ppr :: ArgInfo -> SDoc
ppr (AIApp CpeRhs
arg) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"app" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CpeRhs -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeRhs
arg
  ppr (AICast Coercion
co) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cast" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
  ppr (AITick CoreTickish
tick) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tick" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
tick

{- Note [Ticks and mandatory eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Something like
    `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`
caused a compiler panic in #20938. Why did this happen?
The simplifier will eta-reduce the rhs giving us a partial
application of tagToEnum#. The tick is then pushed inside the
type argument. That is we get
    `(Tick<foo> tagToEnum#) @Bool`
CorePrep would go on to see a undersaturated tagToEnum# application
and eta expand the expression under the tick. Giving us:
    (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool
Suddenly tagToEnum# is applied to a polymorphic type and the code generator
panics as it needs a concrete type to determine the representation.

The problem in my eyes was that the tick covers a partial application
of a primop. There is no clear semantic for such a construct as we can't
partially apply a primop since they do not have bindings.
We fix this by expanding the scope of such ticks slightly to cover the body
of the eta-expanded expression.

We do this by:
* Checking if an application is headed by a primOpish thing.
* If so we collect floatable ticks and usually but also profiling ticks
  along with regular arguments.
* When rebuilding the application we check if any profiling ticks appear
  before the primop is fully saturated.
* If the primop isn't fully satured we eta expand the primop application
  and scope the tick to scope over the body of the saturated expression.

Going back to #20938 this means starting with
    `(Tick<foo> tagToEnum#) @Bool`
we check if the function head is a primop (yes). This means we collect the
profiling tick like if it was floatable. Giving us
    (tagToEnum#, [CpeTick foo, CpeApp @Bool]).
cpe_app filters out the tick as a underscoped tick on the expression
`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the
body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.
-}
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- May return a CpeRhs (instead of CpeApp) because of saturating primops
cpeApp :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeApp CorePrepEnv
top_env CpeRhs
expr
  = do { let (CpeRhs
terminal, [ArgInfo]
args) = CpeRhs -> (CpeRhs, [ArgInfo])
collect_args CpeRhs
expr
      --  ; pprTraceM "cpeApp" $ (ppr expr)
       ; CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
cpe_app CorePrepEnv
top_env CpeRhs
terminal [ArgInfo]
args
       }

  where
    -- We have a nested data structure of the form
    -- e `App` a1 `App` a2 ... `App` an, convert it into
    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
    -- We use 'ArgInfo' because we may also need to
    -- record casts and ticks.  Depth counts the number
    -- of arguments that would consume strictness information
    -- (so, no type or coercion arguments.)
    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo])
    collect_args :: CpeRhs -> (CpeRhs, [ArgInfo])
collect_args CpeRhs
e = CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
go CpeRhs
e []
      where
        go :: CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
go (App CpeRhs
fun CpeRhs
arg)      [ArgInfo]
as
            = CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
go CpeRhs
fun (CpeRhs -> ArgInfo
AIApp CpeRhs
arg ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
        go (Cast CpeRhs
fun Coercion
co)      [ArgInfo]
as
            = CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
go CpeRhs
fun (Coercion -> ArgInfo
AICast Coercion
co ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
        go (Tick CoreTickish
tickish CpeRhs
fun) [ArgInfo]
as
            -- Profiling ticks are slightly less strict so we expand their scope
            -- if they cover partial applications of things like primOps.
            -- See Note [Ticks and mandatory eta expansion]
            -- Here we look inside `fun` before we make the final decision about
            -- floating the tick which isn't optimal for perf. But this only makes
            -- a difference if we have a non-floatable tick which is somewhat rare.
            | Var InVar
vh <- CpeRhs
head
            , Var InVar
head' <- CorePrepEnv -> InVar -> CpeRhs
lookupCorePrepEnv CorePrepEnv
top_env InVar
vh
            , InVar -> CoreTickish -> Bool
forall (pass :: TickishPass). InVar -> GenTickish pass -> Bool
etaExpansionTick InVar
head' CoreTickish
tickish
            = (CpeRhs
head,[ArgInfo]
as')
            where
              (CpeRhs
head,[ArgInfo]
as') = CpeRhs -> [ArgInfo] -> (CpeRhs, [ArgInfo])
go CpeRhs
fun (CoreTickish -> ArgInfo
AITick CoreTickish
tickish ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)

        -- Terminal could still be an app if it's wrapped by a tick.
        -- E.g. Tick<foo> (f x) can give us (f x) as terminal.
        go CpeRhs
terminal [ArgInfo]
as = (CpeRhs
terminal, [ArgInfo]
as)

    cpe_app :: CorePrepEnv
            -> CoreExpr -- The thing we are calling
            -> [ArgInfo]
            -> UniqSM (Floats, CpeRhs)
    cpe_app :: CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
cpe_app CorePrepEnv
env (Var InVar
f) (AIApp Type{} : AIApp CpeRhs
arg : [ArgInfo]
args)
        | InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey          -- Replace (lazy a) with a, and
            -- See Note [lazyId magic] in GHC.Types.Id.Make
       Bool -> Bool -> Bool
|| InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineIdKey Bool -> Bool -> Bool
|| InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineConstraintIdKey
            -- Replace (noinline a) with a
            -- See Note [noinlineId magic] in GHC.Types.Id.Make
       Bool -> Bool -> Bool
|| InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nospecIdKey        -- Replace (nospec a) with a
            -- See Note [nospecId magic] in GHC.Types.Id.Make

        -- Consider the code:
        --
        --      lazy (f x) y
        --
        -- We need to make sure that we need to recursively collect arguments on
        -- "f x", otherwise we'll float "f x" out (it's not a variable) and
        -- end up with this awful -ddump-prep:
        --
        --      case f x of f_x {
        --        __DEFAULT -> f_x y
        --      }
        --
        -- rather than the far superior "f x y".  Test case is par01.
        = let (CpeRhs
terminal, [ArgInfo]
args') = CpeRhs -> (CpeRhs, [ArgInfo])
collect_args CpeRhs
arg
          in CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
cpe_app CorePrepEnv
env CpeRhs
terminal ([ArgInfo]
args' [ArgInfo] -> [ArgInfo] -> [ArgInfo]
forall a. [a] -> [a] -> [a]
++ [ArgInfo]
args)

    -- runRW# magic
    cpe_app CorePrepEnv
env (Var InVar
f) (AIApp _runtimeRep :: CpeRhs
_runtimeRep@Type{} : AIApp _type :: CpeRhs
_type@Type{} : AIApp CpeRhs
arg : [ArgInfo]
rest)
        | InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
        -- N.B. While it may appear that n == 1 in the case of runRW#
        -- applications, keep in mind that we may have applications that return
        , [ArgInfo] -> Bool
has_value_arg (CpeRhs -> ArgInfo
AIApp CpeRhs
arg ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
rest)
        -- See Note [runRW magic]
        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
        -- is why we return a CorePrepEnv as well)
        = case CpeRhs
arg of
            Lam InVar
s CpeRhs
body -> CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
cpe_app (CorePrepEnv -> InVar -> InVar -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env InVar
s InVar
realWorldPrimId) CpeRhs
body [ArgInfo]
rest
            CpeRhs
_          -> CorePrepEnv -> CpeRhs -> [ArgInfo] -> UniqSM (Floats, CpeRhs)
cpe_app CorePrepEnv
env CpeRhs
arg (CpeRhs -> ArgInfo
AIApp (InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
realWorldPrimId) ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
rest)
             -- TODO: What about casts?
        where
          has_value_arg :: [ArgInfo] -> Bool
has_value_arg [] = Bool
False
          has_value_arg (AIApp CpeRhs
arg:[ArgInfo]
_rest)
            | Bool -> Bool
not (CpeRhs -> Bool
forall b. Expr b -> Bool
isTyCoArg CpeRhs
arg) = Bool
True
          has_value_arg (ArgInfo
_:[ArgInfo]
rest) = [ArgInfo] -> Bool
has_value_arg [ArgInfo]
rest

    -- See Note [seq# magic]. This is the step for CorePrep
    cpe_app CorePrepEnv
env (Var InVar
f) [AIApp (Type Type
ty), AIApp _st_ty :: CpeRhs
_st_ty@Type{}, AIApp CpeRhs
thing, AIApp CpeRhs
token]
        | InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqHashKey
        -- seq# thing token
        --    ==>   case token of s   { __DEFAULT ->
        --          case thing of res { __DEFAULT -> (# token, res#) } },
        -- allocating CaseBound Floats for token and thing as needed
        = do { (floats1, token) <- CorePrepEnv -> Demand -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeArg CorePrepEnv
env Demand
topDmd CpeRhs
token
             ; (floats2, thing) <- cpeBody env thing
             ; case_bndr <- newVar ty
             ; let tup = [CpeRhs] -> CpeRhs
mkCoreUnboxedTuple [CpeRhs
token, InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
case_bndr]
             ; let is_unlifted = Bool
False -- otherwise seq# would not type-check
             ; let float = Bool -> InVar -> CpeRhs -> FloatingBind
mkCaseFloat Bool
is_unlifted InVar
case_bndr CpeRhs
thing
             ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }

    cpe_app CorePrepEnv
env (Var InVar
v) [ArgInfo]
args
      = do { v1 <- InVar -> UniqSM InVar
fiddleCCall InVar
v
           ; let e2 = CorePrepEnv -> InVar -> CpeRhs
lookupCorePrepEnv CorePrepEnv
env InVar
v1
                 hd = CpeRhs -> Maybe InVar
getIdFromTrivialExpr_maybe CpeRhs
e2
                 -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
                 min_arity = case Maybe InVar
hd of
                   Just InVar
v_hd -> if InVar -> Bool
hasNoBinding InVar
v_hd then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! (InVar -> Int
idArity InVar
v_hd) else Maybe Int
forall a. Maybe a
Nothing
                   Maybe InVar
Nothing -> Maybe Int
forall a. Maybe a
Nothing
          --  ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))
           ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity
           ; mb_saturate hd app floats unsat_ticks depth }
        where
          depth :: Int
depth = [ArgInfo] -> Int
val_args [ArgInfo]
args
          stricts :: [Demand]
stricts = case InVar -> DmdSig
idDmdSig InVar
v of
                            DmdSig (DmdType DmdEnv
_ [Demand]
demands)
                              | [Demand] -> Int -> Ordering
forall a. [a] -> Int -> Ordering
listLengthCmp [Demand]
demands Int
depth Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT -> [Demand]
demands
                                    -- length demands <= depth
                              | Bool
otherwise                         -> []
                -- If depth < length demands, then we have too few args to
                -- satisfy strictness  info so we have to  ignore all the
                -- strictness info, e.g. + (error "urk")
                -- Here, we can't evaluate the arg strictly, because this
                -- partial application might be seq'd

        -- We inlined into something that's not a var and has no args.
        -- Bounce it back up to cpeRhsE.
    cpe_app CorePrepEnv
env CpeRhs
fun [] = CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeRhsE CorePrepEnv
env CpeRhs
fun

    -- Here we get:
    -- N-variable fun, better let-bind it
    -- This case covers literals, apps, lams or let expressions applied to arguments.
    -- Basically things we want to ANF before applying to arguments.
    cpe_app CorePrepEnv
env CpeRhs
fun [ArgInfo]
args
      = do { (fun_floats, fun') <- CorePrepEnv -> Demand -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeArg CorePrepEnv
env Demand
evalDmd CpeRhs
fun
                          -- If evalDmd says that it's sure to be evaluated,
                          -- we'll end up case-binding it
           ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing
           ; mb_saturate Nothing app floats unsat_ticks (val_args args) }

    -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG)
    val_args :: [ArgInfo] -> Int
    val_args :: [ArgInfo] -> Int
val_args [ArgInfo]
args = [ArgInfo] -> Int -> Int
forall {t}. Num t => [ArgInfo] -> t -> t
go [ArgInfo]
args Int
0
      where
        go :: [ArgInfo] -> t -> t
go [] !t
n = t
n
        go (ArgInfo
info:[ArgInfo]
infos) t
n =
          case ArgInfo
info of
            AICast {} -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n
            AITick CoreTickish
tickish
              | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish                 -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n
              -- If we can't guarantee a tick will be floated out of the application
              -- we can't guarantee the value args following it will be applied.
              | Bool
otherwise                             -> t
n
            AIApp CpeRhs
e                                  -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n'
              where
                !n' :: t
n'
                  | CpeRhs -> Bool
forall b. Expr b -> Bool
isTypeArg CpeRhs
e = t
n
                  | Bool
otherwise   = t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1

    -- Saturate if necessary
    mb_saturate :: Maybe InVar
-> CpeRhs -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeRhs)
mb_saturate Maybe InVar
head CpeRhs
app a
floats [CoreTickish]
unsat_ticks Int
depth =
       case Maybe InVar
head of
         Just InVar
fn_id -> do { sat_app <- InVar -> CpeRhs -> Int -> [CoreTickish] -> UniqSM CpeRhs
maybeSaturate InVar
fn_id CpeRhs
app Int
depth [CoreTickish]
unsat_ticks
                          ; return (floats, sat_app) }
         Maybe InVar
_other     -> do { Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([CoreTickish] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreTickish]
unsat_ticks)
                          ; (a, CpeRhs) -> UniqSM (a, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CpeRhs
app) }

    -- Deconstruct and rebuild the application, floating any non-atomic
    -- arguments to the outside.  We collect the type of the expression,
    -- the head of the application, and the number of actual value arguments,
    -- all of which are used to possibly saturate this application if it
    -- has a constructor or primop at the head.
    rebuild_app
        :: CorePrepEnv
        -> [ArgInfo]                  -- The arguments (inner to outer)
        -> CpeApp                     -- The function
        -> Floats                     -- INVARIANT: These floats don't bind anything that is in the CpeApp!
                                      -- Just stuff floated out from the head of the application.
        -> [Demand]
        -> Maybe Arity
        -> UniqSM (CpeApp
                  ,Floats
                  ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]
                  )
    rebuild_app :: CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> Maybe Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeRhs
app Floats
floats [Demand]
ss Maybe Int
req_depth =
      CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
args CpeRhs
app Floats
floats [Demand]
ss [] (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
req_depth)

    rebuild_app'
        :: CorePrepEnv
        -> [ArgInfo] -- The arguments (inner to outer)
        -> CpeApp
        -> Floats
        -> [Demand]
        -> [CoreTickish]
        -> Int -- Number of arguments required to satisfy minimal tick scopes.
        -> UniqSM (CpeApp, Floats, [CoreTickish])
    rebuild_app' :: CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
_ [] CpeRhs
app Floats
floats [Demand]
ss [CoreTickish]
rt_ticks !Int
_req_depth
      = Bool
-> SDoc
-> ((CpeRhs, Floats, [CoreTickish])
    -> UniqSM (CpeRhs, Floats, [CoreTickish]))
-> (CpeRhs, Floats, [CoreTickish])
-> UniqSM (CpeRhs, Floats, [CoreTickish])
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Demand] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
ss) ([Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
ss)-- make sure we used all the strictness info
        (CpeRhs, Floats, [CoreTickish])
-> UniqSM (CpeRhs, Floats, [CoreTickish])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeRhs
app, Floats
floats, [CoreTickish]
rt_ticks)

    rebuild_app' CorePrepEnv
env (ArgInfo
a : [ArgInfo]
as) CpeRhs
fun' Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth = case ArgInfo
a of
      -- See Note [Ticks and mandatory eta expansion]
      ArgInfo
_
        | Bool -> Bool
not ([CoreTickish] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreTickish]
rt_ticks)
        , Int
req_depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
        ->
            let tick_fun :: CpeRhs
tick_fun = (CoreTickish -> CpeRhs -> CpeRhs)
-> CpeRhs -> [CoreTickish] -> CpeRhs
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CpeRhs -> CpeRhs
mkTick CpeRhs
fun' [CoreTickish]
rt_ticks
            in CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env (ArgInfo
a ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as) CpeRhs
tick_fun Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth

      AIApp (Type Type
arg_ty)
        -> CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
App CpeRhs
fun' (Type -> CpeRhs
forall b. Type -> Expr b
Type Type
arg_ty')) Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth
        where
           arg_ty' :: Type
arg_ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
arg_ty

      AIApp (Coercion Coercion
co)
        -> CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
App CpeRhs
fun' (Coercion -> CpeRhs
forall b. Coercion -> Expr b
Coercion Coercion
co')) Floats
floats (Int -> [Demand] -> [Demand]
forall a. Int -> [a] -> [a]
drop Int
1 [Demand]
ss) [CoreTickish]
rt_ticks Int
req_depth
        where
           co' :: Coercion
co' = CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co

      AIApp CpeRhs
arg -> do
        let (Demand
ss1, [Demand]
ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make
               = case ([Demand]
ss, CpeRhs -> Bool
isLazyExpr CpeRhs
arg) of
                   (Demand
_   : [Demand]
ss_rest, Bool
True)  -> (Demand
topDmd, [Demand]
ss_rest)
                   (Demand
ss1 : [Demand]
ss_rest, Bool
False) -> (Demand
ss1,    [Demand]
ss_rest)
                   ([],            Bool
_)     -> (Demand
topDmd, [])
        (fs, arg') <- CorePrepEnv -> Demand -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeArg CorePrepEnv
top_env Demand
ss1 CpeRhs
arg
        rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1)

      AICast Coercion
co
        -> CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeRhs -> Coercion -> CpeRhs
forall b. Expr b -> Coercion -> Expr b
Cast CpeRhs
fun' Coercion
co') Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth
        where
           co' :: Coercion
co' = CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co

      -- See Note [Ticks and mandatory eta expansion]
      AITick CoreTickish
tickish
        | CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tickish TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceRuntime
        , Int
req_depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        -> Bool
-> UniqSM (CpeRhs, Floats, [CoreTickish])
-> UniqSM (CpeRhs, Floats, [CoreTickish])
forall a. HasCallStack => Bool -> a -> a
assert (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
isProfTick CoreTickish
tickish) (UniqSM (CpeRhs, Floats, [CoreTickish])
 -> UniqSM (CpeRhs, Floats, [CoreTickish]))
-> UniqSM (CpeRhs, Floats, [CoreTickish])
-> UniqSM (CpeRhs, Floats, [CoreTickish])
forall a b. (a -> b) -> a -> b
$
           CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as CpeRhs
fun' Floats
floats [Demand]
ss (CoreTickish
tickishCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
rt_ticks) Int
req_depth
        | Bool
otherwise
        -- See [Floating Ticks in CorePrep]
        -> CorePrepEnv
-> [ArgInfo]
-> CpeRhs
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeRhs, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as CpeRhs
fun' (Floats -> FloatingBind -> Floats
snocFloat Floats
floats (CoreTickish -> FloatingBind
FloatTick CoreTickish
tickish)) [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth

isLazyExpr :: CoreExpr -> Bool
-- See Note [lazyId magic] in GHC.Types.Id.Make
isLazyExpr :: CpeRhs -> Bool
isLazyExpr (Cast CpeRhs
e Coercion
_)              = CpeRhs -> Bool
isLazyExpr CpeRhs
e
isLazyExpr (Tick CoreTickish
_ CpeRhs
e)              = CpeRhs -> Bool
isLazyExpr CpeRhs
e
isLazyExpr (Var InVar
f `App` CpeRhs
_ `App` CpeRhs
_) = InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
isLazyExpr CpeRhs
_                       = Bool
False

{- Note [runRW magic]
~~~~~~~~~~~~~~~~~~~~~
Some definitions, for instance @runST@, must have careful control over float out
of the bindings in their body. Consider this use of @runST@,

    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s
                             (_, s'') = fill_in_array_or_something a x s'
                         in freezeArray# a s'' )

If we inline @runST@, we'll get:

    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}
              (_, s'') = fill_in_array_or_something a x s'
          in freezeArray# a s''

And now if we allow the @newArray#@ binding to float out to become a CAF,
we end up with a result that is totally and utterly wrong:

    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
        in \ x ->
            let (_, s'') = fill_in_array_or_something a x s'
            in freezeArray# a s''

All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
must be prevented.

This is what @runRW#@ gives us: by being inlined extremely late in the
optimization (right before lowering to STG, in CorePrep), we can ensure that
no further floating will occur. This allows us to safely inline things like
@runST@, which are otherwise needlessly expensive (see #10678 and #5916).

'runRW' has a variety of quirks:

 * 'runRW' is known-key with a NOINLINE definition in
   GHC.Magic. This definition is used in cases where runRW is curried.

 * In addition to its normal Haskell definition in GHC.Magic, we give it
   a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding
   the incorrect sharing due to float-out noted above.

 * It is levity-polymorphic:

    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
           => (State# RealWorld -> (# State# RealWorld, o #))
           -> (# State# RealWorld, o #)

 * It has some special simplification logic to allow unboxing of results when
   runRW# appears in a strict context. See Note [Simplification of runRW#]
   below.

 * Since its body is inlined, we allow runRW#'s argument to contain jumps to
   join points. That is, the following is allowed:

    join j x = ...
    in runRW# @_ @_ (\s -> ... jump j 42 ...)

   The Core Linter knows about this. See Note [Linting of runRW#] in
   GHC.Core.Lint for details.

   The occurrence analyser and SetLevels also know about this, as described in
   Note [Simplification of runRW#].

Other relevant Notes:

 * Note [Simplification of runRW#] below, describing a transformation of runRW
   applications in strict contexts performed by the simplifier.
 * Note [Linting of runRW#] in GHC.Core.Lint
 * Note [runRW arg] below, describing a non-obvious case where the
   late-inlining could go wrong.

Note [runRW arg]
~~~~~~~~~~~~~~~~~~~
Consider the Core program (from #11291),

   runRW# (case bot of {})

The late inlining logic in cpe_app would transform this into:

   (case bot of {}) realWorld#

Which would rise to a panic in CoreToStg.myCollectArgs, which expects only
variables in function position.

However, as runRW#'s strictness signature captures the fact that it will call
its argument this can't happen: the simplifier will transform the bottoming
application into simply (case bot of {}).

Note that this reasoning does *not* apply to non-bottoming continuations like:

    hello :: Bool -> Int
    hello n =
      runRW# (
          case n of
            True -> \s -> 23
            _    -> \s -> 10)

Why? The difference is that (case bot of {}) is considered by okCpeArg to be
trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both
the function and the arguments) will forgo binding it to a variable. By
contrast, in the non-bottoming case of `hello` above  the function will be
deemed non-trivial and consequently will be case-bound.

Note [Simplification of runRW#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the program,

    case runRW# (\s -> I# 42#) of
      I# n# -> f n#

There is no reason why we should allocate an I# constructor given that we
immediately destructure it.

To avoid this the simplifier has a special transformation rule, specific to
runRW#, that pushes a strict context into runRW#'s continuation.  See the
`runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`.  That is, it transforms

    K[ runRW# @r @ty cont ]
              ~>
    runRW# @r @ty (\s -> K[cont s])

This has a few interesting implications. Consider, for instance, this program:

    join j = ...
    in case runRW# @r @ty cont of
         result -> jump j result

Performing the transform described above would result in:

    join j x = ...
    in runRW# @r @ty (\s ->
         case cont of in
           result -> jump j result
       )

If runRW# were a "normal" function this call to join point j would not be
allowed in its continuation argument. However, since runRW# is inlined (as
described in Note [runRW magic] above), such join point occurrences are
completely fine. Both occurrence analysis (see the runRW guard in occAnalApp)
and Core Lint (see the App case of lintCoreExpr) have special treatment for
runRW# applications. See Note [Linting of runRW#] for details on the latter.

Moreover, it's helpful to ensure that runRW's continuation isn't floated out
For instance, if we have

    runRW# (\s -> do_something)

where do_something contains only top-level free variables, we may be tempted to
float the argument to the top-level. However, we must resist this urge as since
doing so would then require that runRW# produce an allocation and call, e.g.:

    let lvl = \s -> do_somethign
    in
    ....(runRW# lvl)....

whereas without floating the inlining of the definition of runRW would result
in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special
treatment for runRW# applications, ensure the arguments are not floated as
MFEs.

Now that we float evaluation context into runRW#, we also have to give runRW# a
special higher-order CPR transformer lest we risk #19822. E.g.,

  case runRW# (\s -> doThings) of x -> Data.Text.Text x something something'
      ~>
  runRW# (\s -> case doThings s of x -> Data.Text.Text x something something')

The former had the CPR property, and so should the latter.

Other considered designs
------------------------

One design that was rejected was to *require* that runRW#'s continuation be
headed by a lambda. However, this proved to be quite fragile. For instance,
SetLevels is very eager to float bottoming expressions. For instance given
something of the form,

    runRW# @r @ty (\s -> case expr of x -> undefined)

SetLevels will see that the body the lambda is bottoming and will consequently
float it to the top-level (assuming expr has no free coercion variables which
prevent this). We therefore end up with

    runRW# @r @ty (\s -> lvl s)

Which the simplifier will beta reduce, leaving us with

    runRW# @r @ty lvl

Breaking our desired invariant. Ultimately we decided to simply accept that
the continuation may not be a manifest lambda.


-- ---------------------------------------------------------------------------
--      CpeArg: produces a result satisfying CpeArg
-- ---------------------------------------------------------------------------

Note [ANF-ising literal string arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a Core program like,

    data Foo = Foo Addr#
    foo = Foo "turtle"#

String literals are non-trivial, see 'GHC.Types.Literal.litIsTrivial', hence
they are non-atomic in STG.
With -O1, FloatOut is likely to have floated most of these strings to top-level,
not least to give CSE a chance to deduplicate strings early (before the
linker, that is).
(Notable exceptions seem to be applications of 'unpackAppendCString#'.)
But with -O0, there is no FloatOut, so CorePrep must do the ANFisation to

    s = "turtle"#
    foo = Foo s

(String literals are the only kind of binding allowed at top-level and hence
their `FloatInfo` is `TopLvlFloatable`.)

This appears to lead to bad code if the arg is under a lambda, because CorePrep
doesn't float out of RHSs, e.g., (T23270)

    foo x = ... patError "turtle"# ...
==> foo x = ... case "turtle"# of s { __DEFAULT -> petError s } ...

This looks bad because it evals an HNF on every call.
But actually, it doesn't, because "turtle"# is already an HNF. Here is the Cmm:

  [section ""cstring" . cB4_str" {
       cB4_str:
           I8[] "turtle"
   }
  ...
  _sAG::I64 = cB4_str;
  R2 = _sAG::I64;
  Sp = Sp + 8;
  call Control.Exception.Base.patError_info(R2) args: 8, res: 0, upd: 8;

Wrinkles:

(FS1) We detect string literals in `cpeBind Rec{}` and float them out anyway;
      otherwise we'd try to bind a string literal in a letrec, violating
      Note [Core letrec invariant]. Since we know that literals don't have
      free variables, we float further.
      Arguably, we could just as well relax the letrec invariant for
      string literals, or anthing that is a value (lifted or not).
      This is tracked in #24036.
-}

-- This is where we arrange that a non-trivial argument is let-bound
cpeArg :: CorePrepEnv -> Demand
       -> CoreArg -> UniqSM (Floats, CpeArg)
cpeArg :: CorePrepEnv -> Demand -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeArg CorePrepEnv
env Demand
dmd CpeRhs
arg
  = do { (floats1, arg1) <- CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeRhs)
cpeRhsE CorePrepEnv
env CpeRhs
arg     -- arg1 can be a lambda
       ; let arg_ty      = HasDebugCallStack => CpeRhs -> Type
CpeRhs -> Type
exprType CpeRhs
arg1
             is_unlifted = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
             dec         = RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision
wantFloatLocal RecFlag
NonRecursive Demand
dmd Bool
is_unlifted Floats
floats1 CpeRhs
arg1
       ; (floats2, arg2) <- executeFloatDecision dec floats1 arg1
                -- Else case: arg1 might have lambdas, and we can't
                --            put them inside a wrapBinds

       -- Now ANF-ise any non-trivial argument
       -- NB: "non-trivial" includes string literals;
       -- see Note [ANF-ising literal string arguments]
       ; if exprIsTrivial arg2
         then return (floats2, arg2)
         else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty
                       -- See Note [Pin demand info on floats]
                 ; let arity = CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> Int
cpeArgArity CorePrepEnv
env FloatDecision
dec Floats
floats1 CpeRhs
arg2
                       arg3  = Int -> CpeRhs -> CpeRhs
cpeEtaExpand Int
arity CpeRhs
arg2
                       -- See Note [Eta expansion of arguments in CorePrep]
                 ; let arg_float = CorePrepEnv -> Bool -> InVar -> CpeRhs -> FloatingBind
mkNonRecFloat CorePrepEnv
env Bool
is_unlifted InVar
v CpeRhs
arg3
                 ; return (snocFloat floats2 arg_float, varToCoreExpr v) }
       }

cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity
-- ^ See Note [Eta expansion of arguments in CorePrep]
-- Returning 0 means "no eta-expansion"; see cpeEtaExpand
cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> Int
cpeArgArity CorePrepEnv
env FloatDecision
float_decision Floats
floats1 CpeRhs
arg
  | FloatDecision
FloatNone <- FloatDecision
float_decision
         -- If we did not float
  , Bool -> Bool
not (Floats -> Bool
isEmptyFloats Floats
floats1)
         -- ... but there was something to float
  , Floats -> FloatInfo
fs_info Floats
floats1 FloatInfo -> FloatInfo -> Bool
`floatsAtLeastAsFarAs` FloatInfo
LazyContextFloatable
         -- ... and we could have floated it out of a lazy arg
  = Int
0    -- ... then short-cut, because floats1 is likely expensive!
         -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep]

  | Just ArityOpts
ao <- CorePrepConfig -> Maybe ArityOpts
cp_arityOpts (CorePrepEnv -> CorePrepConfig
cpe_config CorePrepEnv
env) -- Just <=> -O1 or -O2
  , Bool -> Bool
not (CpeRhs -> Bool
eta_would_wreck_join CpeRhs
arg)
            -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]
  = case HasDebugCallStack => ArityOpts -> CpeRhs -> Maybe SafeArityType
ArityOpts -> CpeRhs -> Maybe SafeArityType
exprEtaExpandArity ArityOpts
ao CpeRhs
arg of
      Maybe SafeArityType
Nothing -> Int
0
      Just SafeArityType
at -> SafeArityType -> Int
arityTypeArity SafeArityType
at

  | Bool
otherwise
  = CpeRhs -> Int
exprArity CpeRhs
arg -- this is cheap enough for -O0

eta_would_wreck_join :: CoreExpr -> Bool
-- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in
-- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]
eta_would_wreck_join :: CpeRhs -> Bool
eta_would_wreck_join (Let CoreBind
bs CpeRhs
e)        = CoreBind -> Bool
isJoinBind CoreBind
bs Bool -> Bool -> Bool
|| CpeRhs -> Bool
eta_would_wreck_join CpeRhs
e
eta_would_wreck_join (Lam InVar
_ CpeRhs
e)         = CpeRhs -> Bool
eta_would_wreck_join CpeRhs
e
eta_would_wreck_join (Cast CpeRhs
e Coercion
_)        = CpeRhs -> Bool
eta_would_wreck_join CpeRhs
e
eta_would_wreck_join (Tick CoreTickish
_ CpeRhs
e)        = CpeRhs -> Bool
eta_would_wreck_join CpeRhs
e
eta_would_wreck_join (Case CpeRhs
_ InVar
_ Type
_ [Alt InVar]
alts) = (CpeRhs -> Bool) -> [CpeRhs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CpeRhs -> Bool
eta_would_wreck_join ([Alt InVar] -> [CpeRhs]
forall b. [Alt b] -> [Expr b]
rhssOfAlts [Alt InVar]
alts)
eta_would_wreck_join CpeRhs
_                 = Bool
False

maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs
maybeSaturate :: InVar -> CpeRhs -> Int -> [CoreTickish] -> UniqSM CpeRhs
maybeSaturate InVar
fn CpeRhs
expr Int
n_args [CoreTickish]
unsat_ticks
  | InVar -> Bool
hasNoBinding InVar
fn        -- There's no binding
    -- See Note [Eta expansion of hasNoBinding things in CorePrep]
  = CpeRhs -> UniqSM CpeRhs
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeRhs -> UniqSM CpeRhs) -> CpeRhs -> UniqSM CpeRhs
forall a b. (a -> b) -> a -> b
$ (CpeRhs -> CpeRhs) -> CpeRhs -> CpeRhs
wrapLamBody (\CpeRhs
body -> (CoreTickish -> CpeRhs -> CpeRhs)
-> CpeRhs -> [CoreTickish] -> CpeRhs
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CpeRhs -> CpeRhs
mkTick CpeRhs
body [CoreTickish]
unsat_ticks) CpeRhs
sat_expr

  | Int
mark_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -- A call-by-value function. See Note [CBV Function Ids]
  , Bool -> Bool
not Bool
applied_marks
  = Bool -> SDoc -> UniqSM CpeRhs -> UniqSM CpeRhs
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr
      ( Bool -> Bool
not (InVar -> Bool
isJoinId InVar
fn)) -- See Note [Do not eta-expand join points]
      ( InVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr InVar
fn SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CpeRhs -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeRhs
expr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"n_args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"marks:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InVar -> Maybe [CbvMark]
idCbvMarks_maybe InVar
fn) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"join_arity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> JoinPointHood -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InVar -> JoinPointHood
idJoinPointHood InVar
fn) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fn_arity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
fn_arity
       ) (UniqSM CpeRhs -> UniqSM CpeRhs) -> UniqSM CpeRhs -> UniqSM CpeRhs
forall a b. (a -> b) -> a -> b
$
    -- pprTrace "maybeSat"
    --   ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$
    --       text "marks:" <+> ppr (idCbvMarks_maybe fn) $$
    --       text "join_arity" <+> ppr (isJoinId_maybe fn) $$
    --       text "fn_arity" <+> ppr fn_arity $$
    --       text "excess_arity" <+> ppr excess_arity $$
    --       text "mark_arity" <+> ppr mark_arity
    --    ) $
    CpeRhs -> UniqSM CpeRhs
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CpeRhs
sat_expr

  | Bool
otherwise
  = Bool -> UniqSM CpeRhs -> UniqSM CpeRhs
forall a. HasCallStack => Bool -> a -> a
assert ([CoreTickish] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreTickish]
unsat_ticks) (UniqSM CpeRhs -> UniqSM CpeRhs) -> UniqSM CpeRhs -> UniqSM CpeRhs
forall a b. (a -> b) -> a -> b
$
    CpeRhs -> UniqSM CpeRhs
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CpeRhs
expr
  where
    mark_arity :: Int
mark_arity    = InVar -> Int
idCbvMarkArity InVar
fn
    fn_arity :: Int
fn_arity      = InVar -> Int
idArity InVar
fn
    excess_arity :: Int
excess_arity  = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
fn_arity Int
mark_arity) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_args
    sat_expr :: CpeRhs
sat_expr      = Int -> CpeRhs -> CpeRhs
cpeEtaExpand Int
excess_arity CpeRhs
expr
    applied_marks :: Bool
applied_marks = Int
n_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ([CbvMark] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CbvMark] -> Int)
-> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CbvMark -> Bool) -> [CbvMark] -> [CbvMark]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (CbvMark -> Bool) -> CbvMark -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CbvMark -> Bool
isMarkedCbv) ([CbvMark] -> [CbvMark])
-> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               [CbvMark] -> [CbvMark]
forall a. [a] -> [a]
reverse ([CbvMark] -> [CbvMark])
-> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe [CbvMark] -> [CbvMark]
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"maybeSaturate" (Maybe [CbvMark] -> Int) -> Maybe [CbvMark] -> Int
forall a b. (a -> b) -> a -> b
$ (InVar -> Maybe [CbvMark]
idCbvMarks_maybe InVar
fn))
    -- For join points we never eta-expand (See Note [Do not eta-expand join points])
    -- so we assert all arguments that need to be passed cbv are visible so that the
    -- backend can evalaute them if required..

{- Note [Eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~
Eta expand to match the arity claimed by the binder Remember,
CorePrep must not change arity

Eta expansion might not have happened already, because it is done by
the simplifier only when there at least one lambda already.

NB1:we could refrain when the RHS is trivial (which can happen
    for exported things).  This would reduce the amount of code
    generated (a little) and make things a little worse for
    code compiled without -O.  The case in point is data constructor
    wrappers.

NB2: we have to be careful that the result of etaExpand doesn't
   invalidate any of the assumptions that CorePrep is attempting
   to establish.  One possible cause is eta expanding inside of
   an SCC note - we're now careful in etaExpand to make sure the
   SCC is pushed inside any new lambdas that are generated.

Note [Eta expansion of hasNoBinding things in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
maybeSaturate deals with eta expanding to saturate things that can't deal
with unsaturated applications (identified by 'hasNoBinding', currently
foreign calls, unboxed tuple/sum constructors, and representation-polymorphic
primitives such as 'coerce' and 'unsafeCoerce#').

Historical Note: Note that eta expansion in CorePrep used to be very fragile
due to the "prediction" of CAFfyness that we used to make during tidying.  We
previously saturated primop applications here as well but due to this
fragility (see #16846) we now deal with this another way, as described in
Note [Primop wrappers] in GHC.Builtin.PrimOps.

Note [Eta expansion and the CorePrep invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It turns out to be much much easier to do eta expansion
*after* the main CorePrep stuff.  But that places constraints
on the eta expander: given a CpeRhs, it must return a CpeRhs.

For example here is what we do not want:
                f = /\a -> g (h 3)      -- h has arity 2
After ANFing we get
                f = /\a -> let s = h 3 in g s
and now we do NOT want eta expansion to give
                f = /\a -> \ y -> (let s = h 3 in g s) y

Instead GHC.Core.Opt.Arity.etaExpand gives
                f = /\a -> \y -> let s = h 3 in g s y

Note [Eta expansion of arguments in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to

  let t = g x
  in f t

We really don't want that `t` to be a thunk! That just wastes runtime, updating
a thunk with a PAP etc. The code generator could in principle allocate a PAP,
but in fact it does not know how to do that -- it's easier just to eta-expand:

  let t = \y. g x y
  in f t

To what arity should we eta-expand the argument? `cpeArg` uses two strategies,
governed by the presence of `-fdo-clever-arg-eta-expansion` (implied by -O):

  1. Cheap, with -O0: just use `exprArity`.
  2. More clever but expensive, with -O1 -O2: use `exprEtaExpandArity`,
     same function the Simplifier uses to eta expand RHSs and lambda bodies.

The only reason for using (1) rather than (2) is to keep compile times down.
Using (2) in -O0 bumped up compiler allocations by 2-3% in tests T4801 and
T5321*. However, Plan (2) catches cases that (1) misses.
For example (#23083, assuming -fno-pedantic-bottoms):

  let t = case z of __DEFAULT -> g x
  in f t

to

  let t = \y -> case z of __DEFAULT -> g x y
  in f t

Note that there is a missed opportunity in eta expanding `t` earlier, in the
Simplifier: It would allow us to inline `g`, potentially enabling further
simplification. But then we could have inlined `g` into the PAP to begin with,
and that is discussed in #23150; hence we needn't worry about that in CorePrep.

There is a nasty Wrinkle:

(EA1) When eta expanding an argument headed by a join point, we might get
      "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts
      it.  This crap means the output does not conform to the syntax in
      Note [CorePrep invariants], which then makes later passes crash (#25033).
      Consider

        f (join j x = rhs in ...(j 1)...(j 2)...)

      where the argument has arity 1. We might be tempted to eta expand, to

        f (\y -> (join j x = rhs in ...(j 1)...(j 2)...) y)

      Why hasn't the App to `y` been pushed into the join point? That's exactly
      the crap of Note [Eta expansion for join points], so we have to put up
      with it here.
      In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid
      `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App
      case of `coreToStgExpr`.

      Hence, in `eta_would_wreck_join`, we check for the cases where an
      intervening join point binding in the tail context of the argument would
      make eta-expansion break Note [CorePrep invariants], in which
      case we abstain from eta expansion.

      This scenario occurs rarely; hence it's OK to generate sub-optimal code.
      The alternative would be to fix Note [Eta expansion for join points], but
      that's quite challenging due to unfoldings of (recursive) join points.

      `eta_would_wreck_join` sees if there are any join points, like `j` above
      that would be messed up.   It must look inside lambdas (#25033); consider
             f (\x. join j y = ... in ...(j 1)...(j 3)...)
      We can't eta expand that `\x` any more than we could if the join was at
      the top.  (And when there's a lambda, we don't have a thunk anyway.)

(EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like
           let <binds> in rhs
      where <binds> is non-empty and can't be floated out of a lazy context (see
      `wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0
      forthwith.  Without this short-cut we will call exprEtaExpandArity on the
      `arg`, and <binds> might be enormous. exprEtaExpandArity be very expensive
      on this: it uses arityType, and may look at <binds>.

      On the other hand, if float_decision = FloatAll, there will be no
      let-bindings around 'arg'; they will have floated out.  So
      exprEtaExpandArity is cheap.

      This can make a huge difference on deeply nested expressions like
         f (f (f (f (f  ...))))
      #24471 is a good example, where Prep took 25% of compile time!
-}

cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
cpeEtaExpand :: Int -> CpeRhs -> CpeRhs
cpeEtaExpand Int
arity CpeRhs
expr
  | Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = CpeRhs
expr
  | Bool
otherwise  = Int -> CpeRhs -> CpeRhs
etaExpand Int
arity CpeRhs
expr

{-
************************************************************************
*                                                                      *
                Floats
*                                                                      *
************************************************************************

Note [Pin demand info on floats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We pin demand info on floated lets, so that we can see the one-shot thunks.
For example,
  f (g x)
where `f` uses its argument at least once, creates a Float for `y = g x` and we
should better pin appropriate demand info on `y`.

Note [Flatten case-binds]
~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have the following call, where f is strict:
   f (case x of DEFAULT -> blah)
(For the moment, ignore the fact that the Simplifier will have floated that
`case` out because `f` is strict.)
In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind`

    Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl

with the call `f a`.  When we wrap that `Float` we will get

   case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a }

which is a bit silly. Actually the rest of the back end can cope with nested
cases like this, but it is harder to read and we'd prefer the more direct:

   case x of y { DEFAULT ->
   case blah of a { DEFAULT -> f a }}

This is easy to avoid: turn that

   case x of DEFAULT -> blah

into a FloatingBind of its own.  This is easily done in the Case
equation for `cpsRhsE`.  Then our example will generate /two/ floats:

    Float (y = x)    CaseBound top_lvl
    Float (a = blah) CaseBound top_lvl

and we'll end up with nested cases.

Of course, the Simplifier never leaves us with an argument like this, but we
/can/ see

  data T a = T !a
  ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs

and the above footwork in cpsRhsE avoids generating a nested case.


Note [Speculative evaluation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since call-by-value is much cheaper than call-by-need, we case-bind arguments
that are either

  1. Strictly evaluated anyway, according to the DmdSig of the callee, or
  2. ok-for-spec, according to 'exprOkForSpeculation'.
     This includes DFuns `$fEqList a`, for example.
     (Could identify more in the future; see reference to !1866 below.)

While (1) is a no-brainer and always beneficial, (2) is a bit
more subtle, as the careful haddock for 'exprOkForSpeculation'
points out. Still, by case-binding the argument we don't need
to allocate a thunk for it, whose closure must be retained as
long as the callee might evaluate it. And if it is evaluated on
most code paths anyway, we get to turn the unknown eval in the
callee into a known call at the call site.

Very Nasty Wrinkle

We must be very careful not to speculate recursive calls!  Doing so
might well change termination behavior.

That comes up in practice for DFuns, which are considered ok-for-spec,
because they always immediately return a constructor.
See Note [NON-BOTTOM-DICTS invariant] in GHC.Core.

But not so if you speculate the recursive call, as #20836 shows:

  class Foo m => Foo m where
    runFoo :: m a -> m a
  newtype Trans m a = Trans { runTrans :: m a }
  instance Monad m => Foo (Trans m) where
    runFoo = id

(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The
example in #20836 is more compelling, but boils down to the same thing.)
This program compiles to the following DFun for the `Trans` instance:

  Rec {
  $fFooTrans
    = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)
  end Rec }

Note that the DFun immediately terminates and produces a dictionary, just
like DFuns ought to, but it calls itself recursively to produce the `Foo m`
dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so
that we can speculate its calls, and hence use call-by-value, we get:

  $fFooTrans
    = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->
                      C:Foo sc (\ @a -> id)

and that's an infinite loop!
Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the
*body* of the letrec, it's absolutely fine to use call-by-value on
`foo ($fFooTrans d)`.

Our solution is this: we track in cpe_rec_ids the set of enclosing
recursively-bound Ids, the RHSs of which we are currently transforming and then
in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',
basically) we'll say that any binder in this set is not ok-for-spec.

Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we
prep up `rhs1`, we have to include not only `f1`, but all binders of the group
`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive
DFuns.

NB: If at some point we decide to have a termination analysis for general
functions (#8655, !1866), we need to take similar precautions for (guarded)
recursive functions:

  repeat x = x : repeat x

Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`
is a cheap call that we are willing to speculate, but *not* in repeat's RHS.
Fortunately, pce_rec_ids already has all the information we need in that case.

The problem is very similar to Note [Eta reduction in recursive RHSs].
Here as well as there it is *unsound* to change the termination properties
of the very function whose termination properties we are exploiting.

It is also similar to Note [Do not strictify a DFun's parameter dictionaries],
where marking recursive DFuns (of undecidable *instances*) strict in dictionary
*parameters* leads to quite the same change in termination as above.

Note [BindInfo and FloatInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The `BindInfo` of a `Float` describes whether it will be case-bound or
let-bound:

  * `LetBound`: A let binding `let x = rhs in ...`, can be Rec or NonRec.
  * `CaseBound`: A case binding `case rhs of x -> { __DEFAULT -> .. }`.
                 (So always NonRec.)
                 Some case-bound things (string literals, lifted bindings)
                 can float to top-level (but not all), hence it is similar
                 to, but not the same as `StrictContextFloatable :: FloatInfo`
                 described below.

This info is used in `wrapBinds` to pick the corresponding binding form.

We want to case-bind iff the binding is (non-recursive, and) either

  * ok-for-spec-eval (and perhaps lifted, see Note [Speculative evaluation]), or
  * unlifted, or
  * strictly used

The `FloatInfo` of a `Float` describes how far it can float without
(a) violating Core invariants and (b) changing semantics.

  * Any binding is at least `StrictContextFloatable`, meaning we may float it
    out of a strict context such as `f <>` where `f` is strict.
    We may never float out of a Case alternative `case e of p -> <>`, though,
    even if we made sure that `p` does not capture any variables of the float,
    because that risks sequencing guarantees of Note [seq# magic].

  * A binding is `LazyContextFloatable` if we may float it out of a lazy context
    such as `let x = <> in Just x`.
    Counterexample: A strict or unlifted binding that isn't ok-for-spec-eval
                    such as `case divInt# x y of r -> { __DEFAULT -> I# r }`.
                    Here, we may not foat out the strict `r = divInt# x y`.

  * A binding is `TopLvlFloatable` if it is `LazyContextFloatable` and also can
    be bound at the top level.
    Counterexample: A strict or unlifted binding (ok-for-spec-eval or not)
                    such as `case x +# y of r -> { __DEFAULT -> I# r }`.

This meaning of "at least" is encoded in `floatsAtLeastAsFarAs`.
Note that today, `LetBound` implies `TopLvlFloatable`, so we could make do with
the the following enum (check `mkNonRecFloat` for whether this is up to date):

   LetBoundTopLvlFloatable          (lifted or boxed values)
  CaseBoundTopLvlFloatable          (strings, ok-for-spec-eval and lifted)
  CaseBoundLazyContextFloatable     (ok-for-spec-eval and unlifted)
  CaseBoundStrictContextFloatable   (not ok-for-spec-eval and unlifted)

Although there is redundancy in the current encoding, SG thinks it is cleaner
conceptually.

See also Note [Floats and FloatDecision] for how we maintain whole groups of
floats and how far they go.

Note [Floats and FloatDecision]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have a special datatype `Floats` for modelling a telescope of `FloatingBind`
and caching its "maximum" `FloatInfo`, according to `floatsAtLeastAsFarAs`
(see Note [BindInfo and FloatInfo] for the ordering).
There are several operations for creating and combining `Floats` that maintain
scoping and the cached `FloatInfo`.

When deciding whether we want to float out a `Floats` out of a binding context
such as `let x = <> in e` (let), `f <>` (app), or `x = <>; ...` (top-level),
we consult the cached `FloatInfo` of the `Floats`:

  * If we want to float to the top-level (`x = <>; ...`), we check whether
    we may float-at-least-as-far-as `TopLvlFloatable`, in which case we
    respond with `FloatAll :: FloatDecision`; otherwise we say `FloatNone`.
  * If we want to float locally (let or app), then the floating decision is
    described in Note [wantFloatLocal].

`executeFloatDecision` is then used to act on the particular `FloatDecision`.
-}

-- See Note [BindInfo and FloatInfo]
data BindInfo
  = CaseBound -- ^ A strict binding
  | LetBound  -- ^ A lazy or value binding
  deriving BindInfo -> BindInfo -> Bool
(BindInfo -> BindInfo -> Bool)
-> (BindInfo -> BindInfo -> Bool) -> Eq BindInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BindInfo -> BindInfo -> Bool
== :: BindInfo -> BindInfo -> Bool
$c/= :: BindInfo -> BindInfo -> Bool
/= :: BindInfo -> BindInfo -> Bool
Eq

-- See Note [BindInfo and FloatInfo]
data FloatInfo
  = TopLvlFloatable
  -- ^ Anything that can be bound at top-level, such as arbitrary lifted
  -- bindings or anything that responds True to `exprIsHNF`, such as literals or
  -- saturated DataCon apps where unlifted or strict args are values.

  | LazyContextFloatable
  -- ^ Anything that can be floated out of a lazy context.
  -- In addition to any 'TopLvlFloatable' things, this includes (unlifted)
  -- bindings that are ok-for-spec that we intend to case-bind.

  | StrictContextFloatable
  -- ^ Anything that can be floated out of a strict evaluation context.
  -- That is possible for all bindings; this is the Top element of 'FloatInfo'.

  deriving FloatInfo -> FloatInfo -> Bool
(FloatInfo -> FloatInfo -> Bool)
-> (FloatInfo -> FloatInfo -> Bool) -> Eq FloatInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FloatInfo -> FloatInfo -> Bool
== :: FloatInfo -> FloatInfo -> Bool
$c/= :: FloatInfo -> FloatInfo -> Bool
/= :: FloatInfo -> FloatInfo -> Bool
Eq

instance Outputable BindInfo where
  ppr :: BindInfo -> SDoc
ppr BindInfo
CaseBound = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Case"
  ppr BindInfo
LetBound  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Let"

instance Outputable FloatInfo where
  ppr :: FloatInfo -> SDoc
ppr FloatInfo
TopLvlFloatable = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"top-lvl"
  ppr FloatInfo
LazyContextFloatable = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lzy-ctx"
  ppr FloatInfo
StrictContextFloatable = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"str-ctx"

-- See Note [Floating in CorePrep]
-- and Note [BindInfo and FloatInfo]
data FloatingBind
  = Float !CoreBind !BindInfo !FloatInfo    -- Never a join-point binding
  | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr]
  | FloatTick CoreTickish

-- See Note [Floats and FloatDecision]
data Floats
  = Floats
  { Floats -> FloatInfo
fs_info  :: !FloatInfo
  , Floats -> OrdList FloatingBind
fs_binds :: !(OrdList FloatingBind)
  }

instance Outputable FloatingBind where
  ppr :: FloatingBind -> SDoc
ppr (Float CoreBind
b BindInfo
bi FloatInfo
fi) = BindInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr BindInfo
bi SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FloatInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatInfo
fi SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b
  ppr (FloatTick CoreTickish
t) = CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
t
  ppr (UnsafeEqualityCase CpeRhs
scrut InVar
b AltCon
k [InVar]
bs) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"case" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CpeRhs -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeRhs
scrut
                                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"of"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr InVar
b SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"@"
                                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> case [InVar]
bs of
                                   [] -> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k
                                   [InVar]
_  -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [InVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InVar]
bs)

instance Outputable Floats where
  ppr :: Floats -> SDoc
ppr (Floats FloatInfo
info OrdList FloatingBind
binds) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Floats" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (FloatInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatInfo
info) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (OrdList FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr OrdList FloatingBind
binds)

lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo FloatInfo
StrictContextFloatable FloatInfo
_                      = FloatInfo
StrictContextFloatable
lubFloatInfo FloatInfo
_                      FloatInfo
StrictContextFloatable = FloatInfo
StrictContextFloatable
lubFloatInfo FloatInfo
LazyContextFloatable   FloatInfo
_                      = FloatInfo
LazyContextFloatable
lubFloatInfo FloatInfo
_                      FloatInfo
LazyContextFloatable   = FloatInfo
LazyContextFloatable
lubFloatInfo FloatInfo
TopLvlFloatable        FloatInfo
TopLvlFloatable        = FloatInfo
TopLvlFloatable

floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool
-- See Note [Floats and FloatDecision]
floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool
floatsAtLeastAsFarAs FloatInfo
l FloatInfo
r = FloatInfo
l FloatInfo -> FloatInfo -> FloatInfo
`lubFloatInfo` FloatInfo
r FloatInfo -> FloatInfo -> Bool
forall a. Eq a => a -> a -> Bool
== FloatInfo
r

emptyFloats :: Floats
emptyFloats :: Floats
emptyFloats = FloatInfo -> OrdList FloatingBind -> Floats
Floats FloatInfo
TopLvlFloatable OrdList FloatingBind
forall a. OrdList a
nilOL

isEmptyFloats :: Floats -> Bool
isEmptyFloats :: Floats -> Bool
isEmptyFloats (Floats FloatInfo
_ OrdList FloatingBind
b) = OrdList FloatingBind -> Bool
forall a. OrdList a -> Bool
isNilOL OrdList FloatingBind
b

getFloats :: Floats -> OrdList FloatingBind
getFloats :: Floats -> OrdList FloatingBind
getFloats = Floats -> OrdList FloatingBind
fs_binds

unitFloat :: FloatingBind -> Floats
unitFloat :: FloatingBind -> Floats
unitFloat = Floats -> FloatingBind -> Floats
snocFloat Floats
emptyFloats

floatInfo :: FloatingBind -> FloatInfo
floatInfo :: FloatingBind -> FloatInfo
floatInfo (Float CoreBind
_ BindInfo
_ FloatInfo
info)     = FloatInfo
info
floatInfo UnsafeEqualityCase{} = FloatInfo
LazyContextFloatable -- See Note [Floating in CorePrep]
floatInfo FloatTick{}          = FloatInfo
TopLvlFloatable      -- We filter these out in cpePair,
                                                      -- see Note [Floating Ticks in CorePrep]

-- | Append a `FloatingBind` `b` to a `Floats` telescope `bs` that may reference any
-- binding of the 'Floats'.
snocFloat :: Floats -> FloatingBind -> Floats
snocFloat :: Floats -> FloatingBind -> Floats
snocFloat Floats
floats FloatingBind
fb =
  Floats { fs_info :: FloatInfo
fs_info  = FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo (Floats -> FloatInfo
fs_info Floats
floats) (FloatingBind -> FloatInfo
floatInfo FloatingBind
fb)
         , fs_binds :: OrdList FloatingBind
fs_binds = Floats -> OrdList FloatingBind
fs_binds Floats
floats OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
fb }

-- | Cons a `FloatingBind` `b` to a `Floats` telescope `bs` which scopes over
-- `b`.
consFloat :: FloatingBind -> Floats -> Floats
consFloat :: FloatingBind -> Floats -> Floats
consFloat FloatingBind
fb Floats
floats =
  Floats { fs_info :: FloatInfo
fs_info  = FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo (Floats -> FloatInfo
fs_info Floats
floats) (FloatingBind -> FloatInfo
floatInfo FloatingBind
fb)
         , fs_binds :: OrdList FloatingBind
fs_binds = FloatingBind
fb FloatingBind -> OrdList FloatingBind -> OrdList FloatingBind
forall a. a -> OrdList a -> OrdList a
`consOL`  Floats -> OrdList FloatingBind
fs_binds Floats
floats }

-- | Append two telescopes, nesting the right inside the left.
appFloats :: Floats -> Floats -> Floats
appFloats :: Floats -> Floats -> Floats
appFloats Floats
outer Floats
inner =
  Floats { fs_info :: FloatInfo
fs_info  = FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo (Floats -> FloatInfo
fs_info Floats
outer) (Floats -> FloatInfo
fs_info Floats
inner)
         , fs_binds :: OrdList FloatingBind
fs_binds = Floats -> OrdList FloatingBind
fs_binds Floats
outer OrdList FloatingBind
-> OrdList FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Floats -> OrdList FloatingBind
fs_binds Floats
inner }

-- | Zip up two `Floats`, none of which scope over the other
zipFloats :: Floats -> Floats -> Floats
-- We may certainly just nest one telescope in the other, so appFloats is a
-- valid implementation strategy.
zipFloats :: Floats -> Floats -> Floats
zipFloats = Floats -> Floats -> Floats
appFloats

-- | `zipFloats` a bunch of independent telescopes.
zipManyFloats :: [Floats] -> Floats
zipManyFloats :: [Floats] -> Floats
zipManyFloats = (Floats -> Floats -> Floats) -> Floats -> [Floats] -> Floats
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Floats -> Floats -> Floats
zipFloats Floats
emptyFloats

mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind
mkCaseFloat :: Bool -> InVar -> CpeRhs -> FloatingBind
mkCaseFloat Bool
is_unlifted InVar
bndr CpeRhs
scrut
  = CoreBind -> BindInfo -> FloatInfo -> FloatingBind
Float (InVar -> CpeRhs -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
bndr CpeRhs
scrut) BindInfo
bound FloatInfo
info
  where
    (BindInfo
bound, FloatInfo
info)
{-
Eventually we want the following code, when #20749 is fixed.
      | is_lifted, is_hnf        = (LetBound,  TopLvlFloatable)
          -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should
          -- let-bind `StrictBox x'` after Note [Flatten case-binds].
-}
      | CpeRhs -> Bool
exprIsTickedString CpeRhs
scrut = (BindInfo
CaseBound, FloatInfo
TopLvlFloatable)
          -- String literals are unboxed (so must be case-bound) and float to
          -- the top-level
      | Bool
otherwise                = (BindInfo
CaseBound, FloatInfo
StrictContextFloatable)
         -- For a Case, we never want to drop the eval; hence no need to test
         -- for ok-for-spec-eval
    _is_lifted :: Bool
_is_lifted   = Bool -> Bool
not Bool
is_unlifted
    _is_hnf :: Bool
_is_hnf      = CpeRhs -> Bool
exprIsHNF CpeRhs
scrut

mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind
mkNonRecFloat :: CorePrepEnv -> Bool -> InVar -> CpeRhs -> FloatingBind
mkNonRecFloat CorePrepEnv
env Bool
is_unlifted InVar
bndr CpeRhs
rhs
  = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)
    --                             <+> ppr is_lifted <+> ppr is_strict
    --                             <+> ppr ok_for_spec
    --                           $$ ppr rhs) $
    CoreBind -> BindInfo -> FloatInfo -> FloatingBind
Float (InVar -> CpeRhs -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
bndr CpeRhs
rhs) BindInfo
bound FloatInfo
info
  where
    (BindInfo
bound, FloatInfo
info)
      | Bool
is_lifted, Bool
is_hnf        = (BindInfo
LetBound, FloatInfo
TopLvlFloatable)
          -- is_lifted: We currently don't allow unlifted values at the
          --            top-level or inside letrecs
          --            (but SG thinks that in principle, we should)
      | InVar -> Bool
is_data_con InVar
bndr         = (BindInfo
LetBound, FloatInfo
TopLvlFloatable)
          -- We need this special case for nullary unlifted DataCon
          -- workers/wrappers (top-level bindings) until #17521 is fixed
      | CpeRhs -> Bool
exprIsTickedString CpeRhs
rhs   = (BindInfo
CaseBound, FloatInfo
TopLvlFloatable)
          -- String literals are unboxed (so must be case-bound) and float to
          -- the top-level
      | Bool
is_unlifted, Bool
ok_for_spec = (BindInfo
CaseBound, FloatInfo
LazyContextFloatable)
      | Bool
is_lifted,   Bool
ok_for_spec = (BindInfo
CaseBound, FloatInfo
TopLvlFloatable)
          -- See Note [Speculative evaluation]
          -- Ok-for-spec-eval things will be case-bound, lifted or not.
          -- But when it's lifted we are ok with floating it to top-level
          -- (where it is actually bound lazily).
      | Bool
is_unlifted Bool -> Bool -> Bool
|| Bool
is_strict = (BindInfo
CaseBound, FloatInfo
StrictContextFloatable)
          -- These will never be floated out of a lazy RHS context
      | Bool
otherwise                = Bool -> SDoc -> (BindInfo, FloatInfo) -> (BindInfo, FloatInfo)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
is_lifted (CpeRhs -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeRhs
rhs) ((BindInfo, FloatInfo) -> (BindInfo, FloatInfo))
-> (BindInfo, FloatInfo) -> (BindInfo, FloatInfo)
forall a b. (a -> b) -> a -> b
$
                                   (BindInfo
LetBound, FloatInfo
TopLvlFloatable)
          -- And these float freely but can't be speculated, hence LetBound

    is_lifted :: Bool
is_lifted   = Bool -> Bool
not Bool
is_unlifted
    is_hnf :: Bool
is_hnf      = CpeRhs -> Bool
exprIsHNF CpeRhs
rhs
    dmd :: Demand
dmd         = InVar -> Demand
idDemandInfo InVar
bndr
    is_strict :: Bool
is_strict   = Demand -> Bool
isStrUsedDmd Demand
dmd
    ok_for_spec :: Bool
ok_for_spec = (InVar -> Bool) -> CpeRhs -> Bool
exprOkForSpecEval (Bool -> Bool
not (Bool -> Bool) -> (InVar -> Bool) -> InVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InVar -> Bool
is_rec_call) CpeRhs
rhs
    is_rec_call :: InVar -> Bool
is_rec_call = (InVar -> UnVarSet -> Bool
`elemUnVarSet` CorePrepEnv -> UnVarSet
cpe_rec_ids CorePrepEnv
env)
    is_data_con :: InVar -> Bool
is_data_con = Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (Maybe DataCon -> Bool)
-> (InVar -> Maybe DataCon) -> InVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InVar -> Maybe DataCon
isDataConId_maybe

-- | Wrap floats around an expression
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds :: Floats -> CpeRhs -> CpeRhs
wrapBinds Floats
floats CpeRhs
body
  = -- pprTraceWith "wrapBinds" (\res -> ppr floats $$ ppr body $$ ppr res) $
    (FloatingBind -> CpeRhs -> CpeRhs)
-> CpeRhs -> OrdList FloatingBind -> CpeRhs
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CpeRhs -> CpeRhs
mk_bind CpeRhs
body (Floats -> OrdList FloatingBind
getFloats Floats
floats)
  where
    -- See Note [BindInfo and FloatInfo] on whether we pick Case or Let here
    mk_bind :: FloatingBind -> CpeRhs -> CpeRhs
mk_bind f :: FloatingBind
f@(Float CoreBind
bind BindInfo
CaseBound FloatInfo
_) CpeRhs
body
      | NonRec InVar
bndr CpeRhs
rhs <- CoreBind
bind
      = CpeRhs -> InVar -> CpeRhs -> CpeRhs
mkDefaultCase CpeRhs
rhs InVar
bndr CpeRhs
body
      | Bool
otherwise
      = String -> SDoc -> CpeRhs
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"wrapBinds" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
f)
    mk_bind (Float CoreBind
bind BindInfo
_ FloatInfo
_) CpeRhs
body
      = CoreBind -> CpeRhs -> CpeRhs
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CpeRhs
body
    mk_bind (UnsafeEqualityCase CpeRhs
scrut InVar
b AltCon
con [InVar]
bs) CpeRhs
body
      = CpeRhs -> InVar -> AltCon -> [InVar] -> CpeRhs -> CpeRhs
mkSingleAltCase CpeRhs
scrut InVar
b AltCon
con [InVar]
bs CpeRhs
body
    mk_bind (FloatTick CoreTickish
tickish) CpeRhs
body
      = CoreTickish -> CpeRhs -> CpeRhs
mkTick CoreTickish
tickish CpeRhs
body

-- | Put floats at top-level
deFloatTop :: Floats -> [CoreBind]
-- Precondition: No Strict or LazyContextFloatable 'FloatInfo', no ticks!
deFloatTop :: Floats -> CoreProgram
deFloatTop Floats
floats
  = (FloatingBind -> CoreProgram -> CoreProgram)
-> CoreProgram -> OrdList FloatingBind -> CoreProgram
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CoreProgram -> CoreProgram
get [] (Floats -> OrdList FloatingBind
getFloats Floats
floats)
  where
    get :: FloatingBind -> CoreProgram -> CoreProgram
get (Float CoreBind
b BindInfo
_ FloatInfo
TopLvlFloatable) CoreProgram
bs
      = CoreBind -> CoreBind
get_bind CoreBind
b CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
bs
    get FloatingBind
b CoreProgram
_  = String -> SDoc -> CoreProgram
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"deFloatTop" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
b)

    -- See Note [Dead code in CorePrep]
    get_bind :: CoreBind -> CoreBind
get_bind (NonRec InVar
x CpeRhs
e) = InVar -> CpeRhs -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
x (CpeRhs -> CpeRhs
occurAnalyseExpr CpeRhs
e)
    get_bind (Rec [(InVar, CpeRhs)]
xes)    = [(InVar, CpeRhs)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(InVar
x, CpeRhs -> CpeRhs
occurAnalyseExpr CpeRhs
e) | (InVar
x, CpeRhs
e) <- [(InVar, CpeRhs)]
xes]

---------------------------------------------------------------------------

{- Note [wantFloatLocal]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  let x = let y = e1 in e2
  in e
Similarly for `(\x. e) (let y = e1 in e2)`.
Do we want to float out `y` out of `x`?
(This is discussed in detail in the paper
"Let-floating: moving bindings to give faster programs".)

`wantFloatLocal` is concerned with answering this question.
It considers the Demand on `x`, whether or not `e2` is unlifted and the
`FloatInfo` of the `y` binding (e.g., it might itself be unlifted, a value,
strict, or ok-for-spec).

We float out if ...
  1. ... the binding context is strict anyway, so either `x` is used strictly
     or has unlifted type.
     Doing so is trivially sound and won`t increase allocations, so we
     return `FloatAll`.
     This might happen while ANF-ising `f (g (h 13))` where `f`,`g` are strict:
       f (g (h 13))
       ==> { ANF }
       case (case h 13 of r -> g r) of r2 -> f r2
       ==> { Float }
       case h 13 of r -> case g r of r2 -> f r2
     The latter is easier to read and grows less stack.
  2. ... `e2` becomes a value in doing so, in which case we won't need to
     allocate a thunk for `x`/the arg that closes over the FVs of `e1`.
     In general, this is only sound if `y=e1` is `LazyContextFloatable`.
     (See Note [BindInfo and FloatInfo].)
     Nothing is won if `x` doesn't become a value
     (i.e., `let x = let sat = f 14 in g sat in e`),
     so we return `FloatNone` if there is any float that is
     `StrictContextFloatable`, and return `FloatAll` otherwise.

To elaborate on (2), consider the case when the floated binding is
`e1 = divInt# a b`, e.g., not `LazyContextFloatable`:
  let x = I# (a `divInt#` b)
  in e
this ANFises to
  let x = case a `divInt#` b of r { __DEFAULT -> I# r }
  in e
If `x` is used lazily, we may not float `r` further out.
A float binding `x +# y` is OK, though, and so every ok-for-spec-eval
binding is `LazyContextFloatable`.

Wrinkles:

 (W1) When the outer binding is a letrec, i.e.,
        letrec x = case a +# b of r { __DEFAULT -> f y r }
               y = [x]
        in e
      we don't want to float `LazyContextFloatable` bindings such as `r` either
      and require `TopLvlFloatable` instead.
      The reason is that we don't track FV of FloatBindings, so we would need
      to park them in the letrec,
        letrec r = a +# b -- NB: r`s RHS might scope over x and y
               x = f y r
               y = [x]
        in e
      and now we have violated Note [Core letrec invariant].
      So we preempt this case in `wantFloatLocal`, responding `FloatNone` unless
      all floats are `TopLvlFloatable`.
-}

data FloatDecision
  = FloatNone
  | FloatAll

executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
executeFloatDecision FloatDecision
dec Floats
floats CpeRhs
rhs
  = case FloatDecision
dec of
      FloatDecision
FloatAll                 -> (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeRhs
rhs)
      FloatDecision
FloatNone
        | Floats -> Bool
isEmptyFloats Floats
floats -> (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeRhs
rhs)
        | Bool
otherwise            -> do { (floats', body) <- CpeRhs -> UniqSM (Floats, CpeRhs)
rhsToBody CpeRhs
rhs
                                     ; return (emptyFloats, wrapBinds floats $
                                                            wrapBinds floats' body) }
            -- FloatNone case: `rhs` might have lambdas, and we can't
            -- put them inside a wrapBinds, which expects a `CpeBody`.

wantFloatTop :: Floats -> FloatDecision
wantFloatTop :: Floats -> FloatDecision
wantFloatTop Floats
fs
  | Floats -> FloatInfo
fs_info Floats
fs FloatInfo -> FloatInfo -> Bool
`floatsAtLeastAsFarAs` FloatInfo
TopLvlFloatable = FloatDecision
FloatAll
  | Bool
otherwise                                         = FloatDecision
FloatNone

wantFloatLocal :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision
-- See Note [wantFloatLocal]
wantFloatLocal :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> FloatDecision
wantFloatLocal RecFlag
is_rec Demand
rhs_dmd Bool
rhs_is_unlifted Floats
floats CpeRhs
rhs
  |  Floats -> Bool
isEmptyFloats Floats
floats -- Well yeah...
  Bool -> Bool -> Bool
|| Demand -> Bool
isStrUsedDmd Demand
rhs_dmd -- Case (1) of Note [wantFloatLocal]
  Bool -> Bool -> Bool
|| Bool
rhs_is_unlifted      -- dito
  Bool -> Bool -> Bool
|| (Floats -> FloatInfo
fs_info Floats
floats FloatInfo -> FloatInfo -> Bool
`floatsAtLeastAsFarAs` FloatInfo
max_float_info Bool -> Bool -> Bool
&& CpeRhs -> Bool
exprIsHNF CpeRhs
rhs)
                          -- Case (2) of Note [wantFloatLocal]
  = FloatDecision
FloatAll

  | Bool
otherwise
  = FloatDecision
FloatNone
  where
    max_float_info :: FloatInfo
max_float_info | RecFlag -> Bool
isRec RecFlag
is_rec = FloatInfo
TopLvlFloatable
                   | Bool
otherwise    = FloatInfo
LazyContextFloatable
                    -- See Note [wantFloatLocal], Wrinkle (W1)
                    -- for 'is_rec'

{-
************************************************************************
*                                                                      *
                Cloning
*                                                                      *
************************************************************************
-}

-- ---------------------------------------------------------------------------
--                      The environment
-- ---------------------------------------------------------------------------

{- Note [Inlining in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is a subtle but important invariant that must be upheld in the output
of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core
is impermissible:

     let x :: ()
         x = y

(where y is a reference to a GLOBAL variable).  Thunks like this are silly:
they can always be profitably replaced by inlining x with y. Consequently,
the code generator/runtime does not bother implementing this properly
(specifically, there is no implementation of stg_ap_0_upd_info, which is the
stack frame that would be used to update this thunk.  The "0" means it has
zero free variables.)

In general, the inliner is good at eliminating these let-bindings.  However,
there is one case where these trivial updatable thunks can arise: when
we are optimizing away 'lazy' (see Note [lazyId magic], and also
'cpeRhsE'.)  Then, we could have started with:

     let x :: ()
         x = lazy @() y

which is a perfectly fine, non-trivial thunk, but then CorePrep will drop
'lazy', giving us 'x = y' which is trivial and impermissible.  The solution is
CorePrep to have a miniature inlining pass which deals with cases like this.
We can then drop the let-binding altogether.

Why does the removal of 'lazy' have to occur in CorePrep?  The gory details
are in Note [lazyId magic] in GHC.Types.Id.Make, but the main reason is that
lazy must appear in unfoldings (optimizer output) and it must prevent
call-by-value for catch# (which is implemented by CorePrep.)

An alternate strategy for solving this problem is to have the inliner treat
'lazy e' as a trivial expression if 'e' is trivial.  We decided not to adopt
this solution to keep the definition of 'exprIsTrivial' simple.

There is ONE caveat however: for top-level bindings we have
to preserve the binding so that we float the (hacky) non-recursive
binding for data constructors; see Note [Data constructor workers].

Note [CorePrepEnv: cpe_subst]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CorePrepEnv carries a substitution `Subst` in the `cpe_subst1 field,
for these reasons:

1. To support cloning of local Ids so that they are
   all unique (see Note [Cloning in CorePrep])

2. To support beta-reduction of runRW, see Note [runRW magic] and
   Note [runRW arg].

3. To let us inline trivial RHSs of non top-level let-bindings,
   see Note [lazyId magic], Note [Inlining in CorePrep] (#12076)

   Note that, if (y::forall a. a->a), we could get
      x = lazy @(forall a.a) y @Bool
   so after eliminating `lazy`, we need to replace occurrences of `x` with
   `y @Bool`, not just `y`.  Situations like this can easily arise with
   higher-rank types; thus, `cpe_subst` must map to CoreExprs, not Ids, which
   oc course it does

4. The TyCoVar part of the substitution is used only for
   Note [Cloning CoVars and TyVars]
-}

data CorePrepConfig = CorePrepConfig
  { CorePrepConfig -> Bool
cp_catchNonexhaustiveCases :: !Bool
  -- ^ Whether to generate a default alternative with ``error`` in these
  -- cases. This is helpful when debugging demand analysis or type
  -- checker bugs which can sometimes manifest as segmentation faults.

  , CorePrepConfig -> Platform
cp_platform                :: Platform

  , CorePrepConfig -> Maybe ArityOpts
cp_arityOpts               :: !(Maybe ArityOpts)
  -- ^ Configuration for arity analysis ('exprEtaExpandArity').
  -- See Note [Eta expansion of arguments in CorePrep]
  -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead
  }

data CorePrepEnv
  = CPE { CorePrepEnv -> CorePrepConfig
cpe_config          :: !CorePrepConfig
        -- ^ This flag is intended to aid in debugging strictness
        -- analysis bugs. These are particularly nasty to chase down as
        -- they may manifest as segmentation faults. When this flag is
        -- enabled we instead produce an 'error' expression to catch
        -- the case where a function we think should bottom
        -- unexpectedly returns.

        , CorePrepEnv -> Subst
cpe_subst :: Subst  -- ^ See Note [CorePrepEnv: cpe_subst]

        , CorePrepEnv -> UnVarSet
cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
    }

mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
cfg = CPE
      { cpe_config :: CorePrepConfig
cpe_config        = CorePrepConfig
cfg
      , cpe_subst :: Subst
cpe_subst         = Subst
emptySubst
      , cpe_rec_ids :: UnVarSet
cpe_rec_ids       = UnVarSet
emptyUnVarSet
      }

extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv :: CorePrepEnv -> InVar -> InVar -> CorePrepEnv
extendCorePrepEnv cpe :: CorePrepEnv
cpe@(CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) InVar
id InVar
id'
    = CorePrepEnv
cpe { cpe_subst = subst2 }
    where
      subst1 :: Subst
subst1 = Subst -> InVar -> Subst
extendSubstInScope Subst
subst InVar
id'
      subst2 :: Subst
subst2 = Subst -> InVar -> CpeRhs -> Subst
extendIdSubst Subst
subst1 InVar
id (InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
id')

extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList :: CorePrepEnv -> [(InVar, InVar)] -> CorePrepEnv
extendCorePrepEnvList cpe :: CorePrepEnv
cpe@(CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) [(InVar, InVar)]
prs
    = CorePrepEnv
cpe { cpe_subst = subst2 }
    where
      subst1 :: Subst
subst1 = Subst -> [InVar] -> Subst
extendSubstInScopeList Subst
subst (((InVar, InVar) -> InVar) -> [(InVar, InVar)] -> [InVar]
forall a b. (a -> b) -> [a] -> [b]
map (InVar, InVar) -> InVar
forall a b. (a, b) -> b
snd [(InVar, InVar)]
prs)
      subst2 :: Subst
subst2 = Subst -> [(InVar, CpeRhs)] -> Subst
extendIdSubstList Subst
subst1 [(InVar
id, InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
id') | (InVar
id,InVar
id') <- [(InVar, InVar)]
prs]

extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr :: CorePrepEnv -> InVar -> CpeRhs -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
cpe InVar
id CpeRhs
expr
    = CorePrepEnv
cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr }

lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv :: CorePrepEnv -> InVar -> CpeRhs
lookupCorePrepEnv CorePrepEnv
cpe InVar
id
  = case HasDebugCallStack => Subst -> InVar -> Maybe CpeRhs
Subst -> InVar -> Maybe CpeRhs
lookupIdSubst_maybe (CorePrepEnv -> Subst
cpe_subst CorePrepEnv
cpe) InVar
id of
       Just CpeRhs
e -> CpeRhs
e
       Maybe CpeRhs
Nothing -> InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
id
    -- Do not use GHC.Core.Subs.lookupIdSubst because that is a no-op on GblIds;
    -- and Tidy has made top-level externally-visible Ids into GblIds

enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv
enterRecGroupRHSs :: CorePrepEnv -> [InVar] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [InVar]
grp
  = CorePrepEnv
env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }

cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy (CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) Type
ty = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
ty
          -- substTy has a short-cut if the TCvSubst is empty

cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo (CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) Coercion
co = HasDebugCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
substCo Subst
subst Coercion
co
          -- substCo has a short-cut if the TCvSubst is empty

------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------

cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bs = (CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar))
-> CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneBndr CorePrepEnv
env [InVar]
bs

cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
-- Clone the CoVar
-- See Note [Cloning CoVars and TyVars]
cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneCoVarBndr env :: CorePrepEnv
env@(CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) InVar
covar
  = Bool
-> SDoc
-> UniqSM (CorePrepEnv, InVar)
-> UniqSM (CorePrepEnv, InVar)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (InVar -> Bool
isCoVar InVar
covar) (InVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr InVar
covar) (UniqSM (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar))
-> UniqSM (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
forall a b. (a -> b) -> a -> b
$
    do { uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
       ; let covar1 = InVar -> Unique -> InVar
setVarUnique InVar
covar Unique
uniq
             covar2 = (Type -> Type) -> InVar -> InVar
updateVarType (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) InVar
covar1
             subst1 = Subst -> InVar -> InVar -> Subst
extendTCvSubstWithClone Subst
subst InVar
covar InVar
covar2
       ; return (env { cpe_subst = subst1 }, covar2) }

cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
-- See Note [Cloning in CorePrep]
cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneBndr env :: CorePrepEnv
env@(CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) InVar
bndr
  | InVar -> Bool
isTyCoVar InVar
bndr  -- See Note [Cloning CoVars and TyVars]
  = if Subst -> Bool
isEmptyTCvSubst Subst
subst    -- The common case
    then (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv
env { cpe_subst = extendSubstInScope subst bndr }, InVar
bndr)
    else -- No need to clone the Unique; but we must apply the substitution
         let bndr1 :: InVar
bndr1  = (Type -> Type) -> InVar -> InVar
updateVarType (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) InVar
bndr
             subst1 :: Subst
subst1 = Subst -> InVar -> InVar -> Subst
extendTCvSubstWithClone Subst
subst InVar
bndr InVar
bndr1
         in (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv
env { cpe_subst = subst1 }, InVar
bndr1)

  | Bool
otherwise  -- A non-CoVar Id
  = do { bndr1 <- InVar -> UniqSM InVar
forall {m :: * -> *}. MonadUnique m => InVar -> m InVar
clone_it InVar
bndr
       ; let bndr2 = (Type -> Type) -> InVar -> InVar
updateIdTypeAndMult (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) InVar
bndr1

       -- Drop (now-useless) rules/unfoldings
       -- See Note [Drop unfoldings and rules]
       -- and Note [Preserve evaluatedness] in GHC.Core.Tidy
       -- And force it.. otherwise the old unfolding is just retained.
       -- See #22071
       ; let !unfolding' = Unfolding -> Unfolding
trimUnfolding (InVar -> Unfolding
realIdUnfolding InVar
bndr)
                          -- Simplifier will set the Id's unfolding

             bndr3 = InVar
bndr2 InVar -> Unfolding -> InVar
`setIdUnfolding`      Unfolding
unfolding'
                           InVar -> RuleInfo -> InVar
`setIdSpecialisation` RuleInfo
emptyRuleInfo

       ; return (extendCorePrepEnv env bndr bndr3, bndr3) }
  where
    clone_it :: InVar -> m InVar
clone_it InVar
bndr
      | InVar -> Bool
isLocalId InVar
bndr
      = do { uniq <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
           ; return (setVarUnique bndr uniq) }

      | Bool
otherwise   -- Top level things, which we don't want
                    -- to clone, have become GlobalIds by now
      = InVar -> m InVar
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return InVar
bndr

{- Note [Drop unfoldings and rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to drop the unfolding/rules on every Id:

  - We are now past interface-file generation, and in the
    codegen pipeline, so we really don't need full unfoldings/rules

  - The unfolding/rule may be keeping stuff alive that we'd like
    to discard.  See  Note [Dead code in CorePrep]

  - Getting rid of unnecessary unfoldings reduces heap usage

  - We are changing uniques, so if we didn't discard unfoldings/rules
    we'd have to substitute in them

HOWEVER, we want to preserve evaluated-ness;
see Note [Preserve evaluatedness] in GHC.Core.Tidy.
-}

------------------------------------------------------------------------------
-- Cloning ccall Ids; each must have a unique name,
-- to give the code generator a handle to hang it on
-- ---------------------------------------------------------------------------

fiddleCCall :: Id -> UniqSM Id
fiddleCCall :: InVar -> UniqSM InVar
fiddleCCall InVar
id
  | InVar -> Bool
isFCallId InVar
id = (InVar
id InVar -> Unique -> InVar
`setVarUnique`) (Unique -> InVar) -> UniqSM Unique -> UniqSM InVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  | Bool
otherwise    = InVar -> UniqSM InVar
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return InVar
id

------------------------------------------------------------------------------
-- Generating new binders
-- ---------------------------------------------------------------------------

newVar :: Type -> UniqSM Id
newVar :: Type -> UniqSM InVar
newVar Type
ty
 = Type -> ()
seqType Type
ty () -> UniqSM InVar -> UniqSM InVar
forall a b. a -> b -> b
`seq` FastString -> Type -> Type -> UniqSM InVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m InVar
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"sat") Type
ManyTy Type
ty


------------------------------------------------------------------------------
-- Floating ticks
-- ---------------------------------------------------------------------------
--
-- Note [Floating Ticks in CorePrep]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- It might seem counter-intuitive to float ticks by default, given
-- that we don't actually want to move them if we can help it. On the
-- other hand, nothing gets very far in CorePrep anyway, and we want
-- to preserve the order of let bindings and tick annotations in
-- relation to each other. For example, if we just wrapped let floats
-- when they pass through ticks, we might end up performing the
-- following transformation:
--
--   src<...> let foo = bar in baz
--   ==>  let foo = src<...> bar in src<...> baz
--
-- Because the let-binding would float through the tick, and then
-- immediately materialize, achieving nothing but decreasing tick
-- accuracy. The only special case is the following scenario:
--
--   let foo = src<...> (let a = b in bar) in baz
--   ==>  let foo = src<...> bar; a = src<...> b in baz
--
-- Here we would not want the source tick to end up covering "baz" and
-- therefore refrain from pushing ticks outside. Instead, we copy them
-- into the floating binds (here "a") in cpePair. Note that where "b"
-- or "bar" are (value) lambdas we have to push the annotations
-- further inside in order to uphold our rules.
--
-- All of this is implemented below in @wrapTicks@.

-- | Like wrapFloats, but only wraps tick floats
wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks :: Floats -> CpeRhs -> (Floats, CpeRhs)
wrapTicks Floats
floats CpeRhs
expr
  | (Floats
floats1, OrdList CoreTickish
ticks1) <- ((OrdList FloatingBind, OrdList CoreTickish)
 -> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish))
-> Floats -> (Floats, OrdList CoreTickish)
forall {a}.
((OrdList FloatingBind, OrdList a)
 -> FloatingBind -> (OrdList FloatingBind, OrdList a))
-> Floats -> (Floats, OrdList a)
fold_fun (OrdList FloatingBind, OrdList CoreTickish)
-> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish)
go Floats
floats
  = (Floats
floats1, (CoreTickish -> CpeRhs -> CpeRhs)
-> CpeRhs -> OrdList CoreTickish -> CpeRhs
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL CoreTickish -> CpeRhs -> CpeRhs
mkTick CpeRhs
expr OrdList CoreTickish
ticks1)
  where fold_fun :: ((OrdList FloatingBind, OrdList a)
 -> FloatingBind -> (OrdList FloatingBind, OrdList a))
-> Floats -> (Floats, OrdList a)
fold_fun (OrdList FloatingBind, OrdList a)
-> FloatingBind -> (OrdList FloatingBind, OrdList a)
f Floats
floats =
           let (OrdList FloatingBind
binds, OrdList a
ticks) = ((OrdList FloatingBind, OrdList a)
 -> FloatingBind -> (OrdList FloatingBind, OrdList a))
-> (OrdList FloatingBind, OrdList a)
-> OrdList FloatingBind
-> (OrdList FloatingBind, OrdList a)
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL (OrdList FloatingBind, OrdList a)
-> FloatingBind -> (OrdList FloatingBind, OrdList a)
f (OrdList FloatingBind
forall a. OrdList a
nilOL,OrdList a
forall a. OrdList a
nilOL) (Floats -> OrdList FloatingBind
fs_binds Floats
floats)
           in (Floats
floats { fs_binds = binds }, OrdList a
ticks)
        -- Deeply nested constructors will produce long lists of
        -- redundant source note floats here. We need to eliminate
        -- those early, as relying on mkTick to spot it after the fact
        -- can yield O(n^3) complexity [#11095]
        go :: (OrdList FloatingBind, OrdList CoreTickish)
-> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish)
go (OrdList FloatingBind
flt_binds, OrdList CoreTickish
ticks) (FloatTick CoreTickish
t)
          = Bool
-> (OrdList FloatingBind, OrdList CoreTickish)
-> (OrdList FloatingBind, OrdList CoreTickish)
forall a. HasCallStack => Bool -> a -> a
assert (CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam)
            (OrdList FloatingBind
flt_binds, if (CoreTickish -> Bool) -> OrdList CoreTickish -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((CoreTickish -> CoreTickish -> Bool)
-> CoreTickish -> CoreTickish -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreTickish -> CoreTickish -> Bool
forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains CoreTickish
t) OrdList CoreTickish
ticks
                        then OrdList CoreTickish
ticks else OrdList CoreTickish
ticks OrdList CoreTickish -> CoreTickish -> OrdList CoreTickish
forall a. OrdList a -> a -> OrdList a
`snocOL` CoreTickish
t)
        go (OrdList FloatingBind
flt_binds, OrdList CoreTickish
ticks) f :: FloatingBind
f@UnsafeEqualityCase{}
          -- unsafe equality case will be erased; don't wrap anything!
          = (OrdList FloatingBind
flt_binds OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
f, OrdList CoreTickish
ticks)
        go (OrdList FloatingBind
flt_binds, OrdList CoreTickish
ticks) f :: FloatingBind
f@Float{}
          = (OrdList FloatingBind
flt_binds OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` (CoreTickish -> FloatingBind -> FloatingBind)
-> FloatingBind -> OrdList CoreTickish -> FloatingBind
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL CoreTickish -> FloatingBind -> FloatingBind
wrap FloatingBind
f OrdList CoreTickish
ticks, OrdList CoreTickish
ticks)

        wrap :: CoreTickish -> FloatingBind -> FloatingBind
wrap CoreTickish
t (Float CoreBind
bind BindInfo
bound FloatInfo
info) = CoreBind -> BindInfo -> FloatInfo -> FloatingBind
Float (CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t CoreBind
bind) BindInfo
bound FloatInfo
info
        wrap CoreTickish
_ FloatingBind
f                 = String -> SDoc -> FloatingBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unexpected FloatingBind" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
f)
        wrapBind :: CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t (NonRec InVar
binder CpeRhs
rhs) = InVar -> CpeRhs -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
binder (CoreTickish -> CpeRhs -> CpeRhs
mkTick CoreTickish
t CpeRhs
rhs)
        wrapBind CoreTickish
t (Rec [(InVar, CpeRhs)]
pairs)         = [(InVar, CpeRhs)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ((CpeRhs -> CpeRhs) -> [(InVar, CpeRhs)] -> [(InVar, CpeRhs)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd (CoreTickish -> CpeRhs -> CpeRhs
mkTick CoreTickish
t) [(InVar, CpeRhs)]
pairs)

------------------------------------------------------------------------------
-- Numeric literals
-- ---------------------------------------------------------------------------

-- | Converts Bignum literals into their final CoreExpr
cpeBigNatLit
   :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
cpeBigNatLit :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
cpeBigNatLit CorePrepEnv
env Integer
i = Bool -> UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a. HasCallStack => Bool -> a -> a
assert (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0) (UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs))
-> UniqSM (Floats, CpeRhs) -> UniqSM (Floats, CpeRhs)
forall a b. (a -> b) -> a -> b
$ do
  let
    platform :: Platform
platform = CorePrepConfig -> Platform
cp_platform (CorePrepEnv -> CorePrepConfig
cpe_config CorePrepEnv
env)

    -- Per the documentation in GHC.Num.BigNat, a BigNat# is:
    --   "Represented as an array of limbs (Word#) stored in
    --   little-endian order (Word# themselves use machine order)."
    --
    --   "Invariant (canonical representation): higher Word# is non-zero."
    -- So we need to break up the integer into target-word-sized chunks,
    -- and encode each of them using the target's byte-order.
    encodeBigNat
      :: forall a. Num a => FixedPrim a -> BS.ByteString
    encodeBigNat :: forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim a
encodeWord
      = LazyByteString -> ByteString
BS.toStrict (Builder -> LazyByteString
BB.toLazyByteString (FixedPrim a
-> (Integer -> Maybe (a, Integer)) -> Integer -> Builder
forall b a. FixedPrim b -> (a -> Maybe (b, a)) -> a -> Builder
primUnfoldrFixed FixedPrim a
encodeWord Integer -> Maybe (a, Integer)
f Integer
i))
      -- (quadratic complexity due to repeated shifts... ok for now)
      where
        f :: Integer -> Maybe (a, Integer)
f Integer
0 = Maybe (a, Integer)
forall a. Maybe a
Nothing
        f Integer
x = let low :: a
low  = Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
x :: a
                  high :: Integer
high = Integer
x Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
bits
              in (a, Integer) -> Maybe (a, Integer)
forall a. a -> Maybe a
Just (a
low, Integer
high)
        bits :: Int
bits = Platform -> Int
platformWordSizeInBits Platform
platform

    words :: BS.ByteString
    words :: ByteString
words = case (Platform -> PlatformWordSize
platformWordSize Platform
platform, Platform -> ByteOrder
platformByteOrder Platform
platform) of
      (PlatformWordSize
PW4, ByteOrder
LittleEndian) -> FixedPrim Word32 -> ByteString
forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim Word32
word32LE
      (PlatformWordSize
PW4, ByteOrder
BigEndian   ) -> FixedPrim Word32 -> ByteString
forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim Word32
word32BE
      (PlatformWordSize
PW8, ByteOrder
LittleEndian) -> FixedPrim Word64 -> ByteString
forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim Word64
word64LE
      (PlatformWordSize
PW8, ByteOrder
BigEndian   ) -> FixedPrim Word64 -> ByteString
forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim Word64
word64BE

  -- Ideally we would just generate a ByteArray# literal here:
  --   pure (emptyFloats, Lit (LitByteArray words))
  -- But sadly we don't have those yet, even in Core. (See also #17747.)
  -- So instead we generate:
  --   * An `Addr#` literal that contains the contents of the
  --      `ByteArray#` we want to create.  This gets its own float.
  --   * A call to `newByteArray#` with the appropriate size
  --   * A call to `copyAddrToByteArray#` to initialize the `ByteArray#`
  --   * A call to `unsafeFreezeByteArray#` to make the types match
  litAddrId <- FastString -> Type -> Type -> UniqSM InVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m InVar
mkSysLocalM (String -> FastString
fsLit String
"bigNatGuts") Type
ManyTy Type
addrPrimTy
  -- returned from newByteArray#:
  deadNewByteArrayTupleId
    <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $
         mkTupleTy Unboxed [ realWorldStatePrimTy
                           , realWorldMutableByteArrayPrimTy
                           ]
  stateTokenFromNewByteArrayId
    <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
  mutableByteArrayId
    <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy
  -- returned from copyAddrToByteArray#:
  stateTokenFromCopyId
    <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
  -- returned from unsafeFreezeByteArray#:
  deadFreezeTupleId
    <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $
         mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy]
  stateTokenFromFreezeId
    <- (`setIdOccInfo` IAmDead) <$>
         mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
  byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy

  let
    litAddrRhs = Literal -> Expr b
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
words)
      -- not "mkLitString"; that does UTF-8 encoding, which we don't want here
    litAddrFloat = CorePrepEnv -> Bool -> InVar -> CpeRhs -> FloatingBind
mkNonRecFloat CorePrepEnv
env Bool
True InVar
litAddrId CpeRhs
forall {b}. Expr b
litAddrRhs

    contentsLength = Platform -> Integer -> CpeRhs
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
words))

    newByteArrayCall =
      InVar -> CpeRhs
forall b. InVar -> Expr b
Var (PrimOp -> InVar
primOpId PrimOp
NewByteArrayOp_Char)
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CpeRhs
forall b. Type -> Expr b
Type Type
realWorldTy
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` CpeRhs
contentsLength
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
realWorldPrimId

    copyContentsCall =
      InVar -> CpeRhs
forall b. InVar -> Expr b
Var (PrimOp -> InVar
primOpId PrimOp
CopyAddrToByteArrayOp)
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CpeRhs
forall b. Type -> Expr b
Type Type
realWorldTy
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
litAddrId
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
mutableByteArrayId
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` Platform -> Integer -> CpeRhs
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
0
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` CpeRhs
contentsLength
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
stateTokenFromNewByteArrayId

    unsafeFreezeCall =
      InVar -> CpeRhs
forall b. InVar -> Expr b
Var (PrimOp -> InVar
primOpId PrimOp
UnsafeFreezeByteArrayOp)
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CpeRhs
forall b. Type -> Expr b
Type Type
realWorldTy
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
mutableByteArrayId
        CpeRhs -> CpeRhs -> CpeRhs
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
stateTokenFromCopyId

    unboxed2tuple_altcon :: AltCon
    unboxed2tuple_altcon = DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
2)

    finalRhs =
      CpeRhs -> InVar -> Type -> [Alt InVar] -> CpeRhs
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeRhs
newByteArrayCall InVar
deadNewByteArrayTupleId Type
byteArrayPrimTy
        [ AltCon -> [InVar] -> CpeRhs -> Alt InVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
unboxed2tuple_altcon
              [InVar
stateTokenFromNewByteArrayId, InVar
mutableByteArrayId]
              CpeRhs
copyContentsCase
        ]

    copyContentsCase =
      CpeRhs -> InVar -> Type -> [Alt InVar] -> CpeRhs
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeRhs
copyContentsCall InVar
stateTokenFromCopyId Type
byteArrayPrimTy
        [ AltCon -> [InVar] -> CpeRhs -> Alt InVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CpeRhs
unsafeFreezeCase
        ]

    unsafeFreezeCase =
      CpeRhs -> InVar -> Type -> [Alt InVar] -> CpeRhs
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeRhs
unsafeFreezeCall InVar
deadFreezeTupleId Type
byteArrayPrimTy
        [ AltCon -> [InVar] -> CpeRhs -> Alt InVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
unboxed2tuple_altcon
              [InVar
stateTokenFromFreezeId, InVar
byteArrayId]
              (InVar -> CpeRhs
forall b. InVar -> Expr b
Var InVar
byteArrayId)
        ]

  pure (emptyFloats `snocFloat` litAddrFloat, finalRhs)