{-# LANGUAGE BangPatterns #-}

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

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


Core pass to saturate constructors and PrimOps
-}

module GHC.CoreToStg.Prep
   ( corePrepPgm
   , corePrepExpr
   , mkConvertNumLiteral
   )
where

import GHC.Prelude

import GHC.Platform

import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Ppr

import GHC.Tc.Utils.Env
import GHC.Unit

import GHC.Builtin.Names
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )

import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.FVs
import GHC.Core.Opt.Monad ( CoreToDo(..) )
import GHC.Core.Lint    ( endPassIO )
import GHC.Core
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.Core.TyCo.Rep( UnivCoProvenance(..) )

import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.FastString
import GHC.Data.Pair

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

import GHC.Types.Demand
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
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.TyThing
import GHC.Types.Unique.Supply

import Data.List        ( unfoldr )
import Data.Functor.Identity
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.  [Not any more; nuked Jun 2002] Do the seq/par munging.

6.  Clone all local Ids.
    This means that all such Ids are unique, rather than the
    weaker guarantee of no clashes which the simplifier provides.
    And that is what the code generator needs.

    We don't clone TyVars or CoVars. The code gen doesn't need that,
    and doing so would be tiresome because then we'd need
    to substitute in types and coercions.

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.  Replace (lazy e) by e.  See Note [lazyId magic] in GHC.Types.Id.Make
    Also replace (noinline e) by e.

10. Convert bignum literals into their core representation.

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

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

13. Eliminate case clutter in favour of unsafe coercions.
    See Note [Unsafe coercions]

14. Eliminate some magic Ids, specifically
     runRW# (\s. e)  ==>  e[readWorldId/s]
             lazy e  ==>  e
         noinline 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 [Unsafe coercions]
~~~~~~~~~~~~~~~~~~~~~~~
CorePrep does these two transformations:

1. Convert empty case to cast with an unsafe coercion
          (case e of {}) ===>  e |> unsafe-co
   See Note [Empty case alternatives] in GHC.Core: if the case
   alternatives are empty, the scrutinee must diverge or raise an
   exception, so we can just dive into it.

   Of course, if the scrutinee *does* return, we may get a seg-fault.
   A belt-and-braces approach would be to persist empty-alternative
   cases to code generator, and put a return point anyway that calls a
   runtime system error function.

   Notice that eliminating empty case can lead to an ill-kinded coercion
       case error @Int "foo" of {}  :: Int#
       ===> error @Int "foo" |> unsafe-co
       where unsafe-co :: Int ~ Int#
   But that's fine because the expression diverges anyway. And it's
   no different to what happened before.

2. Eliminate unsafeEqualityProof in favour of an unsafe coercion
           case unsafeEqualityProof of UnsafeRefl g -> e
           ===>  e[unsafe-co/g]
   See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce

   Note that this requires us to substitute 'unsafe-co' for 'g', and
   that is the main (current) reason for cpe_tyco_env in CorePrepEnv.
   Tiresome, but not difficult.

These transformations get rid of "case clutter", leaving only casts.
We are doing no further significant tranformations, so the reasons
for the case forms have disappeared. And it is extremely helpful for
the ANF-ery, CoreToStg, and backends, if trivial expressions really do
look trivial. #19700 was an example.

In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)),
The boolean 'b' says whether the unsafe coercion is supposed to be
kind-homogeneous (yes for (2), no for (1).  This information is used
/only/ by Lint.

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

    Trivial expressions
       arg ::= lit |  var
              | arg ty  |  /\a. arg
              | truv co  |  /\c. arg  |  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.
-}

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

corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
            -> IO CoreProgram
corePrepPgm :: HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm HscEnv
hsc_env 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
text String
"CorePrep"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
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
    UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
    CorePrepEnv
initialCorePrepEnv <- HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env

    let
        implicit_binds :: CoreProgram
implicit_binds = DynFlags -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers DynFlags
dflags 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 :: CoreProgram
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
                      Floats
floats1 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
binds
                      Floats
floats2 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
implicit_binds
                      CoreProgram -> UniqSM CoreProgram
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> CoreProgram
deFloatTop (Floats
floats1 Floats -> Floats -> Floats
`appendFloats` Floats
floats2))

    HscEnv
-> PrintUnqualified
-> CoreToDo
-> CoreProgram
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
alwaysQualify CoreToDo
CorePrep CoreProgram
binds_out []
    CoreProgram -> IO CoreProgram
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_out
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env

corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr :: HscEnv -> CpeApp -> IO CpeApp
corePrepExpr HscEnv
hsc_env CpeApp
expr = do
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    Logger -> SDoc -> (CpeApp -> ()) -> IO CpeApp -> IO CpeApp
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
text String
"CorePrep [expr]") (\CpeApp
e -> CpeApp
e CpeApp -> () -> ()
forall a b. a -> b -> b
`seq` ()) (IO CpeApp -> IO CpeApp) -> IO CpeApp -> IO CpeApp
forall a b. (a -> b) -> a -> b
$ do
      UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
      CorePrepEnv
initialCorePrepEnv <- HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env
      let new_expr :: CpeApp
new_expr = UniqSupply -> UniqSM CpeApp -> CpeApp
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
initialCorePrepEnv CpeApp
expr)
      Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_prep String
"CorePrep" DumpFormat
FormatCore (CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
new_expr)
      CpeApp -> IO CpeApp
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CpeApp
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 (CorePrepEnv
env', Floats
floats, Maybe CoreBind
maybe_new_bind)
                                 <- TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
TopLevel CorePrepEnv
env CoreBind
bind
                               Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Maybe CoreBind -> Bool
forall a. Maybe a -> Bool
isNothing Maybe CoreBind
maybe_new_bind)
                                 -- Only join points get returned this way by
                                 -- cpeBind, and no join point may float to top
                               Floats
floatss <- CorePrepEnv -> CoreProgram -> UniqSM Floats
go CorePrepEnv
env' CoreProgram
binds
                               Floats -> UniqSM Floats
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats Floats -> Floats -> Floats
`appendFloats` Floats
floatss)

mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
-- See Note [Data constructor workers]
-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy
mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers DynFlags
dflags ModLocation
mod_loc [TyCon]
data_tycons
  = [ Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Name -> CpeApp -> CpeApp
tick_it (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con) (Id -> CpeApp
forall b. Id -> Expr b
Var Id
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 :: Id
id = DataCon -> Id
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 -> CpeApp -> CpeApp
tick_it Name
name
     | Bool -> Bool
not (DynFlags -> Bool
needSourceNotes DynFlags
dflags)           = CpeApp -> CpeApp
forall a. a -> a
id
     | RealSrcSpan RealSrcSpan
span Maybe BufSpan
_ <- Name -> SrcSpan
nameSrcSpan Name
name = RealSrcSpan -> CpeApp -> CpeApp
tick RealSrcSpan
span
     | Just String
file <- ModLocation -> Maybe String
ml_hs_file ModLocation
mod_loc       = RealSrcSpan -> CpeApp -> CpeApp
tick (String -> RealSrcSpan
span1 String
file)
     | Bool
otherwise                             = RealSrcSpan -> CpeApp -> CpeApp
tick (String -> RealSrcSpan
span1 String
"???")
     where tick :: RealSrcSpan -> CpeApp -> CpeApp
tick RealSrcSpan
span  = CoreTickish -> CpeApp -> CpeApp
forall b. CoreTickish -> Expr b -> Expr b
Tick (RealSrcSpan -> String -> CoreTickish
forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
span (String -> CoreTickish) -> String -> CoreTickish
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (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 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 Id
bndr CpeApp
rhs)
  | Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)
  = do { (CorePrepEnv
env1, Id
bndr1) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
       ; let dmd :: Demand
dmd         = Id -> Demand
idDemandInfo Id
bndr
             is_unlifted :: Bool
is_unlifted = (() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
bndr)
       ; (Floats
floats, CpeApp
rhs1) <- TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CpeApp
-> UniqSM (Floats, CpeApp)
cpePair TopLevelFlag
top_lvl RecFlag
NonRecursive
                                   Demand
dmd Bool
is_unlifted
                                   CorePrepEnv
env Id
bndr1 CpeApp
rhs
       -- See Note [Inlining in CorePrep]
       ; let triv_rhs :: Bool
triv_rhs = CpeApp -> Bool
exprIsTrivial CpeApp
rhs1
             env2 :: CorePrepEnv
env2    | Bool
triv_rhs  = CorePrepEnv -> Id -> CpeApp -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
env1 Id
bndr CpeApp
rhs1
                     | Bool
otherwise = CorePrepEnv
env1
             floats1 :: Floats
floats1 | Bool
triv_rhs, Name -> Bool
isInternalName (Id -> Name
idName Id
bndr)
                     = Floats
floats
                     | Bool
otherwise
                     = Floats -> FloatingBind -> Floats
addFloat Floats
floats FloatingBind
new_float

             new_float :: FloatingBind
new_float = Demand -> Bool -> Id -> CpeApp -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
bndr1 CpeApp
rhs1

       ; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv
env2, Floats
floats1, Maybe CoreBind
forall a. Maybe a
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 { (CorePrepEnv
_, Id
bndr1) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
       ; (Id
bndr2, CpeApp
rhs1) <- CorePrepEnv -> Id -> CpeApp -> UniqSM (Id, CpeApp)
cpeJoinPair CorePrepEnv
env Id
bndr1 CpeApp
rhs
       ; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
bndr Id
bndr2,
                 Floats
emptyFloats,
                 CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr2 CpeApp
rhs1)) }

cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (Rec [(Id, CpeApp)]
pairs)
  | Bool -> Bool
not (Id -> Bool
isJoinId ([Id] -> Id
forall a. HasCallStack => [a] -> a
head [Id]
bndrs))
  = do { (CorePrepEnv
env', [Id]
bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
       ; [(Floats, CpeApp)]
stuff <- (Id -> CpeApp -> UniqSM (Floats, CpeApp))
-> [Id] -> [CpeApp] -> UniqSM [(Floats, CpeApp)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CpeApp
-> UniqSM (Floats, CpeApp)
cpePair TopLevelFlag
top_lvl RecFlag
Recursive Demand
topDmd Bool
False CorePrepEnv
env')
                           [Id]
bndrs1 [CpeApp]
rhss

       ; let ([Floats]
floats_s, [CpeApp]
rhss1) = [(Floats, CpeApp)] -> ([Floats], [CpeApp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Floats, CpeApp)]
stuff
             all_pairs :: [(Id, CpeApp)]
all_pairs = (FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)])
-> [(Id, CpeApp)] -> OrdList FloatingBind -> [(Id, CpeApp)]
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)]
add_float ([Id]
bndrs1 [Id] -> [CpeApp] -> [(Id, CpeApp)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CpeApp]
rhss1)
                                           ([Floats] -> OrdList FloatingBind
concatFloats [Floats]
floats_s)

       ; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
