Implement unboxed sum primitive type

Summary:
This patch implements primitive unboxed sum types, as described in
https://ghc.haskell.org/trac/ghc/wiki/UnpackedSumTypes.

Main changes are:

- Add new syntax for unboxed sums types, terms and patterns. Hidden
  behind `-XUnboxedSums`.

- Add unlifted unboxed sum type constructors and data constructors,
  extend type and pattern checkers and desugarer.

- Add new RuntimeRep for unboxed sums.

- Extend unarise pass to translate unboxed sums to unboxed tuples right
  before code generation.

- Add `StgRubbishArg` to `StgArg`, and a new type `CmmArg` for better
  code generation when sum values are involved.

- Add user manual section for unboxed sums.

Some other changes:

- Generalize `UbxTupleRep` to `MultiRep` and `UbxTupAlt` to
  `MultiValAlt` to be able to use those with both sums and tuples.

- Don't use `tyConPrimRep` in `isVoidTy`: `tyConPrimRep` is really
  wrong, given an `Any` `TyCon`, there's no way to tell what its kind
  is, but `kindPrimRep` and in turn `tyConPrimRep` returns `PtrRep`.

- Fix some bugs on the way: #12375.

Not included in this patch:

- Update Haddock for new the new unboxed sum syntax.

- `TemplateHaskell` support is left as future work.

For reviewers:

- Front-end code is mostly trivial and adapted from unboxed tuple code
  for type checking, pattern checking, renaming, desugaring etc.

- Main translation routines are in `RepType` and `UnariseStg`.
  Documentation in `UnariseStg` should be enough for understanding
  what's going on.

Credits:

- Johan Tibell wrote the initial front-end and interface file
  extensions.

- Simon Peyton Jones reviewed this patch many times, wrote some code,
  and helped with debugging.

Reviewers: bgamari, alanz, goldfire, RyanGlScott, simonpj, austin,
           simonmar, hvr, erikd

Reviewed By: simonpj

Subscribers: Iceland_jack, ggreif, ezyang, RyanGlScott, goldfire,
             thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2259

4 files changed, 1035 insertions, 189 deletions

diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs
new file mode 100644
index 0000000000..7e42a866b0
--- /dev/null
+++ b/compiler/simplStg/RepType.hs
@@ -0,0 +1,369 @@
+{-# LANGUAGE CPP #-}
+
+module RepType
+  ( -- * Code generator views onto Types
+    UnaryType, NvUnaryType, isNvUnaryType,
+    RepType(..), repType, repTypeArgs, isUnaryRep, isMultiRep,
+
+    -- * Predicates on types
+    isVoidTy, typePrimRep,
+
+    -- * Type representation for the code generator
+    countConRepArgs, idFunRepArity, tyConPrimRep,
+
+    -- * Unboxed sum representation type
+    ubxSumRepType, layout, typeSlotTy, SlotTy (..), slotTyToType,
+    slotPrimRep, repTypeSlots
+  ) where
+
+#include "HsVersions.h"
+
+import BasicTypes (Arity, RepArity)
+import DataCon
+import Id
+import Outputable
+import PrelNames
+import TyCon
+import TyCoRep
+import Type
+import TysPrim
+import TysWiredIn
+import Util
+
+import Data.List (foldl', sort)
+import Data.Maybe (maybeToList)
+import qualified Data.IntSet as IS
+
+{- **********************************************************************
+*                                                                       *
+                Representation types
+*                                                                       *
+********************************************************************** -}
+
+type NvUnaryType = Type
+type UnaryType   = Type
+     -- Both are always a value type; i.e. its kind is TYPE rr
+     -- for some rr; moreover the rr is never a variable.
+     --
+     --   NvUnaryType : never an unboxed tuple or sum, or void
+     --
+     --   UnaryType   : never an unboxed tuple or sum;
+     --                 can be Void# (but not (# #))
+
+isNvUnaryType :: Type -> Bool
+isNvUnaryType ty
+  = case repType ty of
+      UnaryRep _  -> True
+      MultiRep ss -> not (null ss)
+
+data RepType
+  = MultiRep [SlotTy]     -- Represented by multiple values (e.g. unboxed tuple or sum)
+  | UnaryRep NvUnaryType  -- Represented by a single value; but never Void#, or any
+                          -- other zero-width type (isVoidTy)
+
+instance Outputable RepType where
+  ppr (MultiRep slots) = text "MultiRep" <+> ppr slots
+  ppr (UnaryRep ty)    = text "UnaryRep" <+> ppr ty
+
+isMultiRep :: RepType -> Bool
+isMultiRep (MultiRep _) = True
+isMultiRep _            = False
+
+isUnaryRep :: RepType -> Bool
+isUnaryRep (UnaryRep _) = True
+isUnaryRep _            = False
+
+-- INVARIANT: the result list is never empty.
+repTypeArgs :: Type -> [UnaryType]
+repTypeArgs ty = case repType ty of
+                    MultiRep []    -> [voidPrimTy]
+                    MultiRep slots -> map slotTyToType slots
+                    UnaryRep ty    -> [ty]
+
+repTypeSlots :: RepType -> [SlotTy]
+repTypeSlots (MultiRep slots) = slots
+repTypeSlots (UnaryRep ty)    = maybeToList (typeSlotTy ty)
+
+-- | 'repType' figure out how a type will be represented at runtime. It looks
+-- through
+--
+--      1. For-alls
+--      2. Synonyms
+--      3. Predicates
+--      4. All newtypes, including recursive ones, but not newtype families
+--      5. Casts
+--
+repType :: Type -> RepType
+repType ty
+  = go initRecTc ty
+  where
+    go :: RecTcChecker -> Type -> RepType
+    go rec_nts ty                       -- Expand predicates and synonyms
+      | Just ty' <- coreView ty
+      = go rec_nts ty'
+
+    go rec_nts (ForAllTy _ ty2)         -- Drop type foralls
+      = go rec_nts ty2
+
+    go rec_nts ty@(TyConApp tc tys)     -- Expand newtypes
+      | isNewTyCon tc
+      , tys `lengthAtLeast` tyConArity tc
+      , Just rec_nts' <- checkRecTc rec_nts tc   -- See Note [Expanding newtypes] in TyCon
+      = go rec_nts' (newTyConInstRhs tc tys)
+
+      | isUnboxedTupleTyCon tc
+      = MultiRep (concatMap (repTypeSlots . go rec_nts) non_rr_tys)
+
+      | isUnboxedSumTyCon tc
+      = MultiRep (ubxSumRepType non_rr_tys)
+
+      | isVoidTy ty
+      = MultiRep []
+      where
+        -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+        non_rr_tys = dropRuntimeRepArgs tys
+
+    go rec_nts (CastTy ty _)
+      = go rec_nts ty
+
+    go _ ty@(CoercionTy _)
+      = pprPanic "repType" (ppr ty)
+
+    go _ ty = UnaryRep ty
+
+
+idFunRepArity :: Id -> RepArity
+idFunRepArity x = countFunRepArgs (idArity x) (idType x)
+
+countFunRepArgs :: Arity -> Type -> RepArity
+countFunRepArgs 0 _
+  = 0
+countFunRepArgs n ty
+  | UnaryRep (FunTy arg res) <- repType ty
+  = length (repTypeArgs arg) + countFunRepArgs (n - 1) res
+  | otherwise
+  = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, repType ty))
+
+countConRepArgs :: DataCon -> RepArity
+countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc)
+  where
+    go :: Arity -> Type -> RepArity
+    go 0 _
+      = 0
+    go n ty
+      | UnaryRep (FunTy arg res) <- repType ty
+      = length (repTypeSlots (repType arg)) + go (n - 1) res
+      | otherwise
+      = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, repType ty))
+
+-- | True if the type has zero width.
+isVoidTy :: Type -> Bool
+isVoidTy ty = typePrimRep ty == VoidRep
+
+
+{- **********************************************************************
+*                                                                       *
+                Unboxed sums
+ See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs
+*                                                                       *
+********************************************************************** -}
+
+type SortedSlotTys = [SlotTy]
+
+-- | Given the arguments of a sum type constructor application,
+--   return the unboxed sum rep type.
+--
+-- E.g.
+--
+--   (# Int | Maybe Int | (# Int, Bool #) #)
+--
+-- We call `ubxSumRepType [ Int, Maybe Int, (# Int,Bool #) ]`,
+-- which returns [Tag#, PtrSlot, PtrSlot]
+--
+-- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head
+-- of the list we have the slot for the tag.
+ubxSumRepType :: [Type] -> [SlotTy]
+ubxSumRepType constrs0 =
+  ASSERT2( length constrs0 > 1, ppr constrs0 ) -- otherwise it isn't a sum type
+  let
+    combine_alts :: [SortedSlotTys]  -- slots of constructors
+                 -> SortedSlotTys    -- final slots
+    combine_alts constrs = foldl' merge [] constrs
+
+    merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys
+    merge existing_slots []
+      = existing_slots
+    merge [] needed_slots
+      = needed_slots
+    merge (es : ess) (s : ss)
+      | Just s' <- s `fitsIn` es
+      = -- found a slot, use it
+        s' : merge ess ss
+
+      | otherwise
+      = -- keep searching for a slot
+        es : merge ess (s : ss)
+
+    -- Nesting unboxed tuples and sums is OK, so we need to flatten first.
+    rep :: Type -> SortedSlotTys
+    rep ty = sort (repTypeSlots (repType ty))
+
+    sumRep = WordSlot : combine_alts (map rep constrs0)
+             -- WordSlot: for the tag of the sum
+  in
+    sumRep
+
+layout :: SortedSlotTys -- Layout of sum. Does not include tag.
+                        -- We assume that they are in increasing order
+       -> [SlotTy]      -- Slot types of things we want to map to locations in the
+                        -- sum layout
+       -> [Int]         -- Where to map 'things' in the sum layout
+layout sum_slots0 arg_slots0 =
+    go arg_slots0 IS.empty
+  where
+    go :: [SlotTy] -> IS.IntSet -> [Int]
+    go [] _
+      = []
+    go (arg : args) used
+      = let slot_idx = findSlot arg 0 sum_slots0 used
+         in slot_idx : go args (IS.insert slot_idx used)
+
+    findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int
+    findSlot arg slot_idx (slot : slots) useds
+      | not (IS.member slot_idx useds)
+      , Just slot == arg `fitsIn` slot
+      = slot_idx
+      | otherwise
+      = findSlot arg (slot_idx + 1) slots useds
+    findSlot _ _ [] _
+      = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0)
+
+--------------------------------------------------------------------------------
+
+-- We have 3 kinds of slots:
+--
+--   - Pointer slot: Only shared between actual pointers to Haskell heap (i.e.
+--     boxed objects)
+--
+--   - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep.
+--
+--   - Float slots: Shared between floating point types.
+--
+--   - Void slots: Shared between void types. Not used in sums.
+data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
+  deriving (Eq, Ord)
+    -- Constructor order is important! If slot A could fit into slot B
+    -- then slot A must occur first.  E.g.  FloatSlot before DoubleSlot
+    --
+    -- We are assuming that WordSlot is smaller than or equal to Word64Slot
+    -- (would not be true on a 128-bit machine)
+
+instance Outputable SlotTy where
+  ppr PtrSlot    = text "PtrSlot"
+  ppr Word64Slot = text "Word64Slot"
+  ppr WordSlot   = text "WordSlot"
+  ppr DoubleSlot = text "DoubleSlot"
+  ppr FloatSlot  = text "FloatSlot"
+
+typeSlotTy :: UnaryType -> Maybe SlotTy
+typeSlotTy ty
+  | isVoidTy ty
+  = Nothing
+  | otherwise
+  = Just (primRepSlot (typePrimRep ty))
+
+primRepSlot :: PrimRep -> SlotTy
+primRepSlot VoidRep     = pprPanic "primRepSlot" (text "No slot for VoidRep")
+primRepSlot PtrRep      = PtrSlot
+primRepSlot IntRep      = WordSlot
+primRepSlot WordRep     = WordSlot
+primRepSlot Int64Rep    = Word64Slot
+primRepSlot Word64Rep   = Word64Slot
+primRepSlot AddrRep     = WordSlot
+primRepSlot FloatRep    = FloatSlot
+primRepSlot DoubleRep   = DoubleSlot
+primRepSlot VecRep{}    = pprPanic "primRepSlot" (text "No slot for VecRep")
+
+-- Used when unarising sum binders (need to give unarised Ids types)
+slotTyToType :: SlotTy -> Type
+slotTyToType PtrSlot    = anyTypeOfKind liftedTypeKind
+slotTyToType Word64Slot = int64PrimTy
+slotTyToType WordSlot   = intPrimTy
+slotTyToType DoubleSlot = doublePrimTy
+slotTyToType FloatSlot  = floatPrimTy
+
+slotPrimRep :: SlotTy -> PrimRep
+slotPrimRep PtrSlot     = PtrRep
+slotPrimRep Word64Slot  = Word64Rep
+slotPrimRep WordSlot    = WordRep
+slotPrimRep DoubleSlot  = DoubleRep
+slotPrimRep FloatSlot   = FloatRep
+
+-- | Returns the bigger type if one fits into the other. (commutative)
+fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
+fitsIn ty1 ty2
+  | isWordSlot ty1 && isWordSlot ty2
+  = Just (max ty1 ty2)
+  | isFloatSlot ty1 && isFloatSlot ty2
+  = Just (max ty1 ty2)
+  | isPtrSlot ty1 && isPtrSlot ty2
+  = Just PtrSlot
+  | otherwise
+  = Nothing
+  where
+    isPtrSlot PtrSlot = True
+    isPtrSlot _       = False
+
+    isWordSlot Word64Slot = True
+    isWordSlot WordSlot   = True
+    isWordSlot _          = False
+
+    isFloatSlot DoubleSlot = True
+    isFloatSlot FloatSlot  = True
+    isFloatSlot _          = False
+
+
+{- **********************************************************************
+*                                                                       *
+                   PrimRep
+*                                                                       *
+********************************************************************** -}
+
+-- | Discovers the primitive representation of a more abstract 'UnaryType'
+typePrimRep :: UnaryType -> PrimRep
+typePrimRep ty = kindPrimRep (text "kindRep ty" <+> ppr ty $$ ppr (typeKind ty))
+                             (typeKind ty)
+
+-- | Find the runtime representation of a 'TyCon'. Defined here to
+-- avoid module loops. Do not call this on unboxed tuples or sums,
+-- because they don't /have/ a runtime representation
+tyConPrimRep :: TyCon -> PrimRep
+tyConPrimRep tc
+  = ASSERT2( not (isUnboxedTupleTyCon tc), ppr tc )
+    ASSERT2( not (isUnboxedSumTyCon   tc), ppr tc )
+    kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind)
+                res_kind
+  where
+    res_kind = tyConResKind tc
+
+-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep'
+-- of values of types of this kind.
+kindPrimRep :: SDoc -> Kind -> PrimRep
+kindPrimRep doc ki
+  | Just ki' <- coreViewOneStarKind ki
+  = kindPrimRep doc ki'
+kindPrimRep _ (TyConApp typ [runtime_rep])
+  = ASSERT( typ `hasKey` tYPETyConKey )
+    go runtime_rep
+  where
+    go rr
+      | Just rr' <- coreView rr
+      = go rr'
+    go (TyConApp rr_dc args)
+      | RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
+      = fun args
+    go rr
+      = pprPanic "kindPrimRep.go" (ppr rr)
+kindPrimRep doc ki
+  = WARN( True, text "kindPrimRep defaulting to PtrRep on" <+> ppr ki $$ doc )
+    PtrRep  -- this can happen legitimately for, e.g., Any
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 3b636882fe..771df871cc 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -46,6 +46,9 @@ stg2stg dflags module_name binds
         ; (processed_binds, _, cost_centres)
                 <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
 
