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

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

{-
(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 [Types 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 #) #)

So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
layout to use. Note that unlifted values can't be let-bound, so we don't need
types in StgRhsCon.

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:

  * No unboxed sums at all.

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

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

  * Similar to unboxed tuples, Note [Rubbish literals] of TupleRep may only
    appear in return position.

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

  * Binders always have zero (for void arguments) or one PrimRep.
-}

module GHC.Stg.Unarise (unarise) where

import GHC.Prelude

import GHC.Types.Basic
import GHC.Core
import GHC.Core.DataCon
import GHC.Core.TyCon ( isVoidRep )
import GHC.Data.FastString (FastString, mkFastString)
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.Utils.Panic.Plain
import GHC.Types.RepType
import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Core.Type
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.Types
import GHC.Types.Unique.Supply
import GHC.Utils.Misc
import GHC.Types.Var.Env

import Data.Bifunctor (second)
import Data.Maybe (mapMaybe)
import qualified Data.IntMap as IM

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

-- | 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)
--
type UnariseEnv = VarEnv UnariseVal

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 [OutStgArg]
args) = String -> SDoc
text String
"MultiVal" SDoc -> SDoc -> SDoc
<+> [OutStgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
args
  ppr (UnaryVal OutStgArg
arg)   = String -> SDoc
text String
"UnaryVal" SDoc -> SDoc -> SDoc
<+> OutStgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutStgArg
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 -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x (MultiVal [OutStgArg]
args)
  = Bool
-> (UnariseEnv -> InId -> UnariseVal -> UnariseEnv)
-> UnariseEnv
-> InId
-> UnariseVal
-> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert ((OutStgArg -> Bool) -> [OutStgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Bool
isNvUnaryType (Type -> Bool) -> (OutStgArg -> Type) -> OutStgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args)
    UnariseEnv -> InId -> UnariseVal -> UnariseEnv
forall a. VarEnv a -> InId -> a -> VarEnv a
extendVarEnv UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
args)
extendRho UnariseEnv
rho InId
x (UnaryVal OutStgArg
val)
  = Bool
-> (UnariseEnv -> InId -> UnariseVal -> UnariseEnv)
-> UnariseEnv
-> InId
-> UnariseVal
-> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
isNvUnaryType (OutStgArg -> Type
stgArgType OutStgArg
val))
    UnariseEnv -> InId -> UnariseVal -> UnariseEnv