env ([Id]
bndrs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs1),
                 FloatingBind -> Floats
unitFloat (CoreBind -> FloatingBind
FloatLet ([(Id, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CpeApp)]
all_pairs)),
                 Maybe CoreBind
forall a. Maybe a
Nothing) }

  | Bool
otherwise -- See Note [Join points and floating]
  = do { (CorePrepEnv
env', [Id]
bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
       ; [(Id, CpeApp)]
pairs1 <- (Id -> CpeApp -> UniqSM (Id, CpeApp))
-> [Id] -> [CpeApp] -> UniqSM [(Id, CpeApp)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (CorePrepEnv -> Id -> CpeApp -> UniqSM (Id, CpeApp)
cpeJoinPair CorePrepEnv
env') [Id]
bndrs1 [CpeApp]
rhss

       ; let bndrs2 :: [Id]
bndrs2 = ((Id, CpeApp) -> Id) -> [(Id, CpeApp)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CpeApp) -> Id
forall a b. (a, b) -> a
fst [(Id, CpeApp)]
pairs1
       ; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
env' ([Id]
bndrs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs2),
                 Floats
emptyFloats,
                 CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just ([(Id, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CpeApp)]
pairs1)) }
  where
    ([Id]
bndrs, [CpeApp]
rhss) = [(Id, CpeApp)] -> ([Id], [CpeApp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CpeApp)]
pairs

        -- Flatten all the floats, and the current
        -- group into a single giant Rec
    add_float :: FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)]
add_float (FloatLet (NonRec Id
b CpeApp
r)) [(Id, CpeApp)]
prs2 = (Id
b,CpeApp
r) (Id, CpeApp) -> [(Id, CpeApp)] -> [(Id, CpeApp)]
forall a. a -> [a] -> [a]
: [(Id, CpeApp)]
prs2
    add_float (FloatLet (Rec [(Id, CpeApp)]
prs1))   [(Id, CpeApp)]
prs2 = [(Id, CpeApp)]
prs1 [(Id, CpeApp)] -> [(Id, CpeApp)] -> [(Id, CpeApp)]
forall a. [a] -> [a] -> [a]
++ [(Id, CpeApp)]
prs2
    add_float FloatingBind
b                       [(Id, CpeApp)]
_    = String -> SDoc -> [(Id, CpeApp)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cpeBind" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
b)

---------------
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
-> Id
-> CpeApp
-> UniqSM (Floats, CpeApp)
cpePair TopLevelFlag
top_lvl RecFlag
is_rec Demand
dmd Bool
is_unlifted CorePrepEnv
env Id
bndr CpeApp
rhs
  = Bool -> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)) (UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp))
-> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a b. (a -> b) -> a -> b
$ -- those should use cpeJoinPair
    do { (Floats
floats1, CpeApp
rhs1) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
rhs

       -- See if we are allowed to float this stuff out of the RHS
       ; (Floats
floats2, CpeApp
rhs2) <- Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_from_rhs Floats
floats1 CpeApp
rhs1

       -- Make the arity match up
       ; (Floats
floats3, CpeApp
rhs3)
            <- if CpeApp -> Int
manifestArity CpeApp
rhs1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
arity
               then (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats2, Int -> CpeApp -> CpeApp
cpeEtaExpand Int
arity CpeApp
rhs2)
               else Bool
-> String
-> SDoc
-> UniqSM (Floats, CpeApp)
-> UniqSM (Floats, CpeApp)
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"CorePrep: silly extra arguments:" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr) (UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp))
-> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a b. (a -> b) -> a -> b
$
                               -- Note [Silly extra arguments]
                    (do { Id
v <- Type -> UniqSM Id
newVar (Id -> Type
idType Id
bndr)
                        ; let float :: FloatingBind
float = Demand -> Bool -> Id -> CpeApp -> FloatingBind
mkFloat Demand
topDmd Bool
False Id
v CpeApp
rhs2
                        ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Floats -> FloatingBind -> Floats
addFloat Floats
floats2 FloatingBind
float
                                 , Int -> CpeApp -> CpeApp
cpeEtaExpand Int
arity (Id -> CpeApp
forall b. Id -> Expr b
Var Id
v)) })

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

       ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats4, CpeApp
rhs4) }
  where
    arity :: Int
arity = Id -> Int
idArity Id
bndr        -- We must match this arity

    ---------------------
    float_from_rhs :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_from_rhs Floats
floats CpeApp
rhs
      | Floats -> Bool
isEmptyFloats Floats
floats = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
rhs)
      | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl   = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_top    Floats
floats CpeApp
rhs
      | Bool
otherwise            = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_nested Floats
floats CpeApp
rhs

    ---------------------
    float_nested :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_nested Floats
floats CpeApp
rhs
      | RecFlag -> Demand -> Bool -> Floats -> CpeApp -> Bool
wantFloatNested RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CpeApp
rhs
                  = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp
rhs)
      | Bool
otherwise = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
dontFloat Floats
floats CpeApp
rhs

    ---------------------
    float_top :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_top Floats
floats CpeApp
rhs
      | Floats -> Bool
allLazyTop Floats
floats
      = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp
rhs)

      | Just (Floats, CpeApp)
floats <- Floats -> CpeApp -> Maybe (Floats, CpeApp)
canFloat Floats
floats CpeApp
rhs
      = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats, CpeApp)
floats

      | Bool
otherwise
      = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
dontFloat Floats
floats CpeApp
rhs

dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
-- Non-empty floats, but do not want to float from rhs
-- So wrap the rhs in the floats
-- But: rhs1 might have lambdas, and we can't
--      put them inside a wrapBinds
dontFloat :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
dontFloat Floats
floats1 CpeApp
rhs
  = do { (Floats
floats2, CpeApp
body) <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
rhs
        ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Floats -> CpeApp -> CpeApp
wrapBinds Floats
floats1 (CpeApp -> CpeApp) -> CpeApp -> CpeApp
forall a b. (a -> b) -> a -> b
$
                               Floats -> CpeApp -> CpeApp
wrapBinds Floats
floats2 CpeApp
body) }

{- 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 -> Id -> CpeApp -> UniqSM (Id, CpeApp)
cpeJoinPair CorePrepEnv
env Id
bndr CpeApp
rhs
  = Bool -> UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp)
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isJoinId Id
bndr) (UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp))
-> UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp)
forall a b. (a -> b) -> a -> b
$
    do { let Just Int
join_arity = Id -> Maybe Int
isJoinId_maybe Id
bndr
             ([Id]
bndrs, CpeApp
body)   = Int -> CpeApp -> ([Id], CpeApp)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity CpeApp
rhs

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

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

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

       ; (Id, CpeApp) -> UniqSM (Id, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bndr', CpeApp
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 -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env (Type Type
ty)
  = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Type -> CpeApp
forall b. Type -> Expr b
Type (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty))
cpeRhsE CorePrepEnv
env (Coercion Coercion
co)
  = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Coercion -> CpeApp
forall b. Coercion -> Expr b
Coercion (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co))
cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(Lit (LitNumber LitNumType
nt Integer
i))
   = case CorePrepEnv -> LitNumType -> Integer -> Maybe CpeApp
cpe_convertNumLit CorePrepEnv
env LitNumType
nt Integer
i of
      Maybe CpeApp
Nothing -> (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
expr)
      Just CpeApp
e  -> CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
e
cpeRhsE CorePrepEnv
_env expr :: CpeApp
expr@(Lit {}) = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
expr)
cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(Var {})  = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeApp CorePrepEnv
env CpeApp
expr
cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(App {}) = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeApp CorePrepEnv
env CpeApp
expr

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

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