+        ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
+                        (pprStgBindings processed_binds)
+
         ; let un_binds = unarise us1 processed_binds
 
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index 2c72266ad6..38544822d2 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -149,7 +149,7 @@ statExpr :: StgExpr -> StatEnv
 
 statExpr (StgApp _ _)     = countOne Applications
 statExpr (StgLit _)       = countOne Literals
-statExpr (StgConApp _ _)  = countOne ConstructorApps
+statExpr (StgConApp _ _ _)= countOne ConstructorApps
 statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
 statExpr (StgTick _ e)    = statExpr e
 
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index 1b94cbcbc6..af2928d770 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -1,266 +1,740 @@
 {-
 (c) The GRASP/AQUA Project, Glasgow University, 1992-2012
 
-
 Note [Unarisation]
 ~~~~~~~~~~~~~~~~~~
-The idea of this pass is to translate away *all* unboxed-tuple binders.
-So for example:
+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 (x :: (# Int, Bool #)) = f x + f (# 1, True #)
- ==>
-f (x1 :: Int) (x2 :: Bool) = f x1 x2 + 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.
+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 binders natively.
+not support unboxed tuple and unboxed sum binders natively.
 
-In more detail:
+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 :-> [x1,x2]
+  * 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
+  * 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
+  * 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 #)
 
-    This applies to case scrutinees too
-       case x of (# a,b #) -> e   ==>   case (# x1,x2 #) of (# a,b #) -> e
-    I think we rely on the code generator to short-circuit this
-    case without generating any actual code.
+  * 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,
 
-Of course all this applies recursively, so that we flatten out nested tuples.
+  - We first get layouts of all alternatives.
+  - We sort these layouts based on their "slot types".
+  - We merge all the alternatives.
 
-Note [Unarisation and nullary tuples]
+For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)
+
+  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]
+  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]
+  - Merge all alternatives together: [ Ptr, 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 [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 can map to literals]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The above scheme has a special cases for nullary unboxed tuples, x :: (# #)
-To see why, consider
-    f2 :: (# Int, Int #) -> Int
-    f1 :: (# Int #) -> Int
-    f0 :: (# #) -> Int
+To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
+needs to map variables to literals too. Suppose we have this Core:
+
+  f (# x | #)
 
-When we "unarise" to eliminate unboxed tuples (this is done at the STG level),
-we'll transform to
-    f2 :: Int -> Int -> Int
-    f1 :: Int -> Int
-    f0 :: ??
+  ==> (CorePrep)
 
-We do not want to give f0 zero arguments, otherwise a lambda will
-turn into a thunk! So we want to get
-    f0 :: Void# -> Int
+  case (# x | #) of y {
+    _ -> f y
+  }
 
-So here is what we do for nullary tuples
+  ==> (MultiVal)
 
-  * Extend the UnariseEnv with   x :-> [voidPrimId]
+  case (# 1#, x #) of [x1, x2] {
+    _ -> f x1 x2
+  }
 
-  * Replace bindings with a binding for void:Void#
-       \x. e  =>  \void. e
-    and similarly case alternatives
+To eliminate this case expression we need to map x1 to 1# in UnariseEnv:
 
-  * If we find (# #) as an argument all by itself
-       f ...(# #)...
-    it looks like an Id, so we look up in UnariseEnv. We want to replace it
-    with voidPrimId, so the convenient thing is to initalise the UnariseEnv
-    with   (# #) :-> [voidPrimId]
+  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x
 
-See also Note [Nullary unboxed tuple] in Type.hs.
+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.
+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.
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TupleSections #-}
 
 module UnariseStg (unarise) where
 
 #include "HsVersions.h"
 
+import BasicTypes
 import CoreSyn
-import StgSyn
-import VarEnv
-import UniqSupply
+import DataCon
+import FastString (FastString, mkFastString)
 import Id
-import MkId ( voidPrimId, voidArgId )
+import Literal (Literal (..))
+import MkId (voidPrimId, voidArgId)
+import MonadUtils (mapAccumLM)
+import Outputable
+import RepType
+import StgSyn
 import Type
+import TysPrim (intPrimTyCon, intPrimTy)
 import TysWiredIn
-import DataCon
-import OccName
-import Name
+import UniqSupply
 import Util
-import Outputable
-import BasicTypes
+import VarEnv
 
+import Data.Bifunctor (second)
+import Data.Maybe (mapMaybe)
+import qualified Data.IntMap as IM
 
--- | A mapping from unboxed-tuple binders to the Ids they were expanded to.
+--------------------------------------------------------------------------------
+
+-- | A mapping from binders to the Ids they were expanded/renamed to.
+--
+--   x :-> MultiVal [a,b,c] in rho
+--
+-- iff  x's repType is a MultiRep, 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.
 --
--- INVARIANT: Ids in the range don't have unboxed tuple types.
+-- So
+--     x :-> MultiVal [a] in rho
+-- means x is represented by singleton tuple.
 --
--- Those in-scope variables without unboxed-tuple types are not present in
--- the domain of the mapping at all.
-type UnariseEnv = VarEnv [Id]
+--     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 (MultiVal args) = text "MultiVal" <+> ppr args
+  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg
+
+-- | Extend the environment, checking the UnariseEnv invariant.
+extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
+extendRho rho x (MultiVal args)
+  = ASSERT (all (isNvUnaryType . stgArgType) args)
+    extendVarEnv rho x (MultiVal args)
+extendRho rho x (UnaryVal val)
+  = ASSERT (isNvUnaryType (stgArgType val))
+    extendVarEnv rho x (UnaryVal val)
+
+--------------------------------------------------------------------------------
+
+type OutStgExpr = StgExpr
+type InId       = Id
+type OutId      = Id
+type InStgAlt   = StgAlt
+type InStgArg   = StgArg
+type OutStgArg  = StgArg
 
 unarise :: UniqSupply -> [StgBinding] -> [StgBinding]
-unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSupply us) binds
+unarise us binds = initUs_ us (mapM (unariseBinding emptyVarEnv) binds)
+
+unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
+unariseBinding rho (StgNonRec x rhs)
+  = StgNonRec x <$> unariseRhs rho rhs
+unariseBinding rho (StgRec xrhss)
+  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
+
+unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
+unariseRhs rho (StgRhsClosure ccs b_info fvs update_flag args expr)
+  = do (rho', args1) <- unariseFunArgBinders rho args
+       expr' <- unariseExpr rho' expr
+       let fvs' = unariseFreeVars rho fvs
+       return (StgRhsClosure ccs b_info fvs' update_flag args1 expr')
+
+unariseRhs rho (StgRhsCon ccs con args)
+  = ASSERT (not (isUnboxedTupleCon con || isUnboxedSumCon con))
+    return (StgRhsCon ccs con (unariseConArgs rho args))
+
+--------------------------------------------------------------------------------
+
+unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
+
+unariseExpr rho e@(StgApp f [])
+  = case lookupVarEnv rho f of
+      Just (MultiVal args)  -- Including empty tuples
+        -> return (mkTuple args)
+      Just (UnaryVal (StgVarArg f'))
+        -> return (StgApp f' [])
+      Just (UnaryVal (StgLitArg f'))
+        -> return (StgLit f')
+      Just (UnaryVal arg@(StgRubbishArg {}))
+        -> pprPanic "unariseExpr - app1" (ppr e $$ ppr arg)
+      Nothing
+        -> return e
+
+unariseExpr rho e@(StgApp f args)
+  = return (StgApp f' (unariseFunArgs rho args))
   where
-     -- See Note [Unarisation and nullary tuples]
-     nullary_tup = dataConWorkId unboxedUnitDataCon
-     init_env = unitVarEnv nullary_tup [voidPrimId]
-
-unariseBinding :: UniqSupply -> UnariseEnv -> StgBinding -> StgBinding
-unariseBinding us rho bind = case bind of
-  StgNonRec x rhs -> StgNonRec x (unariseRhs us rho rhs)
-  StgRec xrhss    -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs))
-                                      (listSplitUniqSupply us) xrhss
-
-unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs
-unariseRhs us rho rhs = case rhs of
-  StgRhsClosure ccs b_info fvs update_flag args expr
-    -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag
-                     args' (unariseExpr us' rho' expr)
-    where (us', rho', args') = unariseIdBinders us rho args
-  StgRhsCon ccs con args
-    -> StgRhsCon ccs con (unariseArgs rho args)
-
-------------------------
-unariseExpr :: UniqSupply -> UnariseEnv -> StgExpr -> StgExpr
-unariseExpr _ rho (StgApp f args)
-  | null args
-  , UbxTupleRep tys <- repType (idType f)
-  =  -- Particularly important where (##) is concerned
-     -- See Note [Nullary unboxed tuple]
-    StgConApp (tupleDataCon Unboxed (length tys))
-              (map StgVarArg (unariseId rho f))
+    f' = case lookupVarEnv rho f of
+           Just (UnaryVal (StgVarArg f')) -> f'
+           Nothing -> f
+           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)
+               -- Can't happen because 'args' is non-empty, and
+               -- a tuple or sum cannot be applied to anything
+
+unariseExpr _ (StgLit l)
+  = return (StgLit l)
+
+unariseExpr rho (StgConApp dc args ty_args)
+  | Just args' <- unariseMulti_maybe rho dc args ty_args
+  = return (mkTuple args')
 
   | otherwise
-  = StgApp f (unariseArgs rho args)
+  , let args' = unariseConArgs rho args
+  = return (StgConApp dc args' (map stgArgType args'))
 
-unariseExpr _ _ (StgLit l)
-  = StgLit l
+unariseExpr rho (StgOpApp op args ty)
+  = return (StgOpApp op (unariseFunArgs rho args) ty)
 
-unariseExpr _ rho (StgConApp dc args)
-  | isUnboxedTupleCon dc = StgConApp (tupleDataCon Unboxed (length args')) args'
-  | otherwise            = StgConApp dc args'
-  where
-    args' = unariseArgs rho args
+unariseExpr _ e@StgLam{}
+  = pprPanic "unariseExpr: found lambda" (ppr e)
 
-unariseExpr _ rho (StgOpApp op args ty)
-  = StgOpApp op (unariseArgs rho args) ty
+unariseExpr rho (StgCase scrut bndr alt_ty alts)
+  -- a tuple/sum binders in the scrutinee can always be eliminated
+  | StgApp v [] <- scrut
+  , Just (MultiVal xs) <- lookupVarEnv rho v
+  = elimCase rho xs bndr alt_ty alts
 
-unariseExpr us rho (StgLam xs e)
-  = StgLam xs' (unariseExpr us' rho' e)
-  where
-    (us', rho', xs') = unariseIdBinders us rho xs
+  -- Handle strict lets for tuples and sums:
+  --   case (# a,b #) of r -> rhs
+  -- and analogously for sums
+  | StgConApp dc args ty_args <- scrut
+  , Just args' <- unariseMulti_maybe rho dc args ty_args
+  = elimCase rho args' bndr alt_ty alts
 
-unariseExpr us rho (StgCase e bndr alt_ty alts)
-  = StgCase (unariseExpr us1 rho e) bndr alt_ty alts'
- where
-    (us1, us2) = splitUniqSupply us
-    alts'      = unariseAlts us2 rho alt_ty bndr alts
+  -- general case
+  | otherwise
+  = do scrut' <- unariseExpr rho scrut
+       alts'  <- unariseAlts rho alt_ty bndr alts
+       return (StgCase scrut' bndr alt_ty alts')
+                       -- bndr will be dead after unarise
 
-unariseExpr us rho (StgLet bind e)
-  = StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
-  where
-    (us1, us2) = splitUniqSupply us
+unariseExpr rho (StgLet bind e)
+  = StgLet <$> unariseBinding rho bind <*> unariseExpr rho e
 
-unariseExpr us rho (StgLetNoEscape bind e)
-  = StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
-  where
-    (us1, us2) = splitUniqSupply us
+unariseExpr rho (StgLetNoEscape bind e)
+  = StgLetNoEscape <$> unariseBinding rho bind <*> unariseExpr rho e
 
-unariseExpr us rho (StgTick tick e)
-  = StgTick tick (unariseExpr us rho e)
+unariseExpr rho (StgTick tick e)
+  = StgTick tick <$> unariseExpr rho e
 
-------------------------
-unariseAlts :: UniqSupply -> UnariseEnv -> AltType -> Id -> [StgAlt] -> [StgAlt]
-unariseAlts us rho (UbxTupAlt n) bndr [(DEFAULT, [], e)]
-  = [(DataAlt (tupleDataCon Unboxed n), ys, unariseExpr us2' rho' e)]
-  where
-    (us2', rho', ys) = unariseIdBinder us rho bndr
+-- Doesn't return void args.
+unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
+unariseMulti_maybe rho dc args ty_args
+  | isUnboxedTupleCon dc
+  = Just (unariseConArgs rho args)
 
-unariseAlts us rho (UbxTupAlt n) bndr [(DataAlt _, ys, e)]
-  = [(DataAlt (tupleDataCon Unboxed n), ys', unariseExpr us2' rho'' e)]
-  where
-    (us2', rho', ys') = unariseIdBinders us rho ys
-    rho'' = extendVarEnv rho' bndr ys'
+  | isUnboxedSumCon dc
+  , let args1 = ASSERT (isSingleton args) (unariseConArgs rho args)
+  = Just (mkUbxSum dc ty_args args1)
 
-unariseAlts _ _ (UbxTupAlt _) _ alts
-  = pprPanic "unariseExpr: strange unboxed tuple alts" (ppr alts)
+  | otherwise
+  = Nothing
+
+--------------------------------------------------------------------------------
+
+elimCase :: UnariseEnv
+         -> [OutStgArg] -- non-void args
+         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
+
+elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
+  = do let rho1 = extendRho rho bndr (MultiVal args)
+           rho2
+             | isUnboxedTupleBndr bndr
+             = mapTupleIdBinders bndrs args rho1
+             | otherwise
+             = ASSERT (isUnboxedSumBndr bndr)
+               if null bndrs then rho1
+                             else mapSumIdBinders bndrs args rho1
+
+       unariseExpr rho2 rhs
+
+elimCase rho args bndr (MultiValAlt _) alts
+  | isUnboxedSumBndr bndr
+  = do let (tag_arg : real_args) = args
+       tag_bndr <- mkId (mkFastString "tag") tagTy
+          -- this won't be used but we need a binder anyway
+       let rho1 = extendRho rho bndr (MultiVal args)
+           scrut' = case tag_arg of
+                      StgVarArg v     -> StgApp v []
+                      StgLitArg l     -> StgLit l
+                      StgRubbishArg _ -> pprPanic "unariseExpr" (ppr args)
+
+       alts' <- unariseSumAlts rho1 real_args alts
+       return (StgCase scrut' tag_bndr tagAltTy alts')
+
+elimCase _ args bndr alt_ty alts
+  = pprPanic "elimCase - unhandled case"
+      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)
+
+--------------------------------------------------------------------------------
+
+unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
+unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
+  | isUnboxedTupleBndr bndr
+  = do (rho', ys) <- unariseConArgBinder rho bndr
+       e' <- unariseExpr rho' e
+       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
+
+unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
+  | isUnboxedTupleBndr bndr
+  = do (rho', ys1) <- unariseConArgBinders rho ys
+       MASSERT(n == length ys1)
+       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
+       e' <- unariseExpr rho'' e
+       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
+
+unariseAlts _ (MultiValAlt _) bndr alts
+  | isUnboxedTupleBndr bndr
+  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)
+
+-- In this case we don't need to scrutinize the tag bit
+unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
+  | isUnboxedSumBndr bndr
+  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
+       rhs' <- unariseExpr rho_sum_bndrs rhs
+       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
+
+unariseAlts rho (MultiValAlt _) bndr alts
+  | isUnboxedSumBndr bndr
+  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
+       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
+       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
+       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
+                 scrt_bndrs,
+                 inner_case) ]
+
+unariseAlts rho _ _ alts
+  = mapM (\alt -> unariseAlt rho alt) alts
+
+unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
+unariseAlt rho (con, xs, e)
+  = do (rho', xs') <- unariseConArgBinders rho xs
+       (con, xs',) <$> unariseExpr rho' 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 env args alts
+  = do alts' <- mapM (unariseSumAlt env args) alts
+       return (mkDefaultLitAlt alts')
+
+unariseSumAlt :: UnariseEnv
+              -> [StgArg] -- sum components _excluding_ the tag bit.
+              -> StgAlt   -- original alternative with sum LHS
+              -> UniqSM StgAlt
+unariseSumAlt rho _ (DEFAULT, _, e)
+  = ( DEFAULT, [], ) <$> unariseExpr rho e
+
+unariseSumAlt rho args (DataAlt sumCon, bs, e)
+  = do let rho' = mapSumIdBinders bs args rho
+       e' <- unariseExpr rho' e
+       return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )
+
+unariseSumAlt _ scrt alt
+  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr 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 ids args0 rho0
+  = ASSERT (not (any (isVoidTy . stgArgType) args0))
+    let
+      ids_unarised :: [(Id, RepType)]
+      ids_unarised = map (\id -> (id, repType (idType id))) ids
+
+      map_ids :: UnariseEnv -> [(Id, RepType)] -> [StgArg] -> UnariseEnv
+      map_ids rho [] _  = rho
+      map_ids rho ((x, x_rep) : xs) args =
+        let
+          x_arity = length (repTypeSlots x_rep)
+          (x_args, args') =
+            ASSERT(args `lengthAtLeast` x_arity)
+            splitAt x_arity args
+
+          rho'
+            | isMultiRep x_rep
+            = extendRho rho x (MultiVal x_args)
+            | otherwise
+            = ASSERT (x_args `lengthIs` 1)
+              extendRho rho x (UnaryVal (head x_args))
+        in
+          map_ids rho' xs args'
+    in
+      map_ids rho0 ids_unarised 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 [id] args rho0
+  = ASSERT (not (any (isVoidTy . stgArgType) args))
+    let
+      arg_slots = concatMap (repTypeSlots . repType . stgArgType) args
+      id_slots  = repTypeSlots (repType (idType id))
+      layout1   = layout arg_slots id_slots
+    in
+      if isMultiValBndr id
+        then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
+        else ASSERT(layout1 `lengthIs` 1)
+             extendRho rho0 id (UnaryVal (args !! head layout1))
+
+mapSumIdBinders ids sum_args _
+  = pprPanic "mapSumIdBinders" (ppr ids $$ ppr 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 dc ty_args args0
+  = let
+      (_ : sum_slots) = ubxSumRepType ty_args
+        -- drop tag slot
+
+      tag = dataConTag dc
+
+      layout'  = layout sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
+      tag_arg  = StgLitArg (MachInt (fromIntegral tag))
+      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
+
+      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
+      mkTupArgs _ [] _
+        = []
+      mkTupArgs arg_idx (slot : slots_left) arg_map
+        | Just stg_arg <- IM.lookup arg_idx arg_map
+        = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
+        | otherwise
+        = StgRubbishArg (slotTyToType slot) : mkTupArgs (arg_idx + 1) slots_left arg_map
+    in
+      tag_arg : mkTupArgs 0 sum_slots arg_idxs
+
+--------------------------------------------------------------------------------
 
-unariseAlts us rho _ _ alts
-  = zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us) alts
+{-
+For arguments (StgArg) and binders (Id) we have two kind of unarisation:
 
---------------------------
-unariseAlt :: UniqSupply -> UnariseEnv -> StgAlt -> StgAlt
-unariseAlt us rho (con, xs, e)
-  = (con, xs', unariseExpr us' rho' e)
-  where
-    (us', rho', xs') = unariseIdBinders us rho xs
+  - When unarising function arg binders and arguments, we don't want to remove
+    void binders and arguments. For example,
 
-------------------------
-unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg]
-unariseArgs rho = concatMap (unariseArg rho)
+      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
+      f x y z = <body>
 
-unariseArg :: UnariseEnv -> StgArg -> [StgArg]
-unariseArg rho (StgVarArg x) = map StgVarArg (unariseId rho x)
-unariseArg _   (StgLitArg l) = [StgLitArg l]
+    Here after unarise we should still get a function with arity 3. Similarly
+    in the call site we shouldn't remove void arguments:
 
-unariseIds :: UnariseEnv -> [Id] -> [Id]
-unariseIds rho = concatMap (unariseId rho)
+      f (# (# #), (# #) #) voidId rw
 
-unariseId :: UnariseEnv -> Id -> [Id]
-unariseId rho x
-  | Just ys <- lookupVarEnv rho x
-  = ASSERT2( case repType (idType x) of UbxTupleRep _ -> True; _ -> False
-           , text "unariseId: not unboxed tuple" <+> ppr x )
-    ys
+    When unarising <body>, we extend the environment with these binders:
 
-  | otherwise
-  = ASSERT2( case repType (idType x) of UbxTupleRep _ -> False; _ -> True
-           , text "unariseId: was unboxed tuple" <+> ppr x )
-    [x]
-
-unariseIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> (UniqSupply, UnariseEnv, [Id])
-unariseIdBinders us rho xs = third3 concat $ mapAccumL2 unariseIdBinder us rho xs
-
-unariseIdBinder :: UniqSupply -> UnariseEnv
-                -> Id                -- Binder
-                -> (UniqSupply,
-                    UnariseEnv,      -- What to expand to at occurrence sites
-                    [Id])            -- What to expand to at binding site
-unariseIdBinder us rho x = case repType (idType x) of
-    UnaryRep {} -> (us, rho, [x])
-
-    UbxTupleRep tys
-      | null tys  -> -- See Note [Unarisation and nullary tuples]
-                     let ys = [voidPrimId]
-                         rho' = extendVarEnv rho x ys
-                     in (us, rho', [voidArgId])
-
-      | otherwise -> let (us0, us1) = splitUniqSupply us
-                         ys   = unboxedTupleBindersFrom us0 x tys
-                         rho' = extendVarEnv rho x ys
-                      in (us1, rho', ys)
-
-unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id]
-unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys
-  where fs = occNameFS (getOccName x)
+      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.
+-}
+
+--------------------------------------------------------------------------------
+
+-- | MultiVal a function argument. Never returns an empty list.
+unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
+unariseFunArg rho (StgVarArg x) =
+  case lookupVarEnv rho x of
+    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args
+    Just (MultiVal as)  -> as
+    Just (UnaryVal arg) -> [arg]
+    Nothing             -> [StgVarArg x]
+unariseFunArg _ arg = [arg]
+
+unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
+unariseFunArgs = concatMap . unariseFunArg
+
+unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
+
+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+-- Result list of binders is never empty
+unariseFunArgBinder rho x  =
+  case repType (idType x) of
+    UnaryRep _     -> return (rho, [x])
+    MultiRep []    -> return (extendRho rho x (MultiVal []), [voidArgId])
+                            -- NB: do not remove void binders
+    MultiRep slots -> do
+      xs <- mkIds (mkFastString "us") (map slotTyToType slots)
+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+
+--------------------------------------------------------------------------------
+
+-- | MultiVal a DataCon argument. Returns an empty list when argument is void.
+unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
+unariseConArg rho (StgVarArg x) =
+  case lookupVarEnv rho x of
+    Just (UnaryVal arg) -> [arg]
+    Just (MultiVal as) -> as       -- 'as' can be empty
+    Nothing
+      | isVoidTy (idType x) -> [] -- e.g. C realWorld#
+                                  -- Here realWorld# is not in the envt, but
+                                  -- is a void, and so should be eliminated
+      | otherwise -> [StgVarArg x]
+unariseConArg _ arg = [arg]       -- We have no void literals
+
+unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
+unariseConArgs = concatMap . unariseConArg
+
+unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
+unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
+
+unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseConArgBinder rho x =
+  case repType (idType x) of
+    UnaryRep _     -> return (rho, [x])
+    MultiRep slots -> do
+      xs <- mkIds (mkFastString "us") (map slotTyToType slots)
+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+
+unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
+unariseFreeVars rho fvs
+ = [ v | fv <- fvs, StgVarArg v <- unariseFreeVar rho fv ]
+   -- Notice that we filter out any StgLitArgs
+   -- e.g.   case e of (x :: (# Int | Bool #))
+   --           (# v | #) ->  ... let {g = \y. ..x...} in ...
+   --           (# | w #) -> ...
+   --     Here 'x' is free in g's closure, and the env will have
+   --       x :-> [1, v]
+   --     we want to capture 'v', but not 1, in the free vars
+
+unariseFreeVar :: UnariseEnv -> Id -> [StgArg]
+unariseFreeVar rho x =
+  case lookupVarEnv rho x of
+    Just (MultiVal args) -> args
+    Just (UnaryVal arg)  -> [arg]
+    Nothing              -> [StgVarArg x]
+
+--------------------------------------------------------------------------------
+
+mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
+mkIds fs tys = mapM (mkId fs) tys
+
+mkId :: FastString -> UnaryType -> UniqSM Id
+mkId = mkSysLocalOrCoVarM
+
+isMultiValBndr :: Id -> Bool
+isMultiValBndr = isMultiRep . repType . idType
+
+isUnboxedSumBndr :: Id -> Bool
+isUnboxedSumBndr = isUnboxedSumType . idType
+
+isUnboxedTupleBndr :: Id -> Bool
+isUnboxedTupleBndr = isUnboxedTupleType . idType
+
+mkTuple :: [StgArg] -> StgExpr
+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)
+
+tagAltTy :: AltType
+tagAltTy = PrimAlt intPrimTyCon
+
+tagTy :: Type
+tagTy = intPrimTy
+
+voidArg :: StgArg
+voidArg = StgVarArg 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 [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
+mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
+mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)