{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections    #-}
{-# LANGUAGE MultiWayIf       #-}

{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-2012

Note [Unarisation]
~~~~~~~~~~~~~~~~~~
The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
binders. So for example:

  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)

  ==>

  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True

It is important that we do this at the STG level and NOT at the Core level
because it would be very hard to make this pass Core-type-preserving. In this
example the type of 'f' changes, for example.

STG fed to the code generators *must* be unarised because the code generators do
not support unboxed tuple and unboxed sum binders natively.

In more detail: (see next note for unboxed sums)

Suppose that a variable x : (# t1, t2 #).

  * At the binding site for x, make up fresh vars  x1:t1, x2:t2

  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]

  * Replace the binding with a curried binding for x1,x2

       Lambda:   \x.e                ==>   \x1 x2. e
       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e

  * Replace argument occurrences with a sequence of args via a lookup in
    UnariseEnv

       f a b x c d   ==>   f a b x1 x2 c d

  * Replace tail-call occurrences with an unboxed tuple via a lookup in
    UnariseEnv

       x  ==>  (# x1, x2 #)

    So, for example

       f x = x    ==>   f x1 x2 = (# x1, x2 #)

  * We /always/ eliminate a case expression when

       - It scrutinises an unboxed tuple or unboxed sum

       - The scrutinee is a variable (or when it is an explicit tuple, but the
         simplifier eliminates those)

    The case alternative (there can be only one) can be one of these two
    things:

      - An unboxed tuple pattern. e.g.

          case v of x { (# x1, x2, x3 #) -> ... }

        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
        environment with

          x :-> MultiVal [t1,t2,t3]
          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3

      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3

By the end of this pass, we only have unboxed tuples in return positions.
Unboxed sums are completely eliminated, see next note.

Note [Translating unboxed sums to unboxed tuples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unarise also eliminates unboxed sum binders, and translates unboxed sums in
return positions to unboxed tuples. We want to overlap fields of a sum when
translating it to a tuple to have efficient memory layout. When translating a
sum pattern to a tuple pattern, we need to translate it so that binders of sum
alternatives will be mapped to right arguments after the term translation. So
translation of sum DataCon applications to tuple DataCon applications and
translation of sum patterns to tuple patterns need to be in sync.

These translations work like this. Suppose we have

  (# x1 | | ... #) :: (# t1 | t2 | ... #)

remember that t1, t2 ... can be sums and tuples too. So we first generate
layouts of those. Then we "merge" layouts of each alternative, which gives us a
sum layout with best overlapping possible.

Layout of a flat type 'ty1' is just [ty1].
Layout of a tuple is just concatenation of layouts of its fields.

For layout of a sum type,

  - We first get layouts of all alternatives.
  - We sort these layouts based on their "slot types".
  - We merge all the alternatives.

For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)

  - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ]
  - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ]
  - Merge all alternatives together: [ LiftedPtr, Word, Word ]

We add a slot for the tag to the first position. So our tuple type is

  (# Tag#, Any, Word#, Word# #)
  (we use Any for pointer slots)

Now, any term of this sum type needs to generate a tuple of this type instead.
The translation works by simply putting arguments to first slots that they fit
in. Suppose we had

  (# (# 42#, 'c' #) | | #)

42# fits in Word#, 'c' fits in Any, so we generate this application:

  (# 1#, 'c', 42#, rubbish #)

Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
3# fits in Word #, so we get:

  (# 2#, rubbish, 2#, 3# #).


Note [Don't merge lifted and unlifted slots]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When merging slots, one might be tempted to collapse lifted and unlifted
pointers. However, as seen in #19645, this is wrong. Imagine that you have
the program:

  test :: (# Char | ByteArray# #) -> ByteArray#
  test (# c | #) = doSomething c
  test (# | ba #) = ba

Collapsing the Char and ByteArray# slots would produce STG like:

  test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#
    = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]
          case tag of tag'
            1# -> doSomething slot0
            2# -> slot0;

Note how `slot0` has a lifted type, despite being bound to an unlifted
ByteArray# in the 2# alternative. This liftedness would cause the code generator to
attempt to enter it upon returning. As unlifted objects do not have entry code,
this causes a runtime crash.

For this reason, Unarise treats unlifted and lifted things as distinct slot
types, despite both being GC pointers. This approach is a slight pessimisation
(since we need to pass more arguments) but appears to be the simplest way to
avoid #19645. Other alternatives considered include:

 a. Giving unlifted objects "trivial" entry code. However, we ultimately
    concluded that the value of the "unlifted things are never entered" invariant
    outweighed the simplicity of this approach.

 b. Annotating occurrences with calling convention information instead of
    relying on the binder's type. This seemed like a very complicated
    way to fix what is ultimately a corner-case.


Note [Representations in StgConApp]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have this unboxed sum term:

  (# 123 | #)

What will be the unboxed tuple representation? We can't tell without knowing the
type of this term. For example, these are all valid tuples for this:

  (# 1#, 123 #)          -- when type is (# Int | String #)
  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
  (# 1#, 123, rubbish, rubbish #)
                         -- when type is (# Int | (# Int, Int, Int #) #)

Therefore, in StgConApp we store a list [[PrimRep]] of representations
to decide what layout to use.
Given (# T_1 | ... | T_n #), this list will be
[typePrimRep T_1, ..., typePrimRep T_n].
For example, given type
  (# Int | String #)              we will store [[LiftedRep], [LiftedRep]]
  (# Int | Float# #)              we will store [[LiftedRep], [FloatRep]]
  (# Int | (# Int, Int, Int #) #) we will store [[LiftedRep], [LiftedRep, LiftedRep, LiftedRep]].

This field is used for unboxed sums only and it's an empty list otherwise.
Perhaps it would be more elegant to have a separate StgUnboxedSumCon,
but that would require duplication of code in cases where the logic is shared.

Note that unlifted values can't be let-bound, so we don't need
representations in StgRhsCon.

Note [Casting slot arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this function which selects between Int32# and Int64# from a unboxed sum.

    foo ::  (# Int32# | Int64#  #) -> FD
    foo x = case x of
        (# x1 | #) -> F x1
        (# | x2 #) -> D x2

Naturally we would expect x1 to have a PrimRep of Int32Rep and x2 of DoubleRep.
However we used to generate this (bogus) code after Unarise giving rise to #22208:

    M.foo :: (# GHC.Prim.Int32# | GHC.Prim.Int64# #) -> M.FD
    [GblId, Arity=1, Unf=OtherCon []] =
        {} \r [sum_tag sum_field]
            case sum_tag of tag_gsc {
              __DEFAULT -> M.F [sum_field];
              2# -> M.D [sum_field];
            };

Where sum_field is used both as Int32# and Int64# depending on the branch
because they share the same SlotTy.
This usually works out since we put all int's in the same sort of register.
So even if the reps where wrong (x :: bits32) = (y :: bits64) would produce
correct code in the most cases.
However there are cases where this goes wrong, causing lint errors,in the case of #22208
compiler panics or in some cases incorrect results in the C backend.
For now our solution is to construct proper casts between the PrimRep of the slot and
the variables we want to store in, or read out of these slots.

This means when we have a sum (# Int32# | Int64# #) if we want to store a Int32
we convert it to a Int64 on construction of the tuple value, and convert it back
to a Int32 once when want to use the field. On most backends these coversions should
be no-ops at runtime so this seems reasonable.

Conversion for values coming out of a strict field happen in mapSumIdBinders. While
conversion during the construction of sums happen inside mkUbxSum.

------------- A full example of casting during sum construction ----------------

To compile a constructor application of a unboxed sum of type (# Int32# | Int64# )
in an expression like  `let sum = (# x | #)` we will call mkUbxSum to determine
which binders we have to replace sum with at use sites during unarise.
See also Note [Translating unboxed sums to unboxed tuples].

Int32# and Int64# in this case will share the same slot in the unboxed sum. This means
the sum after unarise will be represented by two binders. One for the tag and one for
the field. The later having Int64Rep.
However our input for the field is of Int32Rep. So in order to soundly construct
`(# x | #) :: (# Int32# | Int64# )` we must upcast `x` to Int64#.
To do this mkUbxSum will produce an expression with a hole for constructor application
to go into. That is the call to mkUbxSum and it's result will look something like:

  >>> mkUbxSum (#|#) [Int32#, Int64#] (x::Int32#) us (x')
  ([1#::Int#, x'::Int64#], \rhs -> case int32ToInt# x of x' -> rhs )

We will use the returned arguments to construct an application to an unboxed tuple:

  >>> mkTuple [tag::Int#, x'::Int64#]
  (# tag, x' #)

Which we will then use as the rhs to pass into the casting wrapper to
construct an expression that casts `x` to the right type before constructing the
tuple

  >>> (\rhs -> case int32ToInt# x of x' -> rhs ) (# tag, x' #)
  case int32ToInt# x of x' -> (# #) 1# x'

Which results in the this definition for `sum` after all is said and done:

  let sum = case int32ToInt# x of { x' -> (# #) 1# x' }

Not that the renaming is not optional. Cmm requires binders of different uniques
to have at least different types. See Note [CorePrep Overview]: 6. Clone all local Ids

------------- A full example of casting during sum matching --------------------

When matching on an unboxed sum constructor we start out with
something like this the pre-unarise:

    f :: (# Int32 | Int64# ) -> ...
    f sum = case sum of
        (# x |#) -> alt_rhs
        ...

We unarise the function arguments and get:

    f sum_tag sum_slot1 = case sum_tag of
        1# -> ???

Now we need to match up the original alternative binders with the sum slots passed
to the function. This is done by mapSumIdBinders which we we call for our
example alternative like this:

    >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env
    (env', alt_rhs')

mapSumIdBinders first matches up the list of binders with the slots passed to
the function which is trivial in this case. Then we check if the slot and the
variable residing inside it agree on their Rep. If alternative binders and
the function arguments agree in their slot reps we we just extend the environment
with a mapping from `x` to `sum_slot1` and we return the rhs as is.

If the reps of the sum_slots do not agree with alternative binders they represent
then we need to wrap the whole RHS in nested cases which cast the sum_slot<n>
variables to the correct rep. Here `x` is of Int32Rep while `sum_slot1` will be
of Int64Rep. This means instead of retuning the original alt_rhs we will return:

  >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env
  ( env'[x=x']
  , case int64ToInt32# (sum_slot1 :: Int64#) of
      (x' :: Int32#) -> alt_rhs
  )

We then run unarise on alt_rhs within that expression, which will replace the first occurrence
of `x` with sum_slot_arg_1 giving us post-unarise:

    f sum_tag sum_slot1 =
      case sum_tag of
        1# -> case int64ToInt32# sum_slot1 of
          x' -> ... x' ...
        ...

Note [UnariseEnv]
~~~~~~~~~~~~~~~~~~
At any variable occurrence 'v',
* If the UnariseEnv has a binding for 'v', the binding says what 'v' is bound to
* If not, 'v' stands just for itself.

Most variables are unaffected by unarisation, and (for efficiency) we don't put
them in the UnariseEnv at all.  But NB: when we go under a binding for 'v' we must
remember to delete 'v' from the UnariseEnv, lest occurrences of 'v' see the outer
binding for the variable (#21396).


Note [UnariseEnv can map to literals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
needs to map variables to literals too. Suppose we have this Core:

  f (# x | #)

  ==> (CorePrep)

  case (# x | #) of y {
    _ -> f y
  }

  ==> (MultiVal)

  case (# 1#, x #) of [x1, x2] {
    _ -> f x1 x2
  }

To eliminate this case expression we need to map x1 to 1# in UnariseEnv:

  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x

so that `f x1 x2` becomes `f 1# x`.

Note [Unarisation and arity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Because of unarisation, the arity that will be recorded in the generated info
table for an Id may be larger than the idArity. Instead we record what we call
the RepArity, which is the Arity taking into account any expanded arguments, and
corresponds to the number of (possibly-void) *registers* arguments will arrive
in.

Note [Post-unarisation invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
STG programs after unarisation have these invariants:

 1. No unboxed sums at all.

 2. No unboxed tuple binders. Tuples only appear in return position.

 3. Binders and literals always have zero (for void arguments) or one PrimRep.
    (i.e. typePrimRep1 won't crash; see Note [VoidRep] in GHC.Types.RepType.)

 4. DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
    This means that it's safe to wrap `StgArg`s of DataCon applications with
    `GHC.StgToCmm.Env.NonVoid`, for example.

 5. Alt binders (binders in patterns) are always non-void.
-}

module GHC.Stg.Unarise (unarise) where

import GHC.Prelude

import GHC.Types.Basic
import GHC.Core
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Data.FastString (FastString, mkFastString, fsLit)
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
import GHC.Types.Id.Make (voidPrimId, voidArgId)
import GHC.Utils.Monad (mapAccumLM)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.RepType
import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Stg.Make
import GHC.Core.Type
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.Types
import GHC.Types.Unique.Supply
import GHC.Types.Unique
import GHC.Utils.Misc
import GHC.Types.Var.Env

import Data.Bifunctor (second)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (mapMaybe)
import qualified Data.IntMap as IM
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Casts
import Data.List (mapAccumL)

-- import GHC.Utils.Trace
--------------------------------------------------------------------------------

-- | A mapping from binders to the Ids they were expanded/renamed to.
--
--   x :-> MultiVal [a,b,c] in rho
--
-- iff  x's typePrimRep is not a singleton, or equivalently
--      x's type is an unboxed tuple, sum or void.
--
--    x :-> UnaryVal x'
--
-- iff x's RepType is UnaryRep or equivalently
--     x's type is not unboxed tuple, sum or void.
--
-- So
--     x :-> MultiVal [a] in rho
-- means x is represented by singleton tuple.
--
--     x :-> MultiVal [] in rho
-- means x is void.
--
-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
--            (i.e. no unboxed tuples, sums or voids)
--
data UnariseEnv = UnariseEnv
  { UnariseEnv -> VarEnv UnariseVal
ue_rho                 :: (VarEnv UnariseVal)
  , UnariseEnv -> DataCon -> [StgArg] -> Bool
ue_allow_static_conapp :: DataCon -> [StgArg] -> Bool
  }

initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv
initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv
initUnariseEnv = VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv
UnariseEnv

data UnariseVal
  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
  | UnaryVal OutStgArg   -- See Note [Renaming during unarisation].

instance Outputable UnariseVal where
  ppr :: UnariseVal -> SDoc
ppr (MultiVal [StgArg]
args) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MultiVal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args
  ppr (UnaryVal StgArg
arg)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UnaryVal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> StgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr StgArg
arg

-- | Extend the environment, checking the UnariseEnv invariant.
-- The id is mapped to one or more things.
-- See Note [UnariseEnv]
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
env Id
x (MultiVal [StgArg]
args)
  = Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert ((StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([PrimRep] -> Bool
isNvUnaryRep ([PrimRep] -> Bool) -> (StgArg -> [PrimRep]) -> StgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> [PrimRep]
stgArgRep) [StgArg]
args)
    UnariseEnv
env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) }
extendRho UnariseEnv
env Id
x (UnaryVal StgArg
val)
  = Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert ([PrimRep] -> Bool
isNvUnaryRep (StgArg -> [PrimRep]
stgArgRep StgArg
val))
    UnariseEnv
env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) }
-- Properly shadow things from an outer scope.
-- See Note [UnariseEnv]

-- The id stands for itself so we don't record a mapping.
-- See Note [UnariseEnv]
extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv
extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv
extendRhoWithoutValue UnariseEnv
env Id
x = UnariseEnv
env { ue_rho = delVarEnv (ue_rho env) x }

lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal
lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
env Id
v = VarEnv UnariseVal -> Id -> Maybe UnariseVal
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (UnariseEnv -> VarEnv UnariseVal
ue_rho UnariseEnv
env) Id
v

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

unarise :: UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding]
unarise :: UniqSupply
-> (DataCon -> [StgArg] -> Bool)
-> [StgTopBinding]
-> [StgTopBinding]
unarise UniqSupply
us DataCon -> [StgArg] -> Bool
is_dll_con_app [StgTopBinding]
binds = UniqSupply -> UniqSM [StgTopBinding] -> [StgTopBinding]
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us ((StgTopBinding -> UniqSM StgTopBinding)
-> [StgTopBinding] -> UniqSM [StgTopBinding]
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 (UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding (VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv
initUnariseEnv VarEnv UnariseVal
forall a. VarEnv a
emptyVarEnv DataCon -> [StgArg] -> Bool
is_dll_con_app)) [StgTopBinding]
binds)

unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding UnariseEnv
rho (StgTopLifted GenStgBinding 'Vanilla
bind)
  = GenStgBinding 'Vanilla -> StgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
-> UniqSM (GenStgBinding 'Vanilla) -> UniqSM StgTopBinding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> Bool
-> GenStgBinding 'Vanilla
-> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho Bool
True GenStgBinding 'Vanilla
bind
unariseTopBinding UnariseEnv
_ bind :: StgTopBinding
bind@StgTopStringLit{} = StgTopBinding -> UniqSM StgTopBinding
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return StgTopBinding
bind

unariseBinding :: UnariseEnv -> Bool -> StgBinding -> UniqSM StgBinding
unariseBinding :: UnariseEnv
-> Bool
-> GenStgBinding 'Vanilla
-> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho Bool
top_level (StgNonRec BinderP 'Vanilla
x GenStgRhs 'Vanilla
rhs)
  = BinderP 'Vanilla -> GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec BinderP 'Vanilla
x (GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla)
-> UniqSM (GenStgRhs 'Vanilla) -> UniqSM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> Bool -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho Bool
top_level GenStgRhs 'Vanilla
rhs
unariseBinding UnariseEnv
rho Bool
top_level (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
xrhss)
  = [(Id, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([(Id, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla)
-> UniqSM [(Id, GenStgRhs 'Vanilla)]
-> UniqSM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, GenStgRhs 'Vanilla) -> UniqSM (Id, GenStgRhs 'Vanilla))
-> [(Id, GenStgRhs 'Vanilla)] -> UniqSM [(Id, GenStgRhs 'Vanilla)]
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 (\(Id
x, GenStgRhs 'Vanilla
rhs) -> (Id
x,) (GenStgRhs 'Vanilla -> (Id, GenStgRhs 'Vanilla))
-> UniqSM (GenStgRhs 'Vanilla) -> UniqSM (Id, GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> Bool -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho Bool
top_level GenStgRhs 'Vanilla
rhs) [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
xrhss

unariseRhs :: UnariseEnv -> Bool -> StgRhs -> UniqSM StgRhs
unariseRhs :: UnariseEnv
-> Bool -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho Bool
top_level (StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
update_flag [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
expr Type
typ)
  = do (rho', args1) <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders UnariseEnv
rho [Id]
[BinderP 'Vanilla]
args
       expr' <- unariseExpr rho' expr
       -- Unarisation can lead to a StgRhsClosure becoming a StgRhsCon.
       -- Hence, we call `mk(Top)StgRhsCon_maybe` rather than just building
       -- another `StgRhsClosure`.
       --
       -- For example with unboxed sums (#25166):
       --
       --     foo = \u [] case (# | _ | #) [(##)] of tag { __DEFAULT -> D [True tag] }
       --
       --  ====> {unarisation}
       --
       --     foo = D [True 2#]
       --
       -- Transforming an appropriate StgRhsClosure into a StgRhsCon is
       -- important as top-level StgRhsCon are statically allocated.
       --
       let mk_rhs = MkStgRhs
            { rhs_args :: [Id]
rhs_args = [Id]
args1
            , rhs_expr :: GenStgExpr 'Vanilla
rhs_expr = GenStgExpr 'Vanilla
expr'
            , rhs_type :: Type
rhs_type = Type
typ
            , rhs_is_join :: Bool
rhs_is_join = UpdateFlag
update_flag UpdateFlag -> UpdateFlag -> Bool
forall a. Eq a => a -> a -> Bool
== UpdateFlag
JumpedTo
            }
       if | top_level
          , Just rhs_con <- mkTopStgRhsCon_maybe (ue_allow_static_conapp rho) mk_rhs
          -> pure rhs_con

          | not top_level
          , Just rhs_con <- mkStgRhsCon_maybe mk_rhs
          -> pure rhs_con

          | otherwise
          -> pure (StgRhsClosure ext ccs update_flag args1 expr' typ)

unariseRhs UnariseEnv
rho Bool
_top (StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mu [StgTickish]
ts [StgArg]
args Type
typ)
  = Bool
-> (GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla))
-> GenStgRhs 'Vanilla
-> UniqSM (GenStgRhs 'Vanilla)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con))
    GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mu [StgTickish]
ts (UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs UnariseEnv
rho [StgArg]
args) Type
typ)

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

unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr

unariseExpr :: UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho e :: GenStgExpr 'Vanilla
e@(StgApp Id
f [])
  = case UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
f of
      Just (MultiVal [StgArg]
args)  -- Including empty tuples
        -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg] -> GenStgExpr 'Vanilla
mkTuple [StgArg]
args)
      Just (UnaryVal (StgVarArg Id
f'))
        -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f' [])
      Just (UnaryVal (StgLitArg Literal
f'))
        -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
f')
      Maybe UnariseVal
Nothing
        -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return GenStgExpr 'Vanilla
e

unariseExpr UnariseEnv
rho e :: GenStgExpr 'Vanilla
e@(StgApp Id
f [StgArg]
args)
  = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f' (UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs UnariseEnv
rho [StgArg]
args))
  where
    f' :: Id
f' = case UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
f of
           Just (UnaryVal (StgVarArg Id
f')) -> Id
f'
           Maybe UnariseVal
Nothing -> Id
f
           Maybe UnariseVal
err -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseExpr - app2" (StgPprOpts -> GenStgExpr 'Vanilla -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts GenStgExpr 'Vanilla
e SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Maybe UnariseVal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe UnariseVal
err)
               -- Can't happen because 'args' is non-empty, and
               -- a tuple or sum cannot be applied to anything

unariseExpr UnariseEnv
_ (StgLit Literal
l)
  = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)

unariseExpr UnariseEnv
rho (StgConApp DataCon
dc ConstructorNumber
n [StgArg]
args [[PrimRep]]
ty_args)
  | DataCon -> Bool
isUnboxedSumDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
  = do
      us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
      case unariseUbxSumOrTupleArgs rho us dc args ty_args of
        ([StgArg]
args', Just GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
cast_wrapper)
          -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
cast_wrapper ([StgArg] -> GenStgExpr 'Vanilla
mkTuple [StgArg]
args')
        ([StgArg]
args', Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
Nothing)
          -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ ([StgArg] -> GenStgExpr 'Vanilla
mkTuple [StgArg]
args')
  | Bool
otherwise =
      let args' :: [StgArg]
args' = UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs UnariseEnv
rho [StgArg]
args in
      GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ (DataCon
-> ConstructorNumber
-> [StgArg]
-> [[PrimRep]]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
n [StgArg]
args' [])

unariseExpr UnariseEnv
rho (StgOpApp StgOp
op [StgArg]
args Type
ty)
  = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgOp -> [StgArg] -> Type -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op (UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs UnariseEnv
rho [StgArg]
args) Type
ty)

unariseExpr UnariseEnv
rho (StgCase GenStgExpr 'Vanilla
scrut BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts)
  -- tuple/sum binders in the scrutinee can always be eliminated
  | StgApp Id
v [] <- GenStgExpr 'Vanilla
scrut
  , Just (MultiVal [StgArg]
xs) <- UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
v
  = UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
xs Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts

  -- Handle strict lets for tuples and sums:
  --   case (# a,b #) of r -> rhs
  -- and analogously for sums
  | StgConApp DataCon
dc ConstructorNumber
_n [StgArg]
args [[PrimRep]]
ty_args <- GenStgExpr 'Vanilla
scrut
  , DataCon -> Bool
isUnboxedSumDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
  = do
    us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
    case unariseUbxSumOrTupleArgs rho us dc args ty_args of
      ([StgArg]
args',Just GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper) -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
args' Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
      ([StgArg]
args',Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
Nothing) -> UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
args' Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts

  -- See (3) of Note [Rubbish literals] in GHC.Types.Literal
  | StgLit Literal
lit <- GenStgExpr 'Vanilla
scrut
  , Just [StgArg]
args' <- Literal -> Maybe [StgArg]
unariseLiteral_maybe Literal
lit
  = UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
args' Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts

  -- general case
  | Bool
otherwise
  = do scrut' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
scrut
       alts'  <- unariseAlts rho alt_ty bndr alts
       return (StgCase scrut' bndr alt_ty alts')
                       -- bndr may have a unboxed sum/tuple type but it will be
                       -- dead after unarise (checked in GHC.Stg.Lint)

unariseExpr UnariseEnv
rho (StgLet XLet 'Vanilla
ext GenStgBinding 'Vanilla
bind GenStgExpr 'Vanilla
e)
  = XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
ext (GenStgBinding 'Vanilla
 -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgBinding 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> Bool
-> GenStgBinding 'Vanilla
-> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho Bool
False GenStgBinding 'Vanilla
bind UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e

unariseExpr UnariseEnv
rho (StgLetNoEscape XLetNoEscape 'Vanilla
ext GenStgBinding 'Vanilla
bind GenStgExpr 'Vanilla
e)
  = XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
ext (GenStgBinding 'Vanilla
 -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgBinding 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> Bool
-> GenStgBinding 'Vanilla
-> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho Bool
False GenStgBinding 'Vanilla
bind UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e

unariseExpr UnariseEnv
rho (StgTick StgTickish
tick GenStgExpr 'Vanilla
e)
  = StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e

-- Doesn't return void args.
unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [[PrimRep]]
                   -> ( [OutStgArg]           -- Arguments representing the unboxed sum
                      , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them
                                                    -- into the right Rep
unariseUbxSumOrTupleArgs :: UnariseEnv
-> UniqSupply
-> DataCon
-> [StgArg]
-> [[PrimRep]]
-> ([StgArg], Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla))
unariseUbxSumOrTupleArgs UnariseEnv
rho UniqSupply
us DataCon
dc [StgArg]
args [[PrimRep]]
ty_args
  | DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
  = (UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs UnariseEnv
rho [StgArg]
args, Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall a. Maybe a
Nothing)

  | DataCon -> Bool
isUnboxedSumDataCon DataCon
dc
  , let args1 :: [StgArg]
args1 = Bool -> [StgArg] -> [StgArg]
forall a. HasCallStack => Bool -> a -> a
assert ([StgArg] -> Bool
forall a. [a] -> Bool
isSingleton [StgArg]
args) (UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs UnariseEnv
rho [StgArg]
args)
  = let ([StgArg]
args2, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
cast_wrapper) = HasDebugCallStack =>
DataCon
-> [[PrimRep]]
-> [StgArg]
-> UniqSupply
-> ([StgArg], GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
DataCon
-> [[PrimRep]]
-> [StgArg]
-> UniqSupply
-> ([StgArg], GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
mkUbxSum DataCon
dc [[PrimRep]]
ty_args [StgArg]
args1 UniqSupply
us
    in ([StgArg]
args2, (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall a. a -> Maybe a
Just GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
cast_wrapper)

  | Bool
otherwise
  = String
-> ([StgArg], Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla))
forall a. HasCallStack => String -> a
panic String
"unariseUbxSumOrTupleArgs: Constructor not a unboxed sum or tuple"

-- Returns @Nothing@ if the given literal is already unary (exactly
-- one PrimRep).  Doesn't return void args.
--
-- This needs to exist because rubbish literals can have any representation.
-- See also Note [Rubbish literals] in GHC.Types.Literal.
unariseLiteral_maybe :: Literal -> Maybe [OutStgArg]
unariseLiteral_maybe :: Literal -> Maybe [StgArg]
unariseLiteral_maybe (LitRubbish TypeOrConstraint
torc Type
rep)
  | [PrimRep
_] <- [PrimRep]
preps
  = Maybe [StgArg]
forall a. Maybe a
Nothing   -- Single PrimRep. Nothing to do!

  | Bool
otherwise -- Multiple reps, or zero. Eliminate via elimCase
  = [StgArg] -> Maybe [StgArg]
forall a. a -> Maybe a
Just [ Literal -> StgArg
StgLitArg (TypeOrConstraint -> Type -> Literal
LitRubbish TypeOrConstraint
torc (PrimRep -> Type
primRepToRuntimeRep PrimRep
prep))
         | PrimRep
prep <- [PrimRep]
preps ]
  where
    preps :: [PrimRep]
preps = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unariseLiteral_maybe") Type
rep

unariseLiteral_maybe Literal
_ = Maybe [StgArg]
forall a. Maybe a
Nothing

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

elimCase :: UnariseEnv
         -> [OutStgArg] -- non-void args
         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr

elimCase :: UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
args Id
bndr (MultiValAlt Int
_) [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con   = AltCon
_
                                                 , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP 'Vanilla]
bndrs
                                                 , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = GenStgExpr 'Vanilla
rhs}]
  = do let rho1 :: UnariseEnv
rho1 = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
bndr ([StgArg] -> UnariseVal
MultiVal [StgArg]
args)
       (rho2, rhs') <- case () of
           ()
_
             | Id -> Bool
isUnboxedTupleBndr Id
bndr
             -> (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> [StgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [Id]
[BinderP 'Vanilla]
bndrs [StgArg]
args UnariseEnv
rho1, GenStgExpr 'Vanilla
rhs)
             | Bool
otherwise
             -> Bool
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isUnboxedSumBndr Id
bndr) (UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
 -> UniqSM (UnariseEnv, GenStgExpr 'Vanilla))
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$
               case [BinderP 'Vanilla]
bndrs of
                -- Sum with a void-type binder?
                [] -> (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv
rho1, GenStgExpr 'Vanilla
rhs)
                [BinderP 'Vanilla
alt_bndr] -> Id
-> [StgArg]
-> GenStgExpr 'Vanilla
-> UnariseEnv
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
mapSumIdBinders Id
BinderP 'Vanilla
alt_bndr [StgArg]
args GenStgExpr 'Vanilla
rhs UnariseEnv
rho1
                [BinderP 'Vanilla]
_ -> String -> SDoc -> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mapSumIdBinders" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
[BinderP 'Vanilla]
bndrs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args)

       unariseExpr rho2 rhs'

elimCase UnariseEnv
rho args :: [StgArg]
args@(StgArg
tag_arg : [StgArg]
real_args) Id
bndr (MultiValAlt Int
_) [GenStgAlt 'Vanilla]
alts
  | Id -> Bool
isUnboxedSumBndr Id
bndr
  = do tag_bndr <- FastString -> Type -> UniqSM Id
mkId (String -> FastString
mkFastString String
"tag") Type
tagTy
          -- this won't be used but we need a binder anyway
       let rho1 = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
bndr ([StgArg] -> UnariseVal
MultiVal [StgArg]
args)
           scrut' = case StgArg
tag_arg of
                      StgVarArg Id
v     -> Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
v []
                      StgLitArg Literal
l     -> Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l

       alts' <- unariseSumAlts rho1 real_args alts
       return (StgCase scrut' tag_bndr tagAltTy alts')

elimCase UnariseEnv
_ [StgArg]
args Id
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
  = String -> SDoc -> UniqSM (GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"elimCase - unhandled case"
      ([StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> AltType -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltType
alt_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [GenStgAlt 'Vanilla] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt 'Vanilla]
alts)

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

unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
unariseAlts :: UnariseEnv
-> AltType
-> Id
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseAlts UnariseEnv
rho (MultiValAlt Int
n) Id
bndr [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con   = AltCon
DEFAULT
                                               , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = []
                                               , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = GenStgExpr 'Vanilla
e}]
  | Id -> Bool
isUnboxedTupleBndr Id
bndr
  = do (rho', ys) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder UnariseEnv
rho Id
bndr
       !e' <- unariseExpr rho' e
       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys e']

unariseAlts UnariseEnv
rho (MultiValAlt Int
n) Id
bndr [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con   = DataAlt DataCon
_
                                               , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP 'Vanilla]
ys
                                               , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = GenStgExpr 'Vanilla
e}]
  | Id -> Bool
isUnboxedTupleBndr Id
bndr
  = do (rho', ys1) <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders UnariseEnv
rho [Id]
[BinderP 'Vanilla]
ys
       massert (ys1 `lengthIs` n)
       let rho'' = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho' Id
bndr ([StgArg] -> UnariseVal
MultiVal ((Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
ys1))
       !e' <- unariseExpr rho'' e
       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys1 e']

unariseAlts UnariseEnv
_ (MultiValAlt Int
_) Id
bndr [GenStgAlt 'Vanilla]
alts
  | Id -> Bool
isUnboxedTupleBndr Id
bndr
  = String -> SDoc -> UniqSM [GenStgAlt 'Vanilla]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseExpr: strange multi val alts" ([GenStgAlt 'Vanilla] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt 'Vanilla]
alts)

-- In this case we don't need to scrutinize the tag bit
unariseAlts UnariseEnv
rho (MultiValAlt Int
_) Id
bndr [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con    = AltCon
DEFAULT
                                               , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = []
                                               , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = GenStgExpr 'Vanilla
rhs}]
  | Id -> Bool
isUnboxedSumBndr Id
bndr
  = do (rho_sum_bndrs, sum_bndrs) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder UnariseEnv
rho Id
bndr
       rhs' <- unariseExpr rho_sum_bndrs rhs
       return [GenStgAlt (DataAlt (tupleDataCon Unboxed (length sum_bndrs))) sum_bndrs rhs']

unariseAlts UnariseEnv
rho (MultiValAlt Int
_) Id
bndr [GenStgAlt 'Vanilla]
alts
  | Id -> Bool
isUnboxedSumBndr Id
bndr
  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder UnariseEnv
rho Id
bndr
       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
       let inner_case = GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [GenStgAlt 'Vanilla]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
tag_bndr []) Id
BinderP 'Vanilla
tag_bndr AltType
tagAltTy [GenStgAlt 'Vanilla]
alts'
       return [GenStgAlt{ alt_con   = DataAlt (tupleDataCon Unboxed (length scrt_bndrs))
                        , alt_bndrs = scrt_bndrs
                        , alt_rhs   = inner_case
                        }]

unariseAlts UnariseEnv
rho AltType
_ Id
_ [GenStgAlt 'Vanilla]
alts
  = (GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla))
-> [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
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 (\GenStgAlt 'Vanilla
alt -> UnariseEnv -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseAlt UnariseEnv
rho GenStgAlt 'Vanilla
alt) [GenStgAlt 'Vanilla]
alts

unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
unariseAlt :: UnariseEnv -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseAlt UnariseEnv
rho alt :: GenStgAlt 'Vanilla
alt@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
_,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
xs,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'Vanilla
e}
  = do (rho', xs') <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders UnariseEnv
rho [Id]
[BinderP 'Vanilla]
xs
       !e' <- unariseExpr rho' e
       return $! alt {alt_bndrs = xs', alt_rhs = e'}

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

-- | Make alternatives that match on the tag of a sum
-- (i.e. generate LitAlts for the tag)
unariseSumAlts :: UnariseEnv
               -> [StgArg] -- sum components _excluding_ the tag bit.
               -> [StgAlt] -- original alternative with sum LHS
               -> UniqSM [StgAlt]
unariseSumAlts :: UnariseEnv
-> [StgArg] -> [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
env [StgArg]
args [GenStgAlt 'Vanilla]
alts
  = do alts' <- (GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla))
-> [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
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 (UnariseEnv
-> [StgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
env [StgArg]
args) [GenStgAlt 'Vanilla]
alts
       return (mkDefaultLitAlt alts')

unariseSumAlt :: UnariseEnv
              -> [StgArg] -- sum components _excluding_ the tag bit.
              -> StgAlt   -- original alternative with sum LHS
              -> UniqSM StgAlt
unariseSumAlt :: UnariseEnv
-> [StgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
rho [StgArg]
_ GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
DEFAULT,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
_,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'Vanilla
e}
  = AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt AltCon
DEFAULT [Id]
[BinderP 'Vanilla]
forall a. Monoid a => a
mempty (GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgAlt 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e

unariseSumAlt UnariseEnv
rho [StgArg]
args alt :: GenStgAlt 'Vanilla
alt@GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con   = DataAlt DataCon
sumCon
                                , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP 'Vanilla]
bs
                                , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = GenStgExpr 'Vanilla
e
                                }

  = do (rho',e') <- case [BinderP 'Vanilla]
bs of
              [BinderP 'Vanilla
b] -> Id
-> [StgArg]
-> GenStgExpr 'Vanilla
-> UnariseEnv
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
mapSumIdBinders Id
BinderP 'Vanilla
b [StgArg]
args GenStgExpr 'Vanilla
e UnariseEnv
rho
              -- Sums must have one binder
              [BinderP 'Vanilla]
_ -> String -> SDoc -> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseSumAlt2" ([StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenStgAlt 'Vanilla -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt GenStgAlt 'Vanilla
alt)
       let lit_case   = Literal -> AltCon
LitAlt (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DataCon -> Int
dataConTag DataCon
sumCon)))
       GenStgAlt lit_case mempty <$> unariseExpr rho' e'

unariseSumAlt UnariseEnv
_ [StgArg]
scrt GenStgAlt 'Vanilla
alt
  = String -> SDoc -> UniqSM (GenStgAlt 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseSumAlt3" ([StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
scrt SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenStgAlt 'Vanilla -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt GenStgAlt 'Vanilla
alt)

--------------------------------------------------------------------------------
-- Mapping binders when matching und a unboxed sum/tuple

mapTupleIdBinders
  :: [InId]       -- Un-processed binders of a tuple alternative.
                  -- Can have void binders.
  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).
                  -- Can't have void args.
  -> UnariseEnv
  -> UnariseEnv
mapTupleIdBinders :: [Id] -> [StgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [Id]
ids [StgArg]
args0 UnariseEnv
rho0
  = Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ((StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([PrimRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([PrimRep] -> Bool) -> (StgArg -> [PrimRep]) -> StgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> [PrimRep]
stgArgRep) [StgArg]
args0)) (UnariseEnv -> UnariseEnv) -> UnariseEnv -> UnariseEnv
forall a b. (a -> b) -> a -> b
$
    let
      map_ids :: UnariseEnv -> [Id] -> [StgArg] -> UnariseEnv
      map_ids :: UnariseEnv -> [Id] -> [StgArg] -> UnariseEnv
map_ids UnariseEnv
rho [] [StgArg]
_  = UnariseEnv
rho
      map_ids UnariseEnv
rho (Id
x : [Id]
xs) [StgArg]
args =
        let
          x_reps :: [PrimRep]
x_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
x)
          x_arity :: Int
x_arity = [PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
x_reps
          ([StgArg]
x_args, [StgArg]
args') =
            Bool
-> (Int -> [StgArg] -> ([StgArg], [StgArg]))
-> Int
-> [StgArg]
-> ([StgArg], [StgArg])
forall a. HasCallStack => Bool -> a -> a
assert ([StgArg]
args [StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
x_arity)
            Int -> [StgArg] -> ([StgArg], [StgArg])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
x_arity [StgArg]
args

          rho' :: UnariseEnv
rho'
            | Int
x_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
            = Bool
-> (UnariseEnv -> Id -> UnariseVal -> UnariseEnv)
-> UnariseEnv
-> Id
-> UnariseVal
-> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert ([StgArg]
x_args [StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
1)
              UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x (StgArg -> UnariseVal
UnaryVal ([StgArg] -> StgArg
forall a. HasCallStack => [a] -> a
head [StgArg]
x_args))
            | Bool
otherwise
            = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([StgArg] -> UnariseVal
MultiVal [StgArg]
x_args)
        in
          UnariseEnv -> [Id] -> [StgArg] -> UnariseEnv
map_ids UnariseEnv
rho' [Id]
xs [StgArg]
args'
    in
      UnariseEnv -> [Id] -> [StgArg] -> UnariseEnv
map_ids UnariseEnv
rho0 [Id]
ids [StgArg]
args0

mapSumIdBinders
  :: InId        -- Binder (in the case alternative).
  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
                 -- Can't have void args.
  -> InStgExpr
  -> UnariseEnv
  -> UniqSM (UnariseEnv, OutStgExpr)

mapSumIdBinders :: Id
-> [StgArg]
-> GenStgExpr 'Vanilla
-> UnariseEnv
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
mapSumIdBinders Id
alt_bndr [StgArg]
args GenStgExpr 'Vanilla
rhs UnariseEnv
rho0
  = Bool
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ((StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([PrimRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([PrimRep] -> Bool) -> (StgArg -> [PrimRep]) -> StgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> [PrimRep]
stgArgRep) [StgArg]
args)) (UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
 -> UniqSM (UnariseEnv, GenStgExpr 'Vanilla))
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ do
    uss <- UniqSupply -> [UniqSupply]
listSplitUniqSupply (UniqSupply -> [UniqSupply])
-> UniqSM UniqSupply -> UniqSM [UniqSupply]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
    let
      fld_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
alt_bndr)

      -- Slots representing the whole sum
      arg_slots = (PrimRep -> SlotTy) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> SlotTy
primRepSlot ([PrimRep] -> [SlotTy]) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> a -> b
$ (StgArg -> [PrimRep]) -> [StgArg] -> [PrimRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap StgArg -> [PrimRep]
stgArgRep [StgArg]
args
      -- The slots representing the field of the sum we bind.
      id_slots  = (PrimRep -> SlotTy) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> SlotTy
primRepSlot ([PrimRep] -> [SlotTy]) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> a -> b
$ [PrimRep]
fld_reps
      layout1   = [SlotTy] -> [SlotTy] -> [Int]
HasDebugCallStack => [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
arg_slots [SlotTy]
id_slots

      -- See Note [Casting slot arguments]
      -- Most of the code here is just to make sure our binders are of the
      -- right type.
      -- Select only the args which contain parts of the current field.
      id_arg_exprs   = [ [StgArg]
args [StgArg] -> Int -> StgArg
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | Int
i <- [Int]
layout1 ]
      id_vars   = [Id
v | StgVarArg Id
v <- [StgArg]
id_arg_exprs]

      typed_id_arg_input = Bool -> [(Id, PrimRep, UniqSupply)] -> [(Id, PrimRep, UniqSupply)]
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> [PrimRep] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Id]
id_vars [PrimRep]
fld_reps) ([(Id, PrimRep, UniqSupply)] -> [(Id, PrimRep, UniqSupply)])
-> [(Id, PrimRep, UniqSupply)] -> [(Id, PrimRep, UniqSupply)]
forall a b. (a -> b) -> a -> b
$
                           [Id] -> [PrimRep] -> [UniqSupply] -> [(Id, PrimRep, UniqSupply)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Id]
id_vars [PrimRep]
fld_reps [UniqSupply]
uss

      mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id)
      mkCastInput (Id
id,PrimRep
rep,UniqSupply
bndr_us) =
        let ([PrimOp]
ops,[Type]
types) = [(PrimOp, Type)] -> ([PrimOp], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(PrimOp, Type)] -> ([PrimOp], [Type]))
-> [(PrimOp, Type)] -> ([PrimOp], [Type])
forall a b. (a -> b) -> a -> b
$ PrimRep -> PrimRep -> [(PrimOp, Type)]
getCasts (HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRepU (Type -> PrimRep) -> Type -> PrimRep
forall a b. (a -> b) -> a -> b
$ Id -> Type
idType Id
id) PrimRep
rep
            cst_opts :: [(PrimOp, Type, Unique)]
cst_opts = [PrimOp] -> [Type] -> [Unique] -> [(PrimOp, Type, Unique)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [PrimOp]
ops [Type]
types ([Unique] -> [(PrimOp, Type, Unique)])
-> [Unique] -> [(PrimOp, Type, Unique)]
forall a b. (a -> b) -> a -> b
$ UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
bndr_us
            out_id :: Id
out_id = case [(PrimOp, Type, Unique)]
cst_opts of
              [] -> Id
id
              [(PrimOp, Type, Unique)]
_ ->  let (PrimOp
_,Type
ty,Unique
uq) = [(PrimOp, Type, Unique)] -> (PrimOp, Type, Unique)
forall a. HasCallStack => [a] -> a
last [(PrimOp, Type, Unique)]
cst_opts
                    in Unique -> Type -> Id
mkCastVar Unique
uq Type
ty
        in ([(PrimOp, Type, Unique)]
cst_opts,Id
id,Id
out_id)

      cast_inputs = ((Id, PrimRep, UniqSupply) -> ([(PrimOp, Type, Unique)], Id, Id))
-> [(Id, PrimRep, UniqSupply)]
-> [([(PrimOp, Type, Unique)], Id, Id)]
forall a b. (a -> b) -> [a] -> [b]
map (Id, PrimRep, UniqSupply) -> ([(PrimOp, Type, Unique)], Id, Id)
mkCastInput [(Id, PrimRep, UniqSupply)]
typed_id_arg_input
      (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\GenStgExpr 'Vanilla
x->GenStgExpr 'Vanilla
x) cast_inputs
        where
          cast_arg GenStgExpr 'Vanilla -> c
rhs_in ([(PrimOp, Type, Unique)]
cast_ops,Id
in_id,b
out_id) =
            let rhs_out :: GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
rhs_out = [(PrimOp, Type, Unique)]
-> StgArg -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
castArgRename [(PrimOp, Type, Unique)]
cast_ops (Id -> StgArg
StgVarArg Id
in_id)
            in (GenStgExpr 'Vanilla -> c
rhs_in (GenStgExpr 'Vanilla -> c)
-> (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> GenStgExpr 'Vanilla
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
rhs_out, b
out_id)

      typed_id_args = (Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
typed_ids

      -- pprTrace "mapSumIdBinders"
      --           (text "fld_reps" <+> ppr fld_reps $$
      --           text "id_args" <+> ppr id_arg_exprs $$
      --           text "rhs" <+> ppr rhs $$
      --           text "rhs_with_casts" <+> ppr rhs_with_casts
      --           ) $
    if isMultiValBndr alt_bndr
      then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs)
      else assert (typed_id_args `lengthIs` 1) $
            return (extendRho rho0 alt_bndr (UnaryVal (head typed_id_args)), rhs_with_casts rhs)

-- Convert the argument to the given type, and wrap the conversion
-- around the given expression. Use the given Id as a name for the
-- converted value.
castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr
castArgRename :: [(PrimOp, Type, Unique)]
-> StgArg -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
castArgRename [(PrimOp, Type, Unique)]
ops StgArg
in_arg GenStgExpr 'Vanilla
rhs =
  case [(PrimOp, Type, Unique)]
ops of
    [] -> GenStgExpr 'Vanilla
rhs
    ((PrimOp
op,Type
ty,Unique
uq):[(PrimOp, Type, Unique)]
rest_ops) ->
      let out_id' :: Id
out_id' = Unique -> Type -> Id
mkCastVar Unique
uq Type
ty -- out_name `setIdUnique` uq `setIdType` ty
          sub_cast :: GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
sub_cast = [(PrimOp, Type, Unique)]
-> StgArg -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
castArgRename [(PrimOp, Type, Unique)]
rest_ops (Id -> StgArg
StgVarArg Id
out_id')
      in StgArg
-> PrimOp
-> Id
-> Type
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
mkCast StgArg
in_arg PrimOp
op Id
out_id' Type
ty (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall a b. (a -> b) -> a -> b
$ GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
sub_cast GenStgExpr 'Vanilla
rhs

-- Construct a case binder used when casting sums, of a given type and unique.
mkCastVar :: Unique -> Type -> Id
mkCastVar :: Unique -> Type -> Id
mkCastVar Unique
uq Type
ty = FastString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> FastString
fsLit String
"cst_sum") Unique
uq Type
ManyTy Type
ty

mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr
mkCast :: StgArg
-> PrimOp
-> Id
-> Type
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
mkCast StgArg
arg_in PrimOp
cast_op Id
out_id Type
out_ty GenStgExpr 'Vanilla
in_rhs =
  let r2 :: PrimRep
r2 = HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRepU Type
out_ty
      scrut :: GenStgExpr 'Vanilla
scrut = StgOp -> [StgArg] -> Type -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimOp -> StgOp
StgPrimOp PrimOp
cast_op) [StgArg
arg_in] Type
out_ty
      alt :: GenStgAlt 'Vanilla
alt = GenStgAlt { alt_con :: AltCon
alt_con = AltCon
DEFAULT, alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs = [], alt_rhs :: GenStgExpr 'Vanilla
alt_rhs = GenStgExpr 'Vanilla
in_rhs}
      alt_ty :: AltType
alt_ty = PrimRep -> AltType
PrimAlt PrimRep
r2
  in (GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [GenStgAlt 'Vanilla]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'Vanilla
scrut Id
BinderP 'Vanilla
out_id AltType
alt_ty [GenStgAlt 'Vanilla
alt])

-- | Build a unboxed sum term from arguments of an alternative.
--
-- Example, for (# x | #) :: (# (# #) | Int #) we call
--
--   mkUbxSum (# _ | #) [ [], [LiftedRep] ] [ voidPrimId ]
--
-- which returns
--
--   [ 1#, rubbish ]
--
mkUbxSum
  :: HasDebugCallStack
  => DataCon      -- Sum data con
  -> [[PrimRep]]  -- Representations of type arguments of the sum data con
  -> [OutStgArg]  -- Actual arguments of the alternative.
  -> UniqSupply
  -> ([OutStgArg] -- Final tuple arguments
     ,(StgExpr->StgExpr) -- We might need to cast the args first
     )
mkUbxSum :: HasDebugCallStack =>
DataCon
-> [[PrimRep]]
-> [StgArg]
-> UniqSupply
-> ([StgArg], GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
mkUbxSum DataCon
dc [[PrimRep]]
ty_args [StgArg]
args0 UniqSupply
us
  = let
      SlotTy
_ :| [SlotTy]
sum_slots = [[PrimRep]] -> NonEmpty SlotTy
ubxSumRepType [[PrimRep]]
ty_args
      -- drop tag slot
      field_slots :: [SlotTy]
field_slots = ((StgArg -> Maybe SlotTy) -> [StgArg] -> [SlotTy]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([PrimRep] -> Maybe SlotTy
repSlotTy ([PrimRep] -> Maybe SlotTy)
-> (StgArg -> [PrimRep]) -> StgArg -> Maybe SlotTy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> [PrimRep]
stgArgRep) [StgArg]
args0)
      tag :: Int
tag = DataCon -> Int
dataConTag DataCon
dc
      layout' :: [Int]
layout'  = [SlotTy] -> [SlotTy] -> [Int]
HasDebugCallStack => [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
sum_slots [SlotTy]
field_slots

      tag_arg :: StgArg
tag_arg  = Literal -> StgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag))
      arg_idxs :: IntMap StgArg
arg_idxs = [(Int, StgArg)] -> IntMap StgArg
forall a. [(Int, a)] -> IntMap a
IM.fromList (String -> [Int] -> [StgArg] -> [(Int, StgArg)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"mkUbxSum" [Int]
layout' [StgArg]
args0)

      ((Int
_idx,IntMap StgArg
_idx_map,UniqSupply
_us,GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper),[StgArg]
slot_args)
        = Bool
-> ((Int, IntMap StgArg, UniqSupply,
     GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
    [StgArg])
-> ((Int, IntMap StgArg, UniqSupply,
     GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
    [StgArg])
forall a. HasCallStack => Bool -> a -> a
assert (IntMap StgArg -> Int
forall a. IntMap a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length IntMap StgArg
arg_idxs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [SlotTy] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SlotTy]
sum_slots ) (((Int, IntMap StgArg, UniqSupply,
   GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
  [StgArg])
 -> ((Int, IntMap StgArg, UniqSupply,
      GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
     [StgArg]))
-> ((Int, IntMap StgArg, UniqSupply,
     GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
    [StgArg])
-> ((Int, IntMap StgArg, UniqSupply,
     GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
    [StgArg])
forall a b. (a -> b) -> a -> b
$
          ((Int, IntMap StgArg, UniqSupply,
  GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
 -> SlotTy
 -> ((Int, IntMap StgArg, UniqSupply,
      GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
     StgArg))
-> (Int, IntMap StgArg, UniqSupply,
    GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> [SlotTy]
-> ((Int, IntMap StgArg, UniqSupply,
     GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
    [StgArg])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Int, IntMap StgArg, UniqSupply,
 GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> SlotTy
-> ((Int, IntMap StgArg, UniqSupply,
     GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
    StgArg)
mkTupArg (Int
0,IntMap StgArg
arg_idxs,UniqSupply
us,GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall a. a -> a
id) [SlotTy]
sum_slots

      mkTupArg  :: (Int, IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr)
                -> SlotTy
                -> ((Int,IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr), StgArg)
      mkTupArg :: (Int, IntMap StgArg, UniqSupply,
 GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> SlotTy
-> ((Int, IntMap StgArg, UniqSupply,
     GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
    StgArg)
mkTupArg (Int
arg_idx, IntMap StgArg
arg_map, UniqSupply
us, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper) SlotTy
slot
         | Just StgArg
stg_arg <- Int -> IntMap StgArg -> Maybe StgArg
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
arg_idx IntMap StgArg
arg_map
         =  case UniqSupply
-> SlotTy
-> StgArg
-> Maybe
     (StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
castArg UniqSupply
us SlotTy
slot StgArg
stg_arg of
              -- Slot and arg type mismatched, do a cast
              Just (StgArg
casted_arg,UniqSupply
us',GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper') ->
                ( (Int
arg_idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, IntMap StgArg
arg_map, UniqSupply
us', GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper')
                , StgArg
casted_arg)
              -- Use the arg as-is
              Maybe
  (StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
Nothing ->
                ( (Int
arg_idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, IntMap StgArg
arg_map, UniqSupply
us, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper)
                , StgArg
stg_arg)
         -- Garbage slot, fill with rubbish
         | Bool
otherwise
         =  ( (Int
arg_idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, IntMap StgArg
arg_map, UniqSupply
us, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper)
            , SlotTy -> StgArg
ubxSumRubbishArg SlotTy
slot)

      castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr)
      castArg :: UniqSupply
-> SlotTy
-> StgArg
-> Maybe
     (StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
castArg UniqSupply
us SlotTy
slot_ty StgArg
arg
        -- Cast the argument to the type of the slot if required
        | SlotTy -> PrimRep
slotPrimRep SlotTy
slot_ty PrimRep -> PrimRep -> Bool
forall a. Eq a => a -> a -> Bool
/= StgArg -> PrimRep
stgArgRepU StgArg
arg
        , ([PrimOp]
ops,[Type]
types) <- [(PrimOp, Type)] -> ([PrimOp], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(PrimOp, Type)] -> ([PrimOp], [Type]))
-> [(PrimOp, Type)] -> ([PrimOp], [Type])
forall a b. (a -> b) -> a -> b
$ PrimRep -> PrimRep -> [(PrimOp, Type)]
getCasts (StgArg -> PrimRep
stgArgRepU StgArg
arg) (PrimRep -> [(PrimOp, Type)]) -> PrimRep -> [(PrimOp, Type)]
forall a b. (a -> b) -> a -> b
$ SlotTy -> PrimRep
slotPrimRep SlotTy
slot_ty
        , Bool -> Bool
not (Bool -> Bool) -> ([PrimOp] -> Bool) -> [PrimOp] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PrimOp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([PrimOp] -> Bool) -> [PrimOp] -> Bool
forall a b. (a -> b) -> a -> b
$ [PrimOp]
ops
        = let (UniqSupply
us1,UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us
              cast_uqs :: [Unique]
cast_uqs = UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us1
              cast_opts :: [(PrimOp, Type, Unique)]
cast_opts = [PrimOp] -> [Type] -> [Unique] -> [(PrimOp, Type, Unique)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [PrimOp]
ops [Type]
types [Unique]
cast_uqs
              (PrimOp
_op,Type
out_ty,Unique
out_uq) = [(PrimOp, Type, Unique)] -> (PrimOp, Type, Unique)
forall a. HasCallStack => [a] -> a
last [(PrimOp, Type, Unique)]
cast_opts
              casts :: GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
casts = [(PrimOp, Type, Unique)]
-> StgArg -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
castArgRename [(PrimOp, Type, Unique)]
cast_opts StgArg
arg :: StgExpr -> StgExpr
          in (StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> Maybe
     (StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall a. a -> Maybe a
Just (Id -> StgArg
StgVarArg (Unique -> Type -> Id
mkCastVar Unique
out_uq Type
out_ty),UniqSupply
us2,GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
casts)
        -- No need for casting
        | Bool
otherwise = Maybe
  (StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall a. Maybe a
Nothing

      tup_args :: [StgArg]
tup_args = StgArg
tag_arg StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
slot_args
    in
      -- pprTrace "mkUbxSum" (
      --   text "ty_args (slots)" <+> ppr ty_args $$
      --   text "args0" <+> ppr args0 $$
      --   text "wrapper" <+>
      --       (ppr $ wrapper $ StgLit $ LitChar '_'))
      ([StgArg]
tup_args, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper)


-- | Return a rubbish value for the given slot type.
--
-- We use the following rubbish values:
--    * Literals: 0 or 0.0
--    * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError`
--
-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make"
--
ubxSumRubbishArg :: SlotTy -> StgArg
ubxSumRubbishArg :: SlotTy -> StgArg
ubxSumRubbishArg SlotTy
PtrLiftedSlot   = Id -> StgArg
StgVarArg Id
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
PtrUnliftedSlot = Id -> StgArg
StgVarArg Id
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
WordSlot        = Literal -> StgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumWord Integer
0)
ubxSumRubbishArg SlotTy
Word64Slot      = Literal -> StgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumWord64 Integer
0)
ubxSumRubbishArg SlotTy
FloatSlot       = Literal -> StgArg
StgLitArg (Rational -> Literal
LitFloat Rational
0)
ubxSumRubbishArg SlotTy
DoubleSlot      = Literal -> StgArg
StgLitArg (Rational -> Literal
LitDouble Rational
0)
ubxSumRubbishArg (VecSlot Int
n PrimElemRep
e)   = Literal -> StgArg
StgLitArg (TypeOrConstraint -> Type -> Literal
LitRubbish TypeOrConstraint
TypeLike Type
vec_rep)
  where vec_rep :: Type
vec_rep = PrimRep -> Type
primRepToRuntimeRep (Int -> PrimElemRep -> PrimRep
VecRep Int
n PrimElemRep
e)

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

{-
Note [Unarisation of Void binders and arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For arguments (StgArg) and binders (Id) we have two kind of unarisation:

  - When unarising function arg binders and arguments, we don't want to remove
    void binders and arguments. For example,

      f :: (# (# #), (# #) #) -> Void# -> State# RealWorld -> ...
      f x y z = <body>

    Here after unarise we should still get a function with arity 3. Similarly
    in the call site we shouldn't remove void arguments:

      f (# (# #), (# #) #) void# realWorld#

    When unarising <body>, we extend the environment with these binders:

      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []

    Because their rep types are `MultiRep []` (aka. void). This means that when
    we see `x` in a function argument position, we actually replace it with a
    void argument. When we see it in a DataCon argument position, we just get
    rid of it, because DataCon applications in STG are always saturated.

  - When unarising case alternative binders we remove void binders, but we
    still update the environment the same way, because those binders may be
    used in the RHS. Example:

      case x of y {
        (# x1, x2, x3 #) -> <RHS>
      }

    We know that y can't be void, because we don't scrutinize voids, so x will
    be unarised to some number of arguments, and those arguments will have at
    least one non-void thing. So in the rho we will have something like:

      x :-> MultiVal [xu1, xu2]

    Now, after we eliminate void binders in the pattern, we get exactly the same
    number of binders, and extend rho again with these:

      x1 :-> UnaryVal xu1
      x2 :-> MultiVal [] -- x2 is void
      x3 :-> UnaryVal xu2

    Now when we see x2 in a function argument position or in return position, we
    generate void#. In constructor argument position, we just remove it.

So in short, when we have a void id,

  - We keep it if it's a lambda argument binder or
                       in argument position of an application.

  - We remove it if it's a DataCon field binder or
                         in argument position of a DataCon application.
-}

unariseArgBinder
    :: Bool -- data con arg?
    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder :: Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder Bool
is_con_arg UnariseEnv
rho Id
x =
  case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
x) of
    []
      | Bool
is_con_arg
      -> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([StgArg] -> UnariseVal
MultiVal []), [])
      | Bool
otherwise -- fun arg, do not remove void binders
      -> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([StgArg] -> UnariseVal
MultiVal []), [Id
voidArgId])

    [PrimRep
rep]
      -- Arg represented as single variable, but original type may still be an
      -- unboxed sum/tuple, e.g. (# Void# | Void# #).
      --
      -- While not unarising the binder in this case does not break any programs
      -- (because it unarises to a single variable), it triggers StgLint as we
      -- break the post-unarisation invariant that says unboxed tuple/sum
      -- binders should vanish. See Note [Post-unarisation invariants].
      | Type -> Bool
isUnboxedSumType (Id -> Type
idType Id
x) Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
x)
      -> do x' <- FastString -> Type -> UniqSM Id
mkId (String -> FastString
mkFastString String
"us") (PrimRep -> Type
primRepToType PrimRep
rep)
            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
      | Bool
otherwise
      -> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseEnv
extendRhoWithoutValue UnariseEnv
rho Id
x, [Id
x])

    [PrimRep]
reps -> do
      xs <- FastString -> [Type] -> UniqSM [Id]
mkIds (String -> FastString
mkFastString String
"us") ((PrimRep -> Type) -> [PrimRep] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> Type
primRepToType [PrimRep]
reps)
      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)

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

-- | MultiVal a function argument. Never returns an empty list.
unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
unariseFunArg UnariseEnv
rho (StgVarArg Id
x) =
  case UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
x of
    Just (MultiVal [])  -> [StgArg
voidArg]   -- NB: do not remove void args
    Just (MultiVal [StgArg]
as)  -> [StgArg]
as
    Just (UnaryVal StgArg
arg) -> [StgArg
arg]
    Maybe UnariseVal
Nothing             -> [Id -> StgArg
StgVarArg Id
x]
unariseFunArg UnariseEnv
_ arg :: StgArg
arg@(StgLitArg Literal
lit) = case Literal -> Maybe [StgArg]
unariseLiteral_maybe Literal
lit of
  -- forgetting to unariseLiteral_maybe here caused #23914
  Just [] -> [StgArg
voidArg]
  Just [StgArg]
as -> [StgArg]
as
  Maybe [StgArg]
Nothing -> [StgArg
arg]

unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs = (StgArg -> [StgArg]) -> [StgArg] -> [StgArg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((StgArg -> [StgArg]) -> [StgArg] -> [StgArg])
-> (UnariseEnv -> StgArg -> [StgArg])
-> UnariseEnv
-> [StgArg]
-> [StgArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnariseEnv -> StgArg -> [StgArg]
unariseFunArg

unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders UnariseEnv
rho [Id]
xs = ([[Id]] -> [Id]) -> (UnariseEnv, [[Id]]) -> (UnariseEnv, [Id])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((UnariseEnv, [[Id]]) -> (UnariseEnv, [Id]))
-> UniqSM (UnariseEnv, [[Id]]) -> UniqSM (UnariseEnv, [Id])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]))
-> UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [[Id]])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinder UnariseEnv
rho [Id]
xs

-- Result list of binders is never empty
unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinder = Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder Bool
False

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

-- | MultiVal a DataCon argument. Returns an empty list when argument is void.
unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
unariseConArg :: UnariseEnv -> StgArg -> [StgArg]
unariseConArg UnariseEnv
rho (StgVarArg Id
x) =
  case UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
x of
    Just (UnaryVal StgArg
arg) -> [StgArg
arg]
    Just (MultiVal [StgArg]
as) -> [StgArg]
as      -- 'as' can be empty
    Maybe UnariseVal
Nothing
      | HasDebugCallStack => Type -> Bool
Type -> Bool
isZeroBitTy (Id -> Type
idType Id
x) -> [] -- e.g. C realWorld#
                                     -- Here realWorld# is not in the envt, but
                                     -- is a void, and so should be eliminated
      | Bool
otherwise -> [Id -> StgArg
StgVarArg Id
x]
unariseConArg UnariseEnv
_ arg :: StgArg
arg@(StgLitArg Literal
lit)
  | Just [StgArg]
as <- Literal -> Maybe [StgArg]
unariseLiteral_maybe Literal
lit
  = [StgArg]
as
  | Bool
otherwise
  = Bool -> [StgArg] -> [StgArg]
forall a. HasCallStack => Bool -> a -> a
assert ([PrimRep] -> Bool
isNvUnaryRep (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Literal -> Type
literalType Literal
lit))) -- We have no non-rubbish non-unary literals
    [StgArg
arg]

unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
unariseConArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs = (StgArg -> [StgArg]) -> [StgArg] -> [StgArg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((StgArg -> [StgArg]) -> [StgArg] -> [StgArg])
-> (UnariseEnv -> StgArg -> [StgArg])
-> UnariseEnv
-> [StgArg]
-> [StgArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnariseEnv -> StgArg -> [StgArg]
unariseConArg

unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders UnariseEnv
rho [Id]
xs = ([[Id]] -> [Id]) -> (UnariseEnv, [[Id]]) -> (UnariseEnv, [Id])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((UnariseEnv, [[Id]]) -> (UnariseEnv, [Id]))
-> UniqSM (UnariseEnv, [[Id]]) -> UniqSM (UnariseEnv, [Id])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]))
-> UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [[Id]])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder UnariseEnv
rho [Id]
xs

-- Different from `unariseFunArgBinder`: result list of binders may be empty.
-- See DataCon applications case in Note [Post-unarisation invariants].
unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder = Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder Bool
True

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

mkIds :: FastString -> [NvUnaryType] -> UniqSM [Id]
mkIds :: FastString -> [Type] -> UniqSM [Id]
mkIds FastString
fs [Type]
tys = FastString -> [Type] -> UniqSM [Id]
forall (m :: * -> *).
MonadUnique m =>
FastString -> [Type] -> m [Id]
mkUnarisedIds FastString
fs [Type]
tys

mkId :: FastString -> NvUnaryType -> UniqSM Id
mkId :: FastString -> Type -> UniqSM Id
mkId FastString
s Type
t = FastString -> Type -> UniqSM Id
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Id
mkUnarisedId FastString
s Type
t

isMultiValBndr :: Id -> Bool
isMultiValBndr :: Id -> Bool
isMultiValBndr Id
id
  | [PrimRep
_] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
id)
  = Bool
False
  | Bool
otherwise
  = Bool
True

isUnboxedSumBndr :: Id -> Bool
isUnboxedSumBndr :: Id -> Bool
isUnboxedSumBndr = Type -> Bool
isUnboxedSumType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType

isUnboxedTupleBndr :: Id -> Bool
isUnboxedTupleBndr :: Id -> Bool
isUnboxedTupleBndr = Type -> Bool
isUnboxedTupleType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType

mkTuple :: [StgArg] -> StgExpr
mkTuple :: [StgArg] -> GenStgExpr 'Vanilla
mkTuple [StgArg]
args = DataCon
-> ConstructorNumber
-> [StgArg]
-> [[PrimRep]]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
StgConApp (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args)) ConstructorNumber
NoNumber [StgArg]
args []

tagAltTy :: AltType
tagAltTy :: AltType
tagAltTy = PrimRep -> AltType
PrimAlt PrimRep
IntRep

tagTy :: Type
tagTy :: Type
tagTy = Type
intPrimTy

voidArg :: StgArg
voidArg :: StgArg
voidArg = Id -> StgArg
StgVarArg Id
voidPrimId

mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
-- We have an exhaustive list of literal alternatives
--    1# -> e1
--    2# -> e2
-- Since they are exhaustive, we can replace one with DEFAULT, to avoid
-- generating a final test. Remember, the DEFAULT comes first if it exists.
mkDefaultLitAlt :: [GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
mkDefaultLitAlt [] = String -> SDoc -> [GenStgAlt 'Vanilla]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"elimUbxSumExpr.mkDefaultAlt" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Empty alts")
mkDefaultLitAlt alts :: [GenStgAlt 'Vanilla]
alts@(GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
DEFAULT,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
_,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'Vanilla
_} : [GenStgAlt 'Vanilla]
_)   = [GenStgAlt 'Vanilla]
alts
mkDefaultLitAlt (alt :: GenStgAlt 'Vanilla
alt@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=LitAlt{}, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[]} : [GenStgAlt 'Vanilla]
alts) = GenStgAlt 'Vanilla
alt {alt_con = DEFAULT} GenStgAlt 'Vanilla -> [GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
forall a. a -> [a] -> [a]
: [GenStgAlt 'Vanilla]
alts
mkDefaultLitAlt [GenStgAlt 'Vanilla]
alts = String -> SDoc -> [GenStgAlt 'Vanilla]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkDefaultLitAlt" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Not a lit alt:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenStgAlt 'Vanilla] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt 'Vanilla]
alts)

pprPanicAlts :: OutputablePass pass => [GenStgAlt pass] -> SDoc
pprPanicAlts :: forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt pass]
alts = [SDoc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((GenStgAlt pass -> SDoc) -> [GenStgAlt pass] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenStgAlt pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt [GenStgAlt pass]
alts)

pprPanicAlt :: OutputablePass pass => GenStgAlt pass -> SDoc
pprPanicAlt :: forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
c,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP pass]
b,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr pass
e} = (AltCon, [BinderP pass], SDoc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AltCon
c,[BinderP pass]
b,StgPprOpts -> GenStgExpr pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts GenStgExpr pass
e)