cpeRhsE CorePrepEnv
env (Cast CpeApp
expr Coercion
co)
   = do { (Floats
floats, CpeApp
expr') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
expr
        ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> Coercion -> CpeApp
forall b. Expr b -> Coercion -> Expr b
Cast CpeApp
expr' (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co)) }

cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(Lam {})
   = do { let ([Id]
bndrs,CpeApp
body) = CpeApp -> ([Id], CpeApp)
forall b. Expr b -> ([b], Expr b)
collectBinders CpeApp
expr
        ; (CorePrepEnv
env', [Id]
bndrs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
        ; CpeApp
body' <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env' CpeApp
body
        ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, [Id] -> CpeApp -> CpeApp
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs' CpeApp
body') }

-- Eliminate empty case
-- See Note [Unsafe coercions]
cpeRhsE CorePrepEnv
env (Case CpeApp
scrut Id
_ Type
ty [])
  = do { (Floats
floats, CpeApp
scrut') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
scrut
       ; let ty' :: Type
ty'       = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty
             scrut_ty' :: Type
scrut_ty' = (() :: Constraint) => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
scrut'
             co' :: Coercion
co'       = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo UnivCoProvenance
prov Role
Representational Type
scrut_ty' Type
ty'
             prov :: UnivCoProvenance
prov      = Bool -> UnivCoProvenance
CorePrepProv Bool
False
               -- False says that the kinds of two types may differ
               -- E.g. we might cast Int to Int#.  This is fine
               -- because the scrutinee is guaranteed to diverge

       ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> Coercion -> CpeApp
forall b. Expr b -> Coercion -> Expr b
Cast CpeApp
scrut' Coercion
co') }
   -- This can give rise to
   --   Warning: Unsafe coercion: between unboxed and boxed value
   -- but it's fine because 'scrut' diverges

-- Eliminate unsafeEqualityProof
-- See Note [Unsafe coercions]
cpeRhsE CorePrepEnv
env (Case CpeApp
scrut Id
bndr Type
_ [Alt Id]
alts)
  | CpeApp -> Bool
isUnsafeEqualityProof CpeApp
scrut
  , Id -> Bool
isDeadBinder Id
bndr -- We can only discard the case if the case-binder
                      -- is dead.  It usually is, but see #18227
  , [Alt AltCon
_ [Id
co_var] CpeApp
rhs] <- [Alt Id]
alts
  , let Pair Type
ty1 Type
ty2 = (() :: Constraint) => Id -> Pair Type
Id -> Pair Type
coVarTypes Id
co_var
        the_co :: Coercion
the_co = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo UnivCoProvenance
prov Role
Nominal (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty1) (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty2)
        prov :: UnivCoProvenance
prov   = Bool -> UnivCoProvenance
CorePrepProv Bool
True  -- True <=> kind homogeneous
        env' :: CorePrepEnv
env'   = CorePrepEnv -> Id -> Coercion -> CorePrepEnv
extendCoVarEnv CorePrepEnv
env Id
co_var Coercion
the_co
  = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env' CpeApp
rhs

cpeRhsE CorePrepEnv
env (Case CpeApp
scrut Id
bndr Type
ty [Alt Id]
alts)
  = do { (Floats
floats, CpeApp
scrut') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
scrut
       ; (CorePrepEnv
env', Id
bndr2) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
       ; let alts' :: [Alt Id]
alts'
                 -- 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.
               | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CatchNonexhaustiveCases (CorePrepEnv -> DynFlags
cpe_dynFlags CorePrepEnv
env)
               , Bool -> Bool
not ([Alt Id] -> Bool
forall b. [Alt b] -> Bool
altsAreExhaustive [Alt Id]
alts)
               = [Alt Id] -> Maybe CpeApp -> [Alt Id]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault [Alt Id]
alts (CpeApp -> Maybe CpeApp
forall a. a -> Maybe a
Just CpeApp
err)
               | Bool
otherwise = [Alt Id]
alts
               where err :: CpeApp
err = Id -> Type -> String -> CpeApp
mkRuntimeErrorApp Id
rUNTIME_ERROR_ID Type
ty
                                             String
"Bottoming expression returned"
       ; [Alt Id]
alts'' <- (Alt Id -> UniqSM (Alt Id)) -> [Alt Id] -> UniqSM [Alt Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CorePrepEnv -> Alt Id -> UniqSM (Alt Id)
sat_alt CorePrepEnv
env') [Alt Id]
alts'

       ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> Id -> Type -> [Alt Id] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
scrut' Id
bndr2 Type
ty [Alt Id]
alts'') }
  where
    sat_alt :: CorePrepEnv -> Alt Id -> UniqSM (Alt Id)
sat_alt CorePrepEnv
env (Alt AltCon
con [Id]
bs CpeApp
rhs)
       = do { (CorePrepEnv
env2, [Id]
bs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bs
            ; CpeApp
rhs' <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env2 CpeApp
rhs
            ; Alt Id -> UniqSM (Alt Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [Id] -> CpeApp -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs' CpeApp
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 -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env CpeApp
expr
  = do { (Floats
floats, CpeApp
body) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
expr
       ; CpeApp -> UniqSM CpeApp
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> CpeApp -> CpeApp
wrapBinds Floats
floats CpeApp
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 -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
expr
  = do { (Floats
floats1, CpeApp
rhs) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
expr
       ; (Floats
floats2, CpeApp
body) <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
rhs
       ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats1 Floats -> Floats -> Floats
`appendFloats` Floats
floats2, CpeApp
body) }

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

rhsToBody :: CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody (Tick CoreTickish
t CpeApp
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
floats, CpeApp
expr') <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
expr
       ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t CpeApp
expr') }

rhsToBody (Cast CpeApp
e Coercion
co)
        -- You can get things like
        --      case e of { p -> coerce t (\s -> ...) }
  = do { (Floats
floats, CpeApp
e') <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
e
       ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> Coercion -> CpeApp
forall b. Expr b -> Coercion -> Expr b
Cast CpeApp
e' Coercion
co) }

rhsToBody expr :: CpeApp
expr@(Lam {})
  | Just CpeApp
no_lam_result <- [Id] -> CpeApp -> Maybe CpeApp
tryEtaReducePrep [Id]
bndrs CpeApp
body
  = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
no_lam_result)
  | (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isTyVar [Id]
bndrs           -- Type lambdas are ok
  = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
expr)
  | Bool
otherwise                   -- Some value lambdas
  = do { let rhs :: CpeApp
rhs = Int -> CpeApp -> CpeApp
cpeEtaExpand (CpeApp -> Int
exprArity CpeApp
expr) CpeApp
expr
       ; Id
fn <- Type -> UniqSM Id
newVar ((() :: Constraint) => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
rhs)
       ; let float :: FloatingBind
float = CoreBind -> FloatingBind
FloatLet (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
fn CpeApp
rhs)
       ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FloatingBind -> Floats
unitFloat FloatingBind
float, Id -> CpeApp
forall b. Id -> Expr b
Var Id
fn) }
  where
    ([Id]
bndrs,CpeApp
body) = CpeApp -> ([Id], CpeApp)
forall b. Expr b -> ([b], Expr b)
collectBinders CpeApp
expr

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



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

data ArgInfo = CpeApp  CoreArg
             | CpeCast Coercion
             | CpeTick CoreTickish

instance Outputable ArgInfo where
  ppr :: ArgInfo -> SDoc
ppr (CpeApp CpeApp
arg) = String -> SDoc
text String
"app" SDoc -> SDoc -> SDoc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
arg
  ppr (CpeCast Coercion
co) = String -> SDoc
text String
"cast" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
  ppr (CpeTick CoreTickish
tick) = String -> SDoc
text String
"tick" SDoc -> SDoc -> SDoc
<+> 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 because of saturating primops
cpeApp :: CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeApp CorePrepEnv
top_env CpeApp
expr
  = do { let (CpeApp
terminal, [ArgInfo]
args) = CpeApp -> (CpeApp, [ArgInfo])
collect_args CpeApp
expr
       ; CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
top_env CpeApp
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 :: CpeApp -> (CpeApp, [ArgInfo])
collect_args CpeApp
e = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
e []
      where
        go :: CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go (App CpeApp
fun CpeApp
arg)      [ArgInfo]
as
            = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
fun (CpeApp -> ArgInfo
CpeApp CpeApp
arg ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
        go (Cast CpeApp
fun Coercion
co)      [ArgInfo]
as
            = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
fun (Coercion -> ArgInfo
CpeCast Coercion
co ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
        go (Tick CoreTickish
tickish CpeApp
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]
            | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
floatableTick CoreTickish
tickish Bool -> Bool -> Bool
|| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
isProfTick CoreTickish
tickish
            , Var Id
vh <- CpeApp
head
            , Var Id
head' <- CorePrepEnv -> Id -> CpeApp
lookupCorePrepEnv CorePrepEnv
top_env Id
vh
            , Id -> Bool
hasNoBinding Id
head'
            = (CpeApp
head,[ArgInfo]
as')
            where
              (CpeApp
head,[ArgInfo]
as') = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
fun (CoreTickish -> ArgInfo
CpeTick 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 CpeApp
terminal [ArgInfo]
as = (CpeApp
terminal, [ArgInfo]
as)

    cpe_app :: CorePrepEnv
            -> CoreExpr -- The thing we are calling
            -> [ArgInfo]
            -> UniqSM (Floats, CpeRhs)
    cpe_app :: CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
env (Var Id
f) (CpeApp Type{} : CpeApp CpeApp
arg : [ArgInfo]
args)
        | Id
f Id -> 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
|| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineIdKey      -- Replace (noinline a) with a
            -- See Note [noinlineId 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 (CpeApp
terminal, [ArgInfo]
args') = CpeApp -> (CpeApp, [ArgInfo])
collect_args CpeApp
arg
          in CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
env CpeApp
terminal ([ArgInfo]
args' [ArgInfo] -> [ArgInfo] -> [ArgInfo]
forall a. [a] -> [a] -> [a]
++ [ArgInfo]
args)

    -- See Note [keepAlive# magic].
    cpe_app CorePrepEnv
env
            (Var Id
f)
            [ArgInfo]
args
        | Just PrimOp
KeepAliveOp <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
        , CpeApp (Type Type
arg_lev)
          : CpeApp (Type Type
_result_rep)
          : CpeApp (Type Type
arg_ty)
          : CpeApp (Type Type
result_ty)
          : CpeApp CpeApp
arg
          : CpeApp CpeApp
s0
          : CpeApp CpeApp
k
          : [ArgInfo]
rest <- [ArgInfo]
args
        = do { Id
y  <- Type -> UniqSM Id
newVar (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
result_ty)
             ; Id
s2 <- Type -> UniqSM Id
newVar Type
realWorldStatePrimTy
             ; -- beta reduce if possible
             ; (Floats
floats, CpeApp
k') <- case CpeApp
k of
                  Lam Id
s CpeApp
body -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app (CorePrepEnv -> Id -> CpeApp -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
env Id
s CpeApp
s0) CpeApp
body [ArgInfo]
rest
                  CpeApp
_          -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
env CpeApp
k (CpeApp -> ArgInfo
CpeApp CpeApp
s0 ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
rest)
             ; let touchId :: Id
touchId = PrimOp -> Id
primOpId PrimOp
TouchOp
                   expr :: CpeApp
expr = CpeApp -> Id -> Type -> [Alt Id] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
k' Id
y Type
result_ty [AltCon -> [Id] -> CpeApp -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CpeApp
rhs]
                   rhs :: CpeApp
rhs = let scrut :: CpeApp
scrut = CpeApp -> [CpeApp] -> CpeApp
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CpeApp
forall b. Id -> Expr b
Var Id
touchId) [Type -> CpeApp
forall b. Type -> Expr b
Type Type
arg_lev, Type -> CpeApp
forall b. Type -> Expr b
Type Type
arg_ty, CpeApp
arg, Id -> CpeApp
forall b. Id -> Expr b
Var Id
realWorldPrimId]
                         in CpeApp -> Id -> Type -> [Alt Id] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
scrut Id
s2 Type
result_ty [AltCon -> [Id] -> CpeApp -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (Id -> CpeApp
forall b. Id -> Expr b
Var Id
y)]
             ; (Floats
floats', CpeApp
expr') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
expr
             ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats Floats -> Floats -> Floats
`appendFloats` Floats
floats', CpeApp
expr')
             }
        | Just PrimOp
KeepAliveOp <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
        = String -> SDoc -> UniqSM (Floats, CpeApp)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"invalid keepAlive# application" (SDoc -> UniqSM (Floats, CpeApp))
-> SDoc -> UniqSM (Floats, CpeApp)
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"args:" SDoc -> SDoc -> SDoc
<+> [ArgInfo] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ArgInfo]
args ]

    -- runRW# magic
    cpe_app CorePrepEnv
env (Var Id
f) (CpeApp _runtimeRep :: CpeApp
_runtimeRep@Type{} : CpeApp _type :: CpeApp
_type@Type{} : CpeApp CpeApp
arg : [ArgInfo]
rest)
        | Id
f Id -> 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 (CpeApp -> ArgInfo
CpeApp CpeApp
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 CpeApp
arg of
            Lam Id
s CpeApp
body -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
s Id
realWorldPrimId) CpeApp
body [ArgInfo]
rest
            CpeApp
_          -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
env CpeApp
arg (CpeApp -> ArgInfo
CpeApp (Id -> CpeApp
forall b. Id -> Expr b
Var Id
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 (CpeApp CpeApp
arg:[ArgInfo]
_rest)
            | Bool -> Bool
not (CpeApp -> Bool
forall b. Expr b -> Bool
isTyCoArg CpeApp
arg) = Bool
True
          has_value_arg (ArgInfo
_:[ArgInfo]
rest) = [ArgInfo] -> Bool
has_value_arg [ArgInfo]
rest

    cpe_app CorePrepEnv
env (Var Id
v) [ArgInfo]
args
      = do { Id
v1 <- Id -> UniqSM Id
fiddleCCall Id
v
           ; let e2 :: CpeApp
e2 = CorePrepEnv -> Id -> CpeApp
lookupCorePrepEnv CorePrepEnv
env Id
v1
                 hd :: Maybe Id
hd = CpeApp -> Maybe Id
getIdFromTrivialExpr_maybe CpeApp
e2
                 -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
                 min_arity :: Maybe Int
min_arity = case Maybe Id
hd of
                   Just Id
v_hd -> if Id -> Bool
hasNoBinding Id
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
$! (Id -> Int
idArity Id
v_hd) else Maybe Int
forall a. Maybe a
Nothing
                   Maybe Id
Nothing -> Maybe Int
forall a. Maybe a
Nothing
           ; (CpeApp
app, Floats
floats, [CoreTickish]
unsat_ticks) <- CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> Maybe Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeApp
e2 Floats
emptyFloats [Demand]
stricts Maybe Int
min_arity
           ; Maybe Id
-> CpeApp
-> Floats
-> [CoreTickish]
-> Int
-> UniqSM (Floats, CpeApp)
forall {a}.
Maybe Id
-> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
mb_saturate Maybe Id
hd CpeApp
app Floats
floats [CoreTickish]
unsat_ticks Int
depth }
        where
          depth :: Int
depth = [ArgInfo] -> Int
val_args [ArgInfo]
args
          stricts :: [Demand]
stricts = case Id -> DmdSig
idDmdSig Id
v of
                            DmdSig (DmdType DmdEnv
_ [Demand]
demands Divergence
_)
                              | [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 CpeApp
fun [] = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
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 CpeApp
fun [ArgInfo]
args
      = do { (Floats
fun_floats, CpeApp
fun') <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
env Demand
evalDmd CpeApp
fun
                          -- If evalDmd says that it's sure to be evaluated,
                          -- we'll end up case-binding it
           ; (CpeApp
app, Floats
floats,[CoreTickish]
unsat_ticks) <- CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> Maybe Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeApp
fun' Floats
fun_floats [] Maybe Int
forall a. Maybe a
Nothing
           ; Maybe Id
-> CpeApp
-> Floats
-> [CoreTickish]
-> Int
-> UniqSM (Floats, CpeApp)
forall {a}.
Maybe Id
-> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
mb_saturate Maybe Id
forall a. Maybe a
Nothing CpeApp
app Floats
floats [CoreTickish]
unsat_ticks ([ArgInfo] -> Int
val_args [ArgInfo]
args) }

    -- Count the number of value arguments.
    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
            CpeCast {} -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n
            CpeTick CoreTickish
tickish
              | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
floatableTick 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
            CpeApp CpeApp
e                                  -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n'
              where
                !n' :: t
n'
                  | CpeApp -> Bool
forall b. Expr b -> Bool
isTyCoArg CpeApp
e = t
n
                  | Bool
otherwise   = t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1

    -- Saturate if necessary
    mb_saturate :: Maybe Id
-> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
mb_saturate Maybe Id
head CpeApp
app a
floats [CoreTickish]
unsat_ticks Int
depth =
       case Maybe Id
head of
         Just Id
fn_id -> do { CpeApp
sat_app <- Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeApp
maybeSaturate Id
fn_id CpeApp
app Int
depth [CoreTickish]
unsat_ticks
                          ; (a, CpeApp) -> UniqSM (a, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CpeApp
sat_app) }
         Maybe Id
_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, CpeApp) -> UniqSM (a, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CpeApp
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
        -> [Demand]
        -> Maybe Arity
        -> UniqSM (CpeApp
                  ,Floats
                  ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]
                  )
    rebuild_app :: CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> Maybe Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeApp
app Floats
floats [Demand]
ss Maybe Int
req_depth =
      CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
args CpeApp
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]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
_ [] CpeApp
app Floats
floats [Demand]
ss [CoreTickish]
rt_ticks !Int
_req_depth
      = Bool
-> ((CpeApp, Floats, [CoreTickish])
    -> UniqSM (CpeApp, Floats, [CoreTickish]))
-> (CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish])
forall a. HasCallStack => Bool -> a -> a
assert ([Demand] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
ss) -- make sure we used all the strictness info
        (CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeApp
app, Floats
floats, [CoreTickish]
rt_ticks)

    rebuild_app' CorePrepEnv
env (ArgInfo
a : [ArgInfo]
as) CpeApp
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 :: CpeApp
tick_fun = (CoreTickish -> CpeApp -> CpeApp)
-> CpeApp -> [CoreTickish] -> CpeApp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CpeApp -> CpeApp
mkTick CpeApp
fun' [CoreTickish]
rt_ticks
            in CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env (ArgInfo
a ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as) CpeApp
tick_fun Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth

      CpeApp (Type Type
arg_ty)
        -> CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
App CpeApp
fun' (Type -> CpeApp
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

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

      CpeApp CpeApp
arg -> do
        let (Demand
ss1, [Demand]
ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make
               = case ([Demand]
ss, CpeApp -> Bool
isLazyExpr CpeApp
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, [])
        (Floats
fs, CpeApp
arg') <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
top_env Demand
ss1 CpeApp
arg
        CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
App CpeApp
fun' CpeApp
arg') (Floats
fs Floats -> Floats -> Floats
`appendFloats` Floats
floats) [Demand]
ss_rest [CoreTickish]
rt_ticks (Int
req_depthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

      CpeCast Coercion
co
        -> CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeApp -> Coercion -> CpeApp
forall b. Expr b -> Coercion -> Expr b
Cast CpeApp
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]
      CpeTick 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 (CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish])
forall a. HasCallStack => Bool -> a -> a
assert (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
isProfTick CoreTickish
tickish) (UniqSM (CpeApp, Floats, [CoreTickish])
 -> UniqSM (CpeApp, Floats, [CoreTickish]))
-> UniqSM (CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish])
forall a b. (a -> b) -> a -> b
$
           CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as CpeApp
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]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as CpeApp
fun' (Floats -> FloatingBind -> Floats
addFloat 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 :: CpeApp -> Bool
isLazyExpr (Cast CpeApp
e Coercion
_)              = CpeApp -> Bool
isLazyExpr CpeApp
e
isLazyExpr (Tick CoreTickish
_ CpeApp
e)              = CpeApp -> Bool
isLazyExpr CpeApp
e
isLazyExpr (Var Id
f `App` CpeApp
_ `App` CpeApp
_) = Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
isLazyExpr CpeApp
_                       = 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 program like,

    data Foo = Foo Addr#

    foo = Foo "turtle"#

When we go to ANFise this we might think that we want to float the string
literal like we do any other non-trivial argument. This would look like,

    foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }

However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)
wreaks havoc on the CAF annotations that we produce here since we the result
above is caffy since it is updateable. Ideally at some point in the future we
would like to just float the literal to the top level as suggested in #11312,

    s = "turtle"#
    foo = Foo s

However, until then we simply add a special case excluding literals from the
floating done by cpeArg.
-}

-- | Is an argument okay to CPE?
okCpeArg :: CoreExpr -> Bool
-- Don't float literals. See Note [ANF-ising literal string arguments].
okCpeArg :: CpeApp -> Bool
okCpeArg (Lit Literal
_) = Bool
False
-- Do not eta expand a trivial argument
okCpeArg CpeApp
expr    = Bool -> Bool
not (CpeApp -> Bool
exprIsTrivial CpeApp
expr)

-- This is where we arrange that a non-trivial argument is let-bound
cpeArg :: CorePrepEnv -> Demand
       -> CoreArg -> UniqSM (Floats, CpeArg)
cpeArg :: CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
env Demand
dmd CpeApp
arg
  = do { (Floats
floats1, CpeApp
arg1) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
arg     -- arg1 can be a lambda
       ; let arg_ty :: Type
arg_ty      = (() :: Constraint) => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
arg1
             is_unlifted :: Bool
is_unlifted = (() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
             want_float :: Floats -> CpeApp -> Bool
want_float  = RecFlag -> Demand -> Bool -> Floats -> CpeApp -> Bool
wantFloatNested RecFlag
NonRecursive Demand
dmd Bool
is_unlifted
       ; (Floats
floats2, CpeApp
arg2) <- if Floats -> CpeApp -> Bool
want_float Floats
floats1 CpeApp
arg1
                            then (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats1, CpeApp
arg1)
                            else Floats -> CpeApp -> UniqSM (Floats, CpeApp)
dontFloat Floats
floats1 CpeApp
arg1
                -- Else case: arg1 might have lambdas, and we can't
                --            put them inside a wrapBinds

       ; if CpeApp -> Bool
okCpeArg CpeApp
arg2
         then do { Id
v <- Type -> UniqSM Id
newVar Type
arg_ty
                 ; let arg3 :: CpeApp
arg3      = Int -> CpeApp -> CpeApp
cpeEtaExpand (CpeApp -> Int
exprArity CpeApp
arg2) CpeApp
arg2
                       arg_float :: FloatingBind
arg_float = Demand -> Bool -> Id -> CpeApp -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
v CpeApp
arg3
                 ; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> FloatingBind -> Floats
addFloat Floats
floats2 FloatingBind
arg_float, Id -> CpeApp
forall b. Id -> Expr b
varToCoreExpr Id
v) }
         else (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats2, CpeApp
arg2)
       }

{-
Note [Floating unlifted arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider    C (let v* = expensive in v)

where the "*" indicates "will be demanded".  Usually v will have been
inlined by now, but let's suppose it hasn't (see #2756).  Then we
do *not* want to get

     let v* = expensive in C v

because that has different strictness.  Hence the use of 'allLazy'.
(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)


------------------------------------------------------------------------------
-- Building the saturated syntax
-- ---------------------------------------------------------------------------

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

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

  | Int
mark_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -- A strict worker. See Note [Strict Worker Ids]
  , Bool -> Bool
not Bool
applied_marks
  = Bool -> SDoc -> UniqSM CpeApp -> UniqSM CpeApp
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr
      ( Bool -> Bool
not (Id -> Bool
isJoinId Id
fn)) -- See Note [Do not eta-expand join points]
      ( Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"expr:" SDoc -> SDoc -> SDoc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
expr SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"n_args:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_args SDoc -> SDoc -> SDoc
$$
          String -> SDoc
text String
"marks:" SDoc -> SDoc -> SDoc
<+> Maybe [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fn) SDoc -> SDoc -> SDoc
$$
          String -> SDoc
text String
"join_arity" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Int
idJoinArity Id
fn)
       ) (UniqSM CpeApp -> UniqSM CpeApp) -> UniqSM CpeApp -> UniqSM CpeApp
forall a b. (a -> b) -> a -> b
$
    CpeApp -> UniqSM CpeApp
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CpeApp
sat_expr

  | Bool
otherwise
  = Bool -> UniqSM CpeApp -> UniqSM CpeApp
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 CpeApp -> UniqSM CpeApp) -> UniqSM CpeApp -> UniqSM CpeApp
forall a b. (a -> b) -> a -> b
$
    CpeApp -> UniqSM CpeApp
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CpeApp
expr
  where
    mark_arity :: Int
mark_arity    = Id -> Int
idCbvMarkArity Id
fn
    fn_arity :: Int
fn_arity      = Id -> Int
idArity Id
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 :: CpeApp
sat_expr      = Int -> CpeApp -> CpeApp
cpeEtaExpand Int
excess_arity CpeApp
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. HasCallStack => String -> Maybe a -> a
expectJust String
"maybeSaturate" (Maybe [CbvMark] -> Int) -> Maybe [CbvMark] -> Int
forall a b. (a -> b) -> a -> b
$ (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
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..
{-
************************************************************************
*                                                                      *
                Simple GHC.Core operations
*                                                                      *
************************************************************************
-}

{-
-- -----------------------------------------------------------------------------
--      Eta reduction
-- -----------------------------------------------------------------------------

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

-}

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

{-
-- -----------------------------------------------------------------------------
--      Eta reduction
-- -----------------------------------------------------------------------------

Why try eta reduction?  Hasn't the simplifier already done eta?
But the simplifier only eta reduces if that leaves something
trivial (like f, or f Int).  But for deLam it would be enough to
get to a partial application:
        case x of { p -> \xs. map f xs }
    ==> case x of { p -> map f }
-}

-- When updating this function, make sure it lines up with
-- GHC.Core.Utils.tryEtaReduce!
tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep :: [Id] -> CpeApp -> Maybe CpeApp
tryEtaReducePrep [Id]
bndrs expr :: CpeApp
expr@(App CpeApp
_ CpeApp
_)
  | CpeApp -> Bool
ok_to_eta_reduce CpeApp
f
  , Int
n_remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
  , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Id -> CpeApp -> Bool) -> [Id] -> [CpeApp] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id -> CpeApp -> Bool
forall {b}. Id -> Expr b -> Bool
ok [Id]
bndrs [CpeApp]
last_args)
  , Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> VarSet -> Bool
`elemVarSet` VarSet
fvs_remaining) [Id]
bndrs)
  , CpeApp -> Bool
exprIsHNF CpeApp
remaining_expr   -- Don't turn value into a non-value
                               -- else the behaviour with 'seq' changes
  =
    -- pprTrace "prep-reduce" (
    --   text "reduced:" <> ppr remaining_expr $$
    --   ppr (remaining_args)
    --   ) $
    CpeApp -> Maybe CpeApp
forall a. a -> Maybe a
Just CpeApp
remaining_expr
  where
    (CpeApp
f, [CpeApp]
args) = CpeApp -> (CpeApp, [CpeApp])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CpeApp
expr
    remaining_expr :: CpeApp
remaining_expr = CpeApp -> [CpeApp] -> CpeApp
forall b. Expr b -> [Expr b] -> Expr b
mkApps CpeApp
f [CpeApp]
remaining_args
    fvs_remaining :: VarSet
fvs_remaining = CpeApp -> VarSet
exprFreeVars CpeApp
remaining_expr
    ([CpeApp]
remaining_args, [CpeApp]
last_args) = Int -> [CpeApp] -> ([CpeApp], [CpeApp])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_remaining [CpeApp]
args
    n_remaining :: Int
n_remaining = [CpeApp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CpeApp]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bndrs
    n_remaining_vals :: Int
n_remaining_vals = [CpeApp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CpeApp] -> Int) -> [CpeApp] -> Int
forall a b. (a -> b) -> a -> b
$ (CpeApp -> Bool) -> [CpeApp] -> [CpeApp]
forall a. (a -> Bool) -> [a] -> [a]
filter CpeApp -> Bool
isRuntimeArg [CpeApp]
remaining_args

    ok :: Id -> Expr b -> Bool
ok Id
bndr (Var Id
arg) = Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
arg
    ok Id
_    Expr b
_         = Bool
False

    ok_to_eta_reduce :: CpeApp -> Bool
ok_to_eta_reduce (Var Id
f) = Id -> Int -> Int -> Bool
canEtaReduceToArity Id
f Int
n_remaining Int
n_remaining_vals
    ok_to_eta_reduce CpeApp
_       = Bool
False -- Safe. ToDo: generalise


tryEtaReducePrep [Id]
bndrs (Tick CoreTickish
tickish CpeApp
e)
  | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish
  = (CpeApp -> CpeApp) -> Maybe CpeApp -> Maybe CpeApp
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
tickish) (Maybe CpeApp -> Maybe CpeApp) -> Maybe CpeApp -> Maybe CpeApp
forall a b. (a -> b) -> a -> b
$ [Id] -> CpeApp -> Maybe CpeApp
tryEtaReducePrep [Id]
bndrs CpeApp
e

tryEtaReducePrep [Id]
_ CpeApp
_ = Maybe CpeApp
forall a. Maybe a
Nothing

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

Note [Pin demand info on floats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We pin demand info on floated lets, so that we can see the one-shot thunks.

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'

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

data FloatingBind
  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss
                         -- They are always of lifted type;
                         -- unlifted ones are done with FloatCase

 | FloatCase
      CpeBody         -- Always ok-for-speculation
      Id              -- Case binder
      AltCon [Var]    -- Single alternative
      Bool            -- Ok-for-speculation; False of a strict,
                      -- but lifted binding

 -- | See Note [Floating Ticks in CorePrep]
 | FloatTick CoreTickish

data Floats = Floats OkToSpec (OrdList FloatingBind)

instance Outputable FloatingBind where
  ppr :: FloatingBind -> SDoc
ppr (FloatLet CoreBind
b) = CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b
  ppr (FloatCase CpeApp
r Id
b AltCon
k [Id]
bs Bool
ok) = String -> SDoc
text String
"case" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
ok) SDoc -> SDoc -> SDoc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
r
                                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of"SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"@"
                                SDoc -> SDoc -> SDoc
<> case [Id]
bs of
                                   [] -> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k
                                   [Id]
_  -> SDoc -> SDoc
parens (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bs)
  ppr (FloatTick CoreTickish
t) = CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
t

instance Outputable Floats where
  ppr :: Floats -> SDoc
ppr (Floats OkToSpec
flag OrdList FloatingBind
fs) = String -> SDoc
text String
"Floats" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (OkToSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr OkToSpec
flag) SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat ((FloatingBind -> SDoc) -> [FloatingBind] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OrdList FloatingBind -> [FloatingBind]
forall a. OrdList a -> [a]
fromOL OrdList FloatingBind
fs)))

instance Outputable OkToSpec where
  ppr :: OkToSpec -> SDoc
ppr OkToSpec
OkToSpec    = String -> SDoc
text String
"OkToSpec"
  ppr OkToSpec
IfUnboxedOk = String -> SDoc
text String
"IfUnboxedOk"
  ppr OkToSpec
NotOkToSpec = String -> SDoc
text String
"NotOkToSpec"

-- Can we float these binds out of the rhs of a let?  We cache this decision
-- to avoid having to recompute it in a non-linear way when there are
-- deeply nested lets.
data OkToSpec
   = OkToSpec           -- Lazy bindings of lifted type
   | IfUnboxedOk        -- A mixture of lazy lifted bindings and n
                        -- ok-to-speculate unlifted bindings
   | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings

mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
mkFloat :: Demand -> Bool -> Id -> CpeApp -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
bndr CpeApp
rhs
  | Bool
is_strict Bool -> Bool -> Bool
|| Bool
ok_for_spec -- See Note [Speculative evaluation]
  , Bool -> Bool
not Bool
is_hnf  = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CpeApp
rhs Id
bndr AltCon
DEFAULT [] Bool
ok_for_spec
    -- Don't make a case for a HNF binding, even if it's strict
    -- Otherwise we get  case (\x -> e) of ...!

  | Bool
is_unlifted = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CpeApp
rhs Id
bndr AltCon
DEFAULT [] Bool
True
      -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled
      -- because exprOkForSpeculation isn't stable under ANF-ing. See for
      -- example #19489 where the following unlifted expression:
      --
      --    GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0]
      --                    (GHC.Types.: @a_ax0 a2_agq a3_agl)
      --
      -- is ok-for-spec but is ANF-ised into:
      --
      --    let sat = GHC.Types.: @a_ax0 a2_agq a3_agl
      --    in GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0] sat
      --
      -- which isn't ok-for-spec because of the let-expression.

  | Bool
is_hnf      = CoreBind -> FloatingBind
FloatLet (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr                       CpeApp
rhs)
  | Bool
otherwise   = CoreBind -> FloatingBind
FloatLet (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> Demand -> Id
setIdDemandInfo Id
bndr Demand
dmd) CpeApp
rhs)
                   -- See Note [Pin demand info on floats]
  where
    is_hnf :: Bool
is_hnf      = CpeApp -> Bool
exprIsHNF CpeApp
rhs
    is_strict :: Bool
is_strict   = Demand -> Bool
isStrUsedDmd Demand
dmd
    ok_for_spec :: Bool
ok_for_spec = CpeApp -> Bool
exprOkForSpeculation CpeApp
rhs

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

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

wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds :: Floats -> CpeApp -> CpeApp
wrapBinds (Floats OkToSpec
_ OrdList FloatingBind
binds) CpeApp
body
  = (FloatingBind -> CpeApp -> CpeApp)
-> CpeApp -> OrdList FloatingBind -> CpeApp
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CpeApp -> CpeApp
mk_bind CpeApp
body OrdList FloatingBind
binds
  where
    mk_bind :: FloatingBind -> CpeApp -> CpeApp
mk_bind (FloatCase CpeApp
rhs Id
bndr AltCon
con [Id]
bs Bool
_) CpeApp
body = CpeApp -> Id -> Type -> [Alt Id] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
rhs Id
bndr ((() :: Constraint) => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
body) [AltCon -> [Id] -> CpeApp -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs CpeApp
body]
    mk_bind (FloatLet CoreBind
bind)               CpeApp
body = CoreBind -> CpeApp -> CpeApp
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CpeApp
body
    mk_bind (FloatTick CoreTickish
tickish)           CpeApp
body = CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
tickish CpeApp
body

addFloat :: Floats -> FloatingBind -> Floats
addFloat :: Floats -> FloatingBind -> Floats
addFloat (Floats OkToSpec
ok_to_spec OrdList FloatingBind
floats) FloatingBind
new_float
  = OkToSpec -> OrdList FloatingBind -> Floats
Floats (OkToSpec -> OkToSpec -> OkToSpec
combine OkToSpec
ok_to_spec (FloatingBind -> OkToSpec
check FloatingBind
new_float)) (OrdList FloatingBind
floats OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
new_float)
  where
    check :: FloatingBind -> OkToSpec
check (FloatLet {})  = OkToSpec
OkToSpec
    check (FloatCase CpeApp
_ Id
_ AltCon
_ [Id]
_ Bool
ok_for_spec)
      | Bool
ok_for_spec = OkToSpec
IfUnboxedOk
      | Bool
otherwise   = OkToSpec
NotOkToSpec
    check FloatTick{}    = OkToSpec
OkToSpec
        -- The ok-for-speculation flag says that it's safe to
        -- float this Case out of a let, and thereby do it more eagerly
        -- We need the top-level flag because it's never ok to float
        -- an unboxed binding to the top level

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

appendFloats :: Floats -> Floats -> Floats
appendFloats :: Floats -> Floats -> Floats
appendFloats (Floats OkToSpec
spec1 OrdList FloatingBind
floats1) (Floats OkToSpec
spec2 OrdList FloatingBind
floats2)
  = OkToSpec -> OrdList FloatingBind -> Floats
Floats (OkToSpec -> OkToSpec -> OkToSpec
combine OkToSpec
spec1 OkToSpec
spec2) (OrdList FloatingBind
floats1 OrdList FloatingBind
-> OrdList FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList FloatingBind
floats2)

concatFloats :: [Floats] -> OrdList FloatingBind
concatFloats :: [Floats] -> OrdList FloatingBind
concatFloats = (Floats -> OrdList FloatingBind -> OrdList FloatingBind)
-> OrdList FloatingBind -> [Floats] -> OrdList FloatingBind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Floats OkToSpec
_ OrdList FloatingBind
bs1) OrdList FloatingBind
bs2 -> OrdList FloatingBind
-> OrdList FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> OrdList a -> OrdList a
appOL OrdList FloatingBind
bs1 OrdList FloatingBind
bs2) OrdList FloatingBind
forall a. OrdList a
nilOL

combine :: OkToSpec -> OkToSpec -> OkToSpec
combine :: OkToSpec -> OkToSpec -> OkToSpec
combine OkToSpec
NotOkToSpec OkToSpec
_ = OkToSpec
NotOkToSpec
combine OkToSpec
_ OkToSpec
NotOkToSpec = OkToSpec
NotOkToSpec
combine OkToSpec
IfUnboxedOk OkToSpec
_ = OkToSpec
IfUnboxedOk
combine OkToSpec
_ OkToSpec
IfUnboxedOk = OkToSpec
IfUnboxedOk
combine OkToSpec
_ OkToSpec
_           = OkToSpec
OkToSpec

deFloatTop :: Floats -> [CoreBind]
-- For top level only; we don't expect any FloatCases
deFloatTop :: Floats -> CoreProgram
deFloatTop (Floats OkToSpec
_ OrdList FloatingBind
floats)
  = (FloatingBind -> CoreProgram -> CoreProgram)
-> CoreProgram -> OrdList FloatingBind -> CoreProgram
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CoreProgram -> CoreProgram
get [] OrdList FloatingBind
floats
  where
    get :: FloatingBind -> CoreProgram -> CoreProgram
get (FloatLet CoreBind
b)               CoreProgram
bs = CoreBind -> CoreBind
get_bind CoreBind
b                 CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
bs
    get (FloatCase CpeApp
body Id
var AltCon
_ [Id]
_ Bool
_) CoreProgram
bs = CoreBind -> CoreBind
get_bind (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
var CpeApp
body) 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
"corePrepPgm" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
b)

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

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

canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
canFloat :: Floats -> CpeApp -> Maybe (Floats, CpeApp)
canFloat (Floats OkToSpec
ok_to_spec OrdList FloatingBind
fs) CpeApp
rhs
  | OkToSpec
OkToSpec <- OkToSpec
ok_to_spec           -- Worth trying
  , Just OrdList FloatingBind
fs' <- OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go OrdList FloatingBind
forall a. OrdList a
nilOL (OrdList FloatingBind -> [FloatingBind]
forall a. OrdList a -> [a]
fromOL OrdList FloatingBind
fs)
  = (Floats, CpeApp) -> Maybe (Floats, CpeApp)
forall a. a -> Maybe a
Just (OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
OkToSpec OrdList FloatingBind
fs', CpeApp
rhs)
  | Bool
otherwise
  = Maybe (Floats, CpeApp)
forall a. Maybe a
Nothing
  where
    go :: OrdList FloatingBind -> [FloatingBind]
       -> Maybe (OrdList FloatingBind)

    go :: OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go (OrdList FloatingBind
fbs_out) [] = OrdList FloatingBind -> Maybe (OrdList FloatingBind)
forall a. a -> Maybe a
Just OrdList FloatingBind
fbs_out

    go OrdList FloatingBind
fbs_out (fb :: FloatingBind
fb@(FloatLet CoreBind
_) : [FloatingBind]
fbs_in)
      = OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go (OrdList FloatingBind
fbs_out OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
fb) [FloatingBind]
fbs_in

    go OrdList FloatingBind
fbs_out (ft :: FloatingBind
ft@FloatTick{} : [FloatingBind]
fbs_in)
      = OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go (OrdList FloatingBind
fbs_out OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
ft) [FloatingBind]
fbs_in

    go OrdList FloatingBind
_ (FloatCase{} : [FloatingBind]
_) = Maybe (OrdList FloatingBind)
forall a. Maybe a
Nothing


wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeApp -> Bool
wantFloatNested RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CpeApp
rhs
  =  Floats -> Bool
isEmptyFloats Floats
floats
  Bool -> Bool -> Bool
|| Demand -> Bool
isStrUsedDmd Demand
dmd
  Bool -> Bool -> Bool
|| Bool
is_unlifted
  Bool -> Bool -> Bool
|| (RecFlag -> Floats -> Bool
allLazyNested RecFlag
is_rec Floats
floats Bool -> Bool -> Bool
&& CpeApp -> Bool
exprIsHNF CpeApp
rhs)
        -- Why the test for allLazyNested?
        --      v = f (x `divInt#` y)
        -- we don't want to float the case, even if f has arity 2,
        -- because floating the case would make it evaluated too early

allLazyTop :: Floats -> Bool
allLazyTop :: Floats -> Bool
allLazyTop (Floats OkToSpec
OkToSpec OrdList FloatingBind
_) = Bool
True
allLazyTop Floats
_                   = Bool
False

allLazyNested :: RecFlag -> Floats -> Bool
allLazyNested :: RecFlag -> Floats -> Bool
allLazyNested RecFlag
_      (Floats OkToSpec
OkToSpec    OrdList FloatingBind
_) = Bool
True
allLazyNested RecFlag
_      (Floats OkToSpec
NotOkToSpec OrdList FloatingBind
_) = Bool
False
allLazyNested RecFlag
is_rec (Floats OkToSpec
IfUnboxedOk OrdList FloatingBind
_) = RecFlag -> Bool
isNonRec RecFlag
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 [CorePrep inlines trivial CoreExpr not Id]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
IdEnv Id?  Naively, we might conjecture that trivial updatable thunks
as per Note [Inlining in CorePrep] always have the form
'lazy @ SomeType gbl_id'.  But this is not true: the following is
perfectly reasonable Core:

     let x :: ()
         x = lazy @ (forall a. a) y @ Bool

When we inline 'x' 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_env must
map to CoreExprs, not Ids.

-}