forall a. VarEnv a -> InId -> a -> VarEnv a
extendVarEnv UnariseEnv
rho InId
x (OutStgArg -> UnariseVal
UnaryVal OutStgArg
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 -> InId -> UnariseEnv
extendRhoWithoutValue UnariseEnv
rho InId
x = UnariseEnv -> InId -> UnariseEnv
forall a. VarEnv a -> InId -> VarEnv a
delVarEnv UnariseEnv
rho InId
x


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

unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
unarise UniqSupply
us [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 UnariseEnv
forall a. VarEnv a
emptyVarEnv) [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
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho 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 -> StgBinding -> UniqSM StgBinding
unariseBinding :: UnariseEnv
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho (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 -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho GenStgRhs 'Vanilla
rhs
unariseBinding UnariseEnv
rho (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
xrhss)
  = [(InId, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([(InId, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla)
-> UniqSM [(InId, GenStgRhs 'Vanilla)]
-> UniqSM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((InId, GenStgRhs 'Vanilla) -> UniqSM (InId, GenStgRhs 'Vanilla))
-> [(InId, GenStgRhs 'Vanilla)]
-> UniqSM [(InId, 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 (\(InId
x, GenStgRhs 'Vanilla
rhs) -> (InId
x,) (GenStgRhs 'Vanilla -> (InId, GenStgRhs 'Vanilla))
-> UniqSM (GenStgRhs 'Vanilla) -> UniqSM (InId, GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho GenStgRhs 'Vanilla
rhs) [(InId, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
xrhss

unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
unariseRhs :: UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho (StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
update_flag [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
expr)
  = do (UnariseEnv
rho', [InId]
args1) <- UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseFunArgBinders UnariseEnv
rho [InId]
[BinderP 'Vanilla]
args
       GenStgExpr 'Vanilla
expr' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
expr
       GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
update_flag [InId]
[BinderP 'Vanilla]
args1 GenStgExpr 'Vanilla
expr')

unariseRhs UnariseEnv
rho (StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mu [StgTickish]
ts [OutStgArg]
args)
  = 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]
-> [OutStgArg]
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [OutStgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mu [StgTickish]
ts (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args))

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

unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr

unariseExpr :: UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho e :: GenStgExpr 'Vanilla
e@(StgApp InId
f [])
  = case UnariseEnv -> InId -> Maybe UnariseVal
forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
f of
      Just (MultiVal [OutStgArg]
args)  -- Including empty tuples
        -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OutStgArg] -> GenStgExpr 'Vanilla
mkTuple [OutStgArg]
args)
      Just (UnaryVal (StgVarArg InId
f'))
        -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (InId -> [OutStgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). InId -> [OutStgArg] -> GenStgExpr pass
StgApp InId
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 InId
f [OutStgArg]
args)
  = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (InId -> [OutStgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). InId -> [OutStgArg] -> GenStgExpr pass
StgApp InId
f' (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseFunArgs UnariseEnv
rho [OutStgArg]
args))
  where
    f' :: InId
f' = case UnariseEnv -> InId -> Maybe UnariseVal
forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
f of
           Just (UnaryVal (StgVarArg InId
f')) -> InId
f'
           Maybe UnariseVal
Nothing -> InId
f
           Maybe UnariseVal
err -> String -> SDoc -> InId
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
$$ 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 [OutStgArg]
args [Type]
ty_args)
  | Just [OutStgArg]
args' <- UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe UnariseEnv
rho DataCon
dc [OutStgArg]
args [Type]
ty_args
  = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OutStgArg] -> GenStgExpr 'Vanilla
mkTuple [OutStgArg]
args')

  | Bool
otherwise
  , let args' :: [OutStgArg]
args' = UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args
  = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon
-> ConstructorNumber
-> [OutStgArg]
-> [Type]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [OutStgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
n [OutStgArg]
args' ((OutStgArg -> Type) -> [OutStgArg] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map OutStgArg -> Type
stgArgType [OutStgArg]
args'))

unariseExpr UnariseEnv
rho (StgOpApp StgOp
op [OutStgArg]
args Type
ty)
  = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgOp -> [OutStgArg] -> Type -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgOp -> [OutStgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseFunArgs UnariseEnv
rho [OutStgArg]
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 InId
v [] <- GenStgExpr 'Vanilla
scrut
  , Just (MultiVal [OutStgArg]
xs) <- UnariseEnv -> InId -> Maybe UnariseVal
forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
v
  = UnariseEnv
-> [OutStgArg]
-> InId
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
xs InId
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 [OutStgArg]
args [Type]
ty_args <- GenStgExpr 'Vanilla
scrut
  , Just [OutStgArg]
args' <- UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe UnariseEnv
rho DataCon
dc [OutStgArg]
args [Type]
ty_args
  = UnariseEnv
-> [OutStgArg]
-> InId
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
args' InId
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 [OutStgArg]
args' <- Literal -> Maybe [OutStgArg]
unariseRubbish_maybe Literal
lit
  = UnariseEnv
-> [OutStgArg]
-> InId
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
args' InId
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts

  -- general case
  | Bool
otherwise
  = do GenStgExpr 'Vanilla
scrut' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
scrut
       [GenStgAlt 'Vanilla]
alts'  <- UnariseEnv
-> AltType
-> InId
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseAlts UnariseEnv
rho AltType
alt_ty InId
BinderP 'Vanilla
bndr [GenStgAlt 'Vanilla]
alts
       GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (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' BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
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
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho 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
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho 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.
unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe :: UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe UnariseEnv
rho DataCon
dc [OutStgArg]
args [Type]
ty_args
  | DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
  = [OutStgArg] -> Maybe [OutStgArg]
forall a. a -> Maybe a
Just (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args)

  | DataCon -> Bool
isUnboxedSumDataCon DataCon
dc
  , let args1 :: [OutStgArg]
args1 = Bool -> [OutStgArg] -> [OutStgArg]
forall a. HasCallStack => Bool -> a -> a
assert ([OutStgArg] -> Bool
forall a. [a] -> Bool
isSingleton [OutStgArg]
args) (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args)
  = [OutStgArg] -> Maybe [OutStgArg]
forall a. a -> Maybe a
Just (DataCon -> [Type] -> [OutStgArg] -> [OutStgArg]
mkUbxSum DataCon
dc [Type]
ty_args [OutStgArg]
args1)

  | Bool
otherwise
  = Maybe [OutStgArg]
forall a. Maybe a
Nothing

-- Doesn't return void args.
unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
unariseRubbish_maybe (LitRubbish Type
rep)
  | [PrimRep
prep] <- [PrimRep]
preps
  , Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prep)
  = Maybe [OutStgArg]
forall a. Maybe a
Nothing   -- Single, non-void PrimRep. Nothing to do!

  | Bool
otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase
  = [OutStgArg] -> Maybe [OutStgArg]
forall a. a -> Maybe a
Just [ Literal -> OutStgArg
StgLitArg (Type -> Literal
LitRubbish (PrimRep -> Type
primRepToType PrimRep
prep))
         | PrimRep
prep <- [PrimRep]
preps, Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prep) ]
  where
    preps :: [PrimRep]
preps = (() :: Constraint) => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
text String
"unariseRubbish_maybe") Type
rep

unariseRubbish_maybe Literal
_ = Maybe [OutStgArg]
forall a. Maybe a
Nothing

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

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

elimCase :: UnariseEnv
-> [OutStgArg]
-> InId
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
args InId
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 -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
bndr ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
args)
           rho2 :: UnariseEnv
rho2
             | InId -> Bool
isUnboxedTupleBndr InId
bndr
             = [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [InId]
[BinderP 'Vanilla]
bndrs [OutStgArg]
args UnariseEnv
rho1
             | Bool
otherwise
             = Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert (InId -> Bool
isUnboxedSumBndr InId
bndr) (UnariseEnv -> UnariseEnv) -> UnariseEnv -> UnariseEnv
forall a b. (a -> b) -> a -> b
$
               if [InId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InId]
[BinderP 'Vanilla]
bndrs then UnariseEnv
rho1
                             else [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [InId]
[BinderP 'Vanilla]
bndrs [OutStgArg]
args UnariseEnv
rho1

       UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho2 GenStgExpr 'Vanilla
rhs

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

       [GenStgAlt 'Vanilla]
alts' <- UnariseEnv
-> [OutStgArg]
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
rho1 [OutStgArg]
real_args [GenStgAlt 'Vanilla]
alts
       GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (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' InId
BinderP 'Vanilla
tag_bndr AltType
tagAltTy [GenStgAlt 'Vanilla]
alts')

elimCase UnariseEnv
_ [OutStgArg]
args InId
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
  = String -> SDoc -> UniqSM (GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"elimCase - unhandled case"
      ([OutStgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
args SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InId
bndr SDoc -> SDoc -> SDoc
<+> AltType -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltType
alt_ty SDoc -> SDoc -> SDoc
$$ [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
-> InId
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseAlts UnariseEnv
rho (MultiValAlt Int
n) InId
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}]
  | InId -> Bool
isUnboxedTupleBndr InId
bndr
  = do (UnariseEnv
rho', [InId]
ys) <- UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder UnariseEnv
rho InId
bndr
       !GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
e
       [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
n)) [InId]
[BinderP 'Vanilla]
ys GenStgExpr 'Vanilla
e']

unariseAlts UnariseEnv
rho (MultiValAlt Int
n) InId
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}]
  | InId -> Bool
isUnboxedTupleBndr InId
bndr
  = do (UnariseEnv
rho', [InId]
ys1) <- UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseConArgBinders UnariseEnv
rho [InId]
[BinderP 'Vanilla]
ys
       Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([InId]
ys1 [InId] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n)
       let rho'' :: UnariseEnv
rho'' = UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho' InId
bndr ([OutStgArg] -> UnariseVal
MultiVal ((InId -> OutStgArg) -> [InId] -> [OutStgArg]
forall a b. (a -> b) -> [a] -> [b]
map InId -> OutStgArg
StgVarArg [InId]
ys1))
       !GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho'' GenStgExpr 'Vanilla
e
       [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
n)) [InId]
[BinderP 'Vanilla]
ys1 GenStgExpr 'Vanilla
e']

unariseAlts UnariseEnv
_ (MultiValAlt Int
_) InId
bndr [GenStgAlt 'Vanilla]
alts
  | InId -> Bool
isUnboxedTupleBndr InId
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
_) InId
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}]
  | InId -> Bool
isUnboxedSumBndr InId
bndr
  = do (UnariseEnv
rho_sum_bndrs, [InId]
sum_bndrs) <- UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder UnariseEnv
rho InId
bndr
       GenStgExpr 'Vanilla
rhs' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho_sum_bndrs GenStgExpr 'Vanilla
rhs
       [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([InId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InId]
sum_bndrs))) [InId]
[BinderP 'Vanilla]
sum_bndrs GenStgExpr 'Vanilla
rhs']

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

unariseAlts UnariseEnv
rho AltType
_ InId
_ [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 (UnariseEnv
rho', [InId]
xs') <- UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseConArgBinders UnariseEnv
rho [InId]
[BinderP 'Vanilla]
xs
       !GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
e
       GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla))
-> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
forall a b. (a -> b) -> a -> b
$! GenStgAlt 'Vanilla
alt {alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs = [InId]
[BinderP 'Vanilla]
xs', alt_rhs :: GenStgExpr 'Vanilla
alt_rhs = GenStgExpr 'Vanilla
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
-> [OutStgArg]
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
env [OutStgArg]
args [GenStgAlt 'Vanilla]
alts
  = do [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 (UnariseEnv
-> [OutStgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
env [OutStgArg]
args) [GenStgAlt 'Vanilla]
alts
       [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
mkDefaultLitAlt [GenStgAlt 'Vanilla]
alts')

unariseSumAlt :: UnariseEnv
              -> [StgArg] -- sum components _excluding_ the tag bit.
              -> StgAlt   -- original alternative with sum LHS
              -> UniqSM StgAlt
unariseSumAlt :: UnariseEnv
-> [OutStgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
rho [OutStgArg]
_ 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 [InId]
[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 [OutStgArg]
args 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 let rho' :: UnariseEnv
rho'     = [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [InId]
[BinderP 'Vanilla]
bs [OutStgArg]
args UnariseEnv
rho
           lit_case :: AltCon
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)))
       AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt AltCon
lit_case [InId]
[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
_ [OutStgArg]
scrt GenStgAlt 'Vanilla
alt
  = String -> SDoc -> UniqSM (GenStgAlt 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseSumAlt" ([OutStgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
scrt SDoc -> SDoc -> SDoc
$$ GenStgAlt 'Vanilla -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt GenStgAlt 'Vanilla
alt)

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

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 :: [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [InId]
ids [OutStgArg]
args0 UnariseEnv
rho0
  = Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ((OutStgArg -> Bool) -> [OutStgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Type -> Bool) -> (OutStgArg -> Type) -> OutStgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args0)) (UnariseEnv -> UnariseEnv) -> UnariseEnv -> UnariseEnv
forall a b. (a -> b) -> a -> b
$
    let
      ids_unarised :: [(Id, [PrimRep])]
      ids_unarised :: [(InId, [PrimRep])]
ids_unarised = (InId -> (InId, [PrimRep])) -> [InId] -> [(InId, [PrimRep])]
forall a b. (a -> b) -> [a] -> [b]
map (\InId
id -> (InId
id, (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (InId -> Type
idType InId
id))) [InId]
ids

      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
      map_ids :: UnariseEnv -> [(InId, [PrimRep])] -> [OutStgArg] -> UnariseEnv
map_ids UnariseEnv
rho [] [OutStgArg]
_  = UnariseEnv
rho
      map_ids UnariseEnv
rho ((InId
x, [PrimRep]
x_reps) : [(InId, [PrimRep])]
xs) [OutStgArg]
args =
        let
          x_arity :: Int
x_arity = [PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
x_reps
          ([OutStgArg]
x_args, [OutStgArg]
args') =
            Bool
-> (Int -> [OutStgArg] -> ([OutStgArg], [OutStgArg]))
-> Int
-> [OutStgArg]
-> ([OutStgArg], [OutStgArg])
forall a. HasCallStack => Bool -> a -> a
assert ([OutStgArg]
args [OutStgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
x_arity)
            Int -> [OutStgArg] -> ([OutStgArg], [OutStgArg])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
x_arity [OutStgArg]
args

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

mapSumIdBinders
  :: [InId]      -- Binder of a sum alternative (remember that sum patterns
                 -- only have one binder, so this list should be a singleton)
  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
                 -- Can't have void args.
  -> UnariseEnv
  -> UnariseEnv

mapSumIdBinders :: [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [InId
id] [OutStgArg]
args UnariseEnv
rho0
  = Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ((OutStgArg -> Bool) -> [OutStgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Type -> Bool) -> (OutStgArg -> Type) -> OutStgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args)) (UnariseEnv -> UnariseEnv) -> UnariseEnv -> UnariseEnv
forall a b. (a -> b) -> a -> b
$
    let
      arg_slots :: [SlotTy]
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
$ (OutStgArg -> [PrimRep]) -> [OutStgArg] -> [PrimRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Type -> [PrimRep])
-> (OutStgArg -> Type) -> OutStgArg -> [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args
      id_slots :: [SlotTy]
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
$ (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (InId -> Type
idType InId
id)
      layout1 :: [Int]
layout1   = [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
arg_slots [SlotTy]
id_slots
    in
      if InId -> Bool
isMultiValBndr InId
id
        then UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho0 InId
id ([OutStgArg] -> UnariseVal
MultiVal [ [OutStgArg]
args [OutStgArg] -> Int -> OutStgArg
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | Int
i <- [Int]
layout1 ])
        else Bool
-> (UnariseEnv -> InId -> UnariseVal -> UnariseEnv)
-> UnariseEnv
-> InId
-> UnariseVal
-> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert ([Int]
layout1 [Int] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
1)
             UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho0 InId
id (OutStgArg -> UnariseVal
UnaryVal ([OutStgArg]
args [OutStgArg] -> Int -> OutStgArg
forall a. HasCallStack => [a] -> Int -> a
!! [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
layout1))

mapSumIdBinders [InId]
ids [OutStgArg]
sum_args UnariseEnv
_
  = String -> SDoc -> UnariseEnv
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mapSumIdBinders" ([InId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InId]
ids SDoc -> SDoc -> SDoc
$$ [OutStgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
sum_args)

-- | Build a unboxed sum term from arguments of an alternative.
--
-- Example, for (# x | #) :: (# (# #) | Int #) we call
--
--   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
--
-- which returns
--
--   [ 1#, rubbish ]
--
mkUbxSum
  :: DataCon      -- Sum data con
  -> [Type]       -- Type arguments of the sum data con
  -> [OutStgArg]  -- Actual arguments of the alternative.
  -> [OutStgArg]  -- Final tuple arguments
mkUbxSum :: DataCon -> [Type] -> [OutStgArg] -> [OutStgArg]
mkUbxSum DataCon
dc [Type]
ty_args [OutStgArg]
args0
  = let
      (SlotTy
_ : [SlotTy]
sum_slots) = [[PrimRep]] -> [SlotTy]
ubxSumRepType ((Type -> [PrimRep]) -> [Type] -> [[PrimRep]]
forall a b. (a -> b) -> [a] -> [b]
map (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep [Type]
ty_args)
        -- drop tag slot

      tag :: Int
tag = DataCon -> Int
dataConTag DataCon
dc

      layout' :: [Int]
layout'  = [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
sum_slots ((OutStgArg -> Maybe SlotTy) -> [OutStgArg] -> [SlotTy]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Type -> Maybe SlotTy
typeSlotTy (Type -> Maybe SlotTy)
-> (OutStgArg -> Type) -> OutStgArg -> Maybe SlotTy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args0)
      tag_arg :: OutStgArg
tag_arg  = Literal -> OutStgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag))
      arg_idxs :: IntMap OutStgArg
arg_idxs = [(Int, OutStgArg)] -> IntMap OutStgArg
forall a. [(Int, a)] -> IntMap a
IM.fromList (String -> [Int] -> [OutStgArg] -> [(Int, OutStgArg)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"mkUbxSum" [Int]
layout' [OutStgArg]
args0)

      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
      mkTupArgs :: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs Int
_ [] IntMap OutStgArg
_
        = []
      mkTupArgs Int
arg_idx (SlotTy
slot : [SlotTy]
slots_left) IntMap OutStgArg
arg_map
        | Just OutStgArg
stg_arg <- Int -> IntMap OutStgArg -> Maybe OutStgArg
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
arg_idx IntMap OutStgArg
arg_map
        = OutStgArg
stg_arg OutStgArg -> [OutStgArg] -> [OutStgArg]
forall a. a -> [a] -> [a]
: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs (Int
arg_idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [SlotTy]
slots_left IntMap OutStgArg
arg_map
        | Bool
otherwise
        = SlotTy -> OutStgArg
ubxSumRubbishArg SlotTy
slot OutStgArg -> [OutStgArg] -> [OutStgArg]
forall a. a -> [a] -> [a]
: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs (Int
arg_idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [SlotTy]
slots_left IntMap OutStgArg
arg_map
    in
      OutStgArg
tag_arg OutStgArg -> [OutStgArg] -> [OutStgArg]
forall a. a -> [a] -> [a]
: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs Int
0 [SlotTy]
sum_slots IntMap OutStgArg
arg_idxs


-- | 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 -> OutStgArg
ubxSumRubbishArg SlotTy
PtrLiftedSlot    = InId -> OutStgArg
StgVarArg InId
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
PtrUnliftedSlot  = InId -> OutStgArg
StgVarArg InId
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
WordSlot   = Literal -> OutStgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumWord Integer
0)
ubxSumRubbishArg SlotTy
Word64Slot = Literal -> OutStgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumWord64 Integer
0)
ubxSumRubbishArg SlotTy
FloatSlot  = Literal -> OutStgArg
StgLitArg (Rational -> Literal
LitFloat Rational
0)
ubxSumRubbishArg SlotTy
DoubleSlot = Literal -> OutStgArg
StgLitArg (Rational -> Literal
LitDouble Rational
0)

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

{-
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# -> 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 (# (# #), (# #) #) voidId rw

    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 -> InId -> UniqSM (UnariseEnv, [InId])
unariseArgBinder Bool
is_con_arg UnariseEnv
rho InId
x =
  case (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (InId -> Type
idType InId
x) of
    []
      | Bool
is_con_arg
      -> (UnariseEnv, [InId]) -> UniqSM (UnariseEnv, [InId])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal []), [])
      | Bool
otherwise -- fun arg, do not remove void binders
      -> (UnariseEnv, [InId]) -> UniqSM (UnariseEnv, [InId])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal []), [InId
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 (InId -> Type
idType InId
x) Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedTupleType (InId -> Type
idType InId
x)
      -> do InId
x' <- FastString -> Type -> UniqSM InId
mkId (String -> FastString
mkFastString String
"us") (PrimRep -> Type
primRepToType PrimRep
rep)
            (UnariseEnv, [InId]) -> UniqSM (UnariseEnv, [InId])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal [InId -> OutStgArg
StgVarArg InId
x']), [InId
x'])
      | Bool
otherwise
      -> (UnariseEnv, [InId]) -> UniqSM (UnariseEnv, [InId])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseEnv
extendRhoWithoutValue UnariseEnv
rho InId
x, [InId
x])

    [PrimRep]
reps -> do
      [InId]
xs <- FastString -> [Type] -> UniqSM [InId]
mkIds (String -> FastString
mkFastString String
"us") ((PrimRep -> Type) -> [PrimRep] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> Type
primRepToType [PrimRep]
reps)
      (UnariseEnv, [InId]) -> UniqSM (UnariseEnv, [InId])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal ((InId -> OutStgArg) -> [InId] -> [OutStgArg]
forall a b. (a -> b) -> [a] -> [b]
map InId -> OutStgArg
StgVarArg [InId]
xs)), [InId]
xs)

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

-- | MultiVal a function argument. Never returns an empty list.
unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
unariseFunArg :: UnariseEnv -> OutStgArg -> [OutStgArg]
unariseFunArg UnariseEnv
rho (StgVarArg InId
x) =
  case UnariseEnv -> InId -> Maybe UnariseVal
forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
x of
    Just (MultiVal [])  -> [OutStgArg
voidArg]   -- NB: do not remove void args
    Just (MultiVal [OutStgArg]
as)  -> [OutStgArg]
as
    Just (UnaryVal OutStgArg
arg) -> [OutStgArg
arg]
    Maybe UnariseVal
Nothing             -> [InId -> OutStgArg
StgVarArg InId
x]
unariseFunArg UnariseEnv
_ OutStgArg
arg = [OutStgArg
arg]

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

unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders :: UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseFunArgBinders UnariseEnv
rho [InId]
xs = ([[InId]] -> [InId])
-> (UnariseEnv, [[InId]]) -> (UnariseEnv, [InId])
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 [[InId]] -> [InId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((UnariseEnv, [[InId]]) -> (UnariseEnv, [InId]))
-> UniqSM (UnariseEnv, [[InId]]) -> UniqSM (UnariseEnv, [InId])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId]))
-> UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [[InId]])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseFunArgBinder UnariseEnv
rho [InId]
xs

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

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

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

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

unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders :: UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseConArgBinders UnariseEnv
rho [InId]
xs = ([[InId]] -> [InId])
-> (UnariseEnv, [[InId]]) -> (UnariseEnv, [InId])
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 [[InId]] -> [InId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((UnariseEnv, [[InId]]) -> (UnariseEnv, [InId]))
-> UniqSM (UnariseEnv, [[InId]]) -> UniqSM (UnariseEnv, [InId])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId]))
-> UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [[InId]])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder UnariseEnv
rho [InId]
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 -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder = Bool -> UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseArgBinder Bool
True

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

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

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

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

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

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

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

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

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

voidArg :: StgArg
voidArg :: OutStgArg
voidArg = InId -> OutStgArg
StgVarArg InId
voidPrimId

mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
-- We have an exhauseive 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
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 :: AltCon
alt_con = AltCon
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
text String
"Not a lit alt:" SDoc -> SDoc -> SDoc
<+> [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)