data CorePrepEnv
  = CPE { CorePrepEnv -> DynFlags
cpe_dynFlags        :: DynFlags
        , CorePrepEnv -> IdEnv CpeApp
cpe_env             :: IdEnv CoreExpr   -- Clone local Ids
        -- ^ This environment is used for three operations:
        --
        --      1. To support cloning of local Ids so that they are
        --      all unique (see item (6) of CorePrep overview).
        --
        --      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]
        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)

        , CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv]

        , CorePrepEnv -> LitNumType -> Integer -> Maybe CpeApp
cpe_convertNumLit   :: LitNumType -> Integer -> Maybe CoreExpr
        -- ^ Convert some numeric literals (Integer, Natural) into their
        -- final Core form
    }

mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env = do
   LitNumType -> Integer -> Maybe CpeApp
convertNumLit <- HscEnv -> IO (LitNumType -> Integer -> Maybe CpeApp)
mkConvertNumLiteral HscEnv
hsc_env
   CorePrepEnv -> IO CorePrepEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> IO CorePrepEnv) -> CorePrepEnv -> IO CorePrepEnv
forall a b. (a -> b) -> a -> b
$ CPE
      { cpe_dynFlags :: DynFlags
cpe_dynFlags      = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      , cpe_env :: IdEnv CpeApp
cpe_env           = IdEnv CpeApp
forall a. VarEnv a
emptyVarEnv
      , cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env      = Maybe CpeTyCoEnv
forall a. Maybe a
Nothing
      , cpe_convertNumLit :: LitNumType -> Integer -> Maybe CpeApp
cpe_convertNumLit = LitNumType -> Integer -> Maybe CpeApp
convertNumLit
      }

extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
cpe Id
id Id
id'
    = CorePrepEnv
cpe { cpe_env :: IdEnv CpeApp
cpe_env = IdEnv CpeApp -> Id -> CpeApp -> IdEnv CpeApp
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (CorePrepEnv -> IdEnv CpeApp
cpe_env CorePrepEnv
cpe) Id
id (Id -> CpeApp
forall b. Id -> Expr b
Var Id
id') }

extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CpeApp -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
cpe Id
id CpeApp
expr
    = CorePrepEnv
cpe { cpe_env :: IdEnv CpeApp
cpe_env = IdEnv CpeApp -> Id -> CpeApp -> IdEnv CpeApp
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (CorePrepEnv -> IdEnv CpeApp
cpe_env CorePrepEnv
cpe) Id
id CpeApp
expr }

extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList :: CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
cpe [(Id, Id)]
prs
    = CorePrepEnv
cpe { cpe_env :: IdEnv CpeApp
cpe_env = IdEnv CpeApp -> [(Id, CpeApp)] -> IdEnv CpeApp
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList (CorePrepEnv -> IdEnv CpeApp
cpe_env CorePrepEnv
cpe)
                        (((Id, Id) -> (Id, CpeApp)) -> [(Id, Id)] -> [(Id, CpeApp)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id, Id
id') -> (Id
id, Id -> CpeApp
forall b. Id -> Expr b
Var Id
id')) [(Id, Id)]
prs) }

lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv :: CorePrepEnv -> Id -> CpeApp
lookupCorePrepEnv CorePrepEnv
cpe Id
id
  = case IdEnv CpeApp -> Id -> Maybe CpeApp
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (CorePrepEnv -> IdEnv CpeApp
cpe_env CorePrepEnv
cpe) Id
id of
        Maybe CpeApp
Nothing  -> Id -> CpeApp
forall b. Id -> Expr b
Var Id
id
        Just CpeApp
exp -> CpeApp
exp

------------------------------------------------------------------------------
--           CpeTyCoEnv
-- ---------------------------------------------------------------------------

{- Note [CpeTyCoEnv]
~~~~~~~~~~~~~~~~~~~~
The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution
for type and coercion varibles

* We need the coercion substitution to support the elimination of
  unsafeEqualityProof (see Note [Unsafe coercions])

* We need the type substitution in case one of those unsafe
  coercions occurs in the kind of tyvar binder (sigh)

We don't need an in-scope set because we don't clone any of these
binders at all, so no new capture can take place.

The cpe_tyco_env is almost always empty -- it only gets populated
when we get under an usafeEqualityProof.  Hence the Maybe CpeTyCoEnv,
which makes everything into a no-op in the common case.
-}

data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv

emptyTCE :: CpeTyCoEnv
emptyTCE :: CpeTyCoEnv
emptyTCE = TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
TCE TvSubstEnv
emptyTvSubstEnv CvSubstEnv
emptyCvSubstEnv

extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv
extend_tce_cv :: CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
extend_tce_cv (TCE TvSubstEnv
tv_env CvSubstEnv
cv_env) Id
cv Coercion
co
  = TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
TCE TvSubstEnv
tv_env (CvSubstEnv -> Id -> Coercion -> CvSubstEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv CvSubstEnv
cv_env Id
cv Coercion
co)

extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv
extend_tce_tv :: CpeTyCoEnv -> Id -> Type -> CpeTyCoEnv
extend_tce_tv (TCE TvSubstEnv
tv_env CvSubstEnv
cv_env) Id
tv Type
ty
  = TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
TCE (TvSubstEnv -> Id -> Type -> TvSubstEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv TvSubstEnv
tv_env Id
tv Type
ty) CvSubstEnv
cv_env

lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion
lookup_tce_cv :: CpeTyCoEnv -> Id -> Coercion
lookup_tce_cv (TCE TvSubstEnv
_ CvSubstEnv
cv_env) Id
cv
  = case CvSubstEnv -> Id -> Maybe Coercion
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv CvSubstEnv
cv_env Id
cv of
        Just Coercion
co -> Coercion
co
        Maybe Coercion
Nothing -> Id -> Coercion
mkCoVarCo Id
cv

lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type
lookup_tce_tv :: CpeTyCoEnv -> Id -> Type
lookup_tce_tv (TCE TvSubstEnv
tv_env CvSubstEnv
_) Id
tv
  = case TvSubstEnv -> Id -> Maybe Type
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv TvSubstEnv
tv_env Id
tv of
        Just Type
ty -> Type
ty
        Maybe Type
Nothing -> Id -> Type
mkTyVarTy Id
tv

extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv
extendCoVarEnv :: CorePrepEnv -> Id -> Coercion -> CorePrepEnv
extendCoVarEnv cpe :: CorePrepEnv
cpe@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_tce }) Id
cv Coercion
co
  = CorePrepEnv
cpe { cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = CpeTyCoEnv -> Maybe CpeTyCoEnv
forall a. a -> Maybe a
Just (CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
extend_tce_cv CpeTyCoEnv
tce Id
cv Coercion
co) }
  where
    tce :: CpeTyCoEnv
tce = Maybe CpeTyCoEnv
mb_tce Maybe CpeTyCoEnv -> CpeTyCoEnv -> CpeTyCoEnv
forall a. Maybe a -> a -> a
`orElse` CpeTyCoEnv
emptyTCE


cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy (CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Type
ty
  = case Maybe CpeTyCoEnv
mb_env of
      Just CpeTyCoEnv
env -> Identity Type -> Type
forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
env Type
ty)
      Maybe CpeTyCoEnv
Nothing  -> Type
ty

cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo (CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Coercion
co
  = case Maybe CpeTyCoEnv
mb_env of
      Just CpeTyCoEnv
tce -> Identity Coercion -> Coercion
forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Coercion -> Identity Coercion
subst_co CpeTyCoEnv
tce Coercion
co)
      Maybe CpeTyCoEnv
Nothing  -> Coercion
co

subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
subst_tyco_mapper = TyCoMapper
  { tcm_tyvar :: CpeTyCoEnv -> Id -> Identity Type
tcm_tyvar      = \CpeTyCoEnv
env Id
tv -> Type -> Identity Type
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> Type
lookup_tce_tv CpeTyCoEnv
env Id
tv)
  , tcm_covar :: CpeTyCoEnv -> Id -> Identity Coercion
tcm_covar      = \CpeTyCoEnv
env Id
cv -> Coercion -> Identity Coercion
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> Coercion
lookup_tce_cv CpeTyCoEnv
env Id
cv)
  , tcm_hole :: CpeTyCoEnv -> CoercionHole -> Identity Coercion
tcm_hole       = \CpeTyCoEnv
_ CoercionHole
hole -> String -> SDoc -> Identity Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"subst_co_mapper:hole" (CoercionHole -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionHole
hole)
  , tcm_tycobinder :: CpeTyCoEnv -> Id -> ArgFlag -> Identity (CpeTyCoEnv, Id)
tcm_tycobinder = \CpeTyCoEnv
env Id
tcv ArgFlag
_vis -> if Id -> Bool
isTyVar Id
tcv
                                      then (CpeTyCoEnv, Id) -> Identity (CpeTyCoEnv, Id)
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
env Id
tcv)
                                      else (CpeTyCoEnv, Id) -> Identity (CpeTyCoEnv, Id)
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_cv_bndr CpeTyCoEnv
env Id
tcv)
  , tcm_tycon :: TyCon -> Identity TyCon
tcm_tycon      = \TyCon
tc -> TyCon -> Identity TyCon
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc }

subst_ty :: CpeTyCoEnv -> Type     -> Identity Type
subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion
(CpeTyCoEnv -> Type -> Identity Type
subst_ty, CpeTyCoEnv -> [Type] -> Identity [Type]
_, CpeTyCoEnv -> Coercion -> Identity Coercion
subst_co, CpeTyCoEnv -> [Coercion] -> Identity [Coercion]
_) = TyCoMapper CpeTyCoEnv Identity
-> (CpeTyCoEnv -> Type -> Identity Type,
    CpeTyCoEnv -> [Type] -> Identity [Type],
    CpeTyCoEnv -> Coercion -> Identity Coercion,
    CpeTyCoEnv -> [Coercion] -> Identity [Coercion])
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m
-> (env -> Type -> m Type, env -> [Type] -> m [Type],
    env -> Coercion -> m Coercion, env -> [Coercion] -> m [Coercion])
mapTyCoX TyCoMapper CpeTyCoEnv Identity
subst_tyco_mapper

cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar)
cpSubstTyVarBndr :: CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstTyVarBndr env :: CorePrepEnv
env@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Id
tv
  = case Maybe CpeTyCoEnv
mb_env of
      Maybe CpeTyCoEnv
Nothing  -> (CorePrepEnv
env, Id
tv)
      Just CpeTyCoEnv
tce -> (CorePrepEnv
env { cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = CpeTyCoEnv -> Maybe CpeTyCoEnv
forall a. a -> Maybe a
Just CpeTyCoEnv
tce' }, Id
tv')
               where
                  (CpeTyCoEnv
tce', Id
tv') = CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
tce Id
tv

subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)
subst_tv_bndr :: CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
tce Id
tv
  = (CpeTyCoEnv -> Id -> Type -> CpeTyCoEnv
extend_tce_tv CpeTyCoEnv
tce Id
tv (Id -> Type
mkTyVarTy Id
tv'), Id
tv')
  where
    tv' :: Id
tv'   = Name -> Type -> Id
mkTyVar (Id -> Name
tyVarName Id
tv) Type
kind'
    kind' :: Type
kind' = Identity Type -> Type
forall a. Identity a -> a
runIdentity (Identity Type -> Type) -> Identity Type -> Type
forall a b. (a -> b) -> a -> b
$ CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
tce (Type -> Identity Type) -> Type -> Identity Type
forall a b. (a -> b) -> a -> b
$ Id -> Type
tyVarKind Id
tv

cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)
cpSubstCoVarBndr :: CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstCoVarBndr env :: CorePrepEnv
env@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Id
cv
  = case Maybe CpeTyCoEnv
mb_env of
      Maybe CpeTyCoEnv
Nothing  -> (CorePrepEnv
env, Id
cv)
      Just CpeTyCoEnv
tce -> (CorePrepEnv
env { cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = CpeTyCoEnv -> Maybe CpeTyCoEnv
forall a. a -> Maybe a
Just CpeTyCoEnv
tce' }, Id
cv')
               where
                  (CpeTyCoEnv
tce', Id
cv') = CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_cv_bndr CpeTyCoEnv
tce Id
cv

subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)
subst_cv_bndr :: CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_cv_bndr CpeTyCoEnv
tce Id
cv
  = (CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
extend_tce_cv CpeTyCoEnv
tce Id
cv (Id -> Coercion
mkCoVarCo Id
cv'), Id
cv')
  where
    cv' :: Id
cv' = Name -> Type -> Id
mkCoVar (Id -> Name
varName Id
cv) Type
ty'
    ty' :: Type
ty' = Identity Type -> Type
forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
tce (Type -> Identity Type) -> Type -> Identity Type
forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
cv)

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

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

cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
cpCloneBndr :: CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
  | Id -> Bool
isTyVar Id
bndr
  = (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstTyVarBndr CorePrepEnv
env Id
bndr)

  | Id -> Bool
isCoVar Id
bndr
  = (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstCoVarBndr CorePrepEnv
env Id
bndr)

  | Bool
otherwise
  = do { Id
bndr' <- Id -> UniqSM Id
clone_it Id
bndr

       -- Drop (now-useless) rules/unfoldings
       -- See Note [Drop unfoldings and rules]
       -- and Note [Preserve evaluatedness] in GHC.Core.Tidy
       ; let unfolding' :: Unfolding
unfolding' = Unfolding -> Unfolding
zapUnfolding (Id -> Unfolding
realIdUnfolding Id
bndr)
                          -- Simplifier will set the Id's unfolding

             bndr'' :: Id
bndr'' = Id
bndr' Id -> Unfolding -> Id
`setIdUnfolding`      Unfolding
unfolding'
                            Id -> RuleInfo -> Id
`setIdSpecialisation` RuleInfo
emptyRuleInfo

       ; (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
bndr Id
bndr'', Id
bndr'') }
  where
    clone_it :: Id -> UniqSM Id
clone_it Id
bndr
      | Id -> Bool
isLocalId Id
bndr
      = do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
           ; let ty' :: Type
ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env (Id -> Type
idType Id
bndr)
           ; Id -> UniqSM Id
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Unique -> Id
setVarUnique (Id -> Type -> Id
setIdType Id
bndr Type
ty') Unique
uniq) }

      | Bool
otherwise   -- Top level things, which we don't want
                    -- to clone, have become GlobalIds by now
      = Id -> UniqSM Id
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
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 :: Id -> UniqSM Id
fiddleCCall Id
id
  | Id -> Bool
isFCallId Id
id = (Id
id Id -> Unique -> Id
`setVarUnique`) (Unique -> Id) -> UniqSM Unique -> UniqSM Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  | Bool
otherwise    = Id -> UniqSM Id
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
id

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

newVar :: Type -> UniqSM Id
newVar :: Type -> UniqSM Id
newVar Type
ty
 = Type -> ()
seqType Type
ty () -> UniqSM Id -> UniqSM Id
forall a b. a -> b -> b
`seq` do
     Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
     Id -> UniqSM Id
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Type -> Type -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"sat") Unique
uniq Type
Many 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 -> CpeApp -> (Floats, CpeApp)
wrapTicks (Floats OkToSpec
flag OrdList FloatingBind
floats0) CpeApp
expr =
    (OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
flag ([FloatingBind] -> OrdList FloatingBind
forall a. [a] -> OrdList a
toOL ([FloatingBind] -> OrdList FloatingBind)
-> [FloatingBind] -> OrdList FloatingBind
forall a b. (a -> b) -> a -> b
$ [FloatingBind] -> [FloatingBind]
forall a. [a] -> [a]
reverse [FloatingBind]
floats1), (CoreTickish -> CpeApp -> CpeApp)
-> CpeApp -> [CoreTickish] -> CpeApp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CpeApp -> CpeApp
mkTick CpeApp
expr ([CoreTickish] -> [CoreTickish]
forall a. [a] -> [a]
reverse [CoreTickish]
ticks1))
  where ([FloatingBind]
floats1, [CoreTickish]
ticks1) = (([FloatingBind], [CoreTickish])
 -> FloatingBind -> ([FloatingBind], [CoreTickish]))
-> ([FloatingBind], [CoreTickish])
-> OrdList FloatingBind
-> ([FloatingBind], [CoreTickish])
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL ([FloatingBind], [CoreTickish])
-> FloatingBind -> ([FloatingBind], [CoreTickish])
go ([], []) (OrdList FloatingBind -> ([FloatingBind], [CoreTickish]))
-> OrdList FloatingBind -> ([FloatingBind], [CoreTickish])
forall a b. (a -> b) -> a -> b
$ OrdList FloatingBind
floats0
        -- 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 :: ([FloatingBind], [CoreTickish])
-> FloatingBind -> ([FloatingBind], [CoreTickish])
go ([FloatingBind]
floats, [CoreTickish]
ticks) (FloatTick CoreTickish
t)
          = Bool
-> ([FloatingBind], [CoreTickish])
-> ([FloatingBind], [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)
            ([FloatingBind]
floats, if (CoreTickish -> Bool) -> [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) [CoreTickish]
ticks
                     then [CoreTickish]
ticks else CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ticks)
        go ([FloatingBind]
floats, [CoreTickish]
ticks) FloatingBind
f
          = ((CoreTickish -> FloatingBind -> FloatingBind)
-> FloatingBind -> [CoreTickish] -> FloatingBind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> FloatingBind -> FloatingBind
wrap FloatingBind
f ([CoreTickish] -> [CoreTickish]
forall a. [a] -> [a]
reverse [CoreTickish]
ticks)FloatingBind -> [FloatingBind] -> [FloatingBind]
forall a. a -> [a] -> [a]
:[FloatingBind]
floats, [CoreTickish]
ticks)

        wrap :: CoreTickish -> FloatingBind -> FloatingBind
wrap CoreTickish
t (FloatLet CoreBind
bind)           = CoreBind -> FloatingBind
FloatLet (CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t CoreBind
bind)
        wrap CoreTickish
t (FloatCase CpeApp
r Id
b AltCon
con [Id]
bs Bool
ok) = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t CpeApp
r) Id
b AltCon
con [Id]
bs Bool
ok
        wrap CoreTickish
_ FloatingBind
other                     = String -> SDoc -> FloatingBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"wrapTicks: unexpected float!"
                                             (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
other)
        wrapBind :: CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t (NonRec Id
binder CpeApp
rhs) = Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
binder (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t CpeApp
rhs)
        wrapBind CoreTickish
t (Rec [(Id, CpeApp)]
pairs)         = [(Id, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ((CpeApp -> CpeApp) -> [(Id, CpeApp)] -> [(Id, CpeApp)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t) [(Id, CpeApp)]
pairs)

floatableTick :: GenTickish pass -> Bool
floatableTick :: forall (pass :: TickishPass). GenTickish pass -> Bool
floatableTick GenTickish pass
tickish =
    GenTickish pass -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace GenTickish pass
tickish TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam Bool -> Bool -> Bool
&&
    GenTickish pass
tickish GenTickish pass -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope

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

-- | Create a function that converts Bignum literals into their final CoreExpr
mkConvertNumLiteral
   :: HscEnv
   -> IO (LitNumType -> Integer -> Maybe CoreExpr)
mkConvertNumLiteral :: HscEnv -> IO (LitNumType -> Integer -> Maybe CpeApp)
mkConvertNumLiteral HscEnv
hsc_env = do
   let
      dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
      guardBignum :: IO Id -> IO Id
guardBignum IO Id
act
         | HomeUnit -> UnitId -> Bool
isHomeUnitInstanceOf HomeUnit
home_unit UnitId
primUnitId
         = Id -> IO Id
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> IO Id) -> Id -> IO Id
forall a b. (a -> b) -> a -> b
$ String -> Id
forall a. String -> a
panic String
"Bignum literals are not supported in ghc-prim"
         | HomeUnit -> UnitId -> Bool
isHomeUnitInstanceOf HomeUnit
home_unit UnitId
bignumUnitId
         = Id -> IO Id
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> IO Id) -> Id -> IO Id
forall a b. (a -> b) -> a -> b
$ String -> Id
forall a. String -> a
panic String
"Bignum literals are not supported in ghc-bignum"
         | Bool
otherwise = IO Id
act

      lookupBignumId :: Name -> IO Id
lookupBignumId Name
n      = IO Id -> IO Id
guardBignum ((() :: Constraint) => TyThing -> Id
TyThing -> Id
tyThingId (TyThing -> Id) -> IO TyThing -> IO Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
n)

   -- The lookup is done here but the failure (panic) is reported lazily when we
   -- try to access the `bigNatFromWordList` function.
   --
   -- If we ever get built-in ByteArray# literals, we could avoid the lookup by
   -- directly using the Integer/Natural wired-in constructors for big numbers.

   Id
bignatFromWordListId <- Name -> IO Id
lookupBignumId Name
bignatFromWordListName

   let
      convertNumLit :: LitNumType -> Integer -> Maybe CpeApp
convertNumLit LitNumType
nt Integer
i = case LitNumType
nt of
         LitNumType
LitNumBigNat  -> CpeApp -> Maybe CpeApp
forall a. a -> Maybe a
Just (Integer -> CpeApp
convertBignatPrim Integer
i)
         LitNumType
_             -> Maybe CpeApp
forall a. Maybe a
Nothing

      convertBignatPrim :: Integer -> CpeApp
convertBignatPrim Integer
i =
         let
            target :: Platform
target    = DynFlags -> Platform
targetPlatform DynFlags
dflags

            -- ByteArray# literals aren't supported (yet). Were they supported,
            -- we would use them directly. We would need to handle
            -- wordSize/endianness conversion between host and target
            -- wordSize  = platformWordSize platform
            -- byteOrder = platformByteOrder platform

            -- For now we build a list of Words and we produce
            -- `bigNatFromWordList# list_of_words`

            words :: CpeApp
words = Type -> [CpeApp] -> CpeApp
mkListExpr Type
wordTy ([CpeApp] -> [CpeApp]
forall a. [a] -> [a]
reverse ((Integer -> Maybe (CpeApp, Integer)) -> Integer -> [CpeApp]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Integer -> Maybe (CpeApp, Integer)
f Integer
i))
               where
                  f :: Integer -> Maybe (CpeApp, Integer)
f Integer
0 = Maybe (CpeApp, Integer)
forall a. Maybe a
Nothing
                  f Integer
x = let low :: Integer
low  = Integer
x Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
mask
                            high :: Integer
high = Integer
x Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
bits
                        in (CpeApp, Integer) -> Maybe (CpeApp, Integer)
forall a. a -> Maybe a
Just (DataCon -> [CpeApp] -> CpeApp
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
wordDataCon [Literal -> CpeApp
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
low)], Integer
high)
                  bits :: Int
bits = Platform -> Int
platformWordSizeInBits Platform
target
                  mask :: Integer
mask = Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
bits Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1

         in CpeApp -> [CpeApp] -> CpeApp
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CpeApp
forall b. Id -> Expr b
Var Id
bignatFromWordListId) [CpeApp
words]


   (LitNumType -> Integer -> Maybe CpeApp)
-> IO (LitNumType -> Integer -> Maybe CpeApp)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LitNumType -> Integer -> Maybe CpeApp
convertNumLit