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

3 files changed, 84 insertions, 101 deletions

diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 8839ffa544..9c7d25a5ec 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -31,6 +31,7 @@ import Literal
 import PrimOp
 import CoreFVs
 import Type
+import RepType
 import Kind            ( isLiftedTypeKind )
 import DataCon
 import TyCon
@@ -303,8 +304,8 @@ collect (_, e) = go [] e
   where
     go xs e | Just e' <- bcView e = go xs e'
     go xs (AnnLam x (_,e))
-      | UbxTupleRep _ <- repType (idType x)
-      = unboxedTupleException
+      | repTypeArgs (idType x) `lengthExceeds` 1
+      = multiValException
       | otherwise
       = go (x:xs) e
     go xs not_lambda = (reverse xs, not_lambda)
@@ -532,8 +533,9 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
         -- no alts: scrut is guaranteed to diverge
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
-   | isUnboxedTupleCon dc
-   , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2)
+   | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
+   , [rep_ty1] <- repTypeArgs (idType bind1)
+   , [rep_ty2] <- repTypeArgs (idType bind2)
         -- Convert
         --      case .... of x { (# V'd-thing, a #) -> ... }
         -- to
@@ -543,43 +545,25 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
         -- Note that it does not matter losing the void-rep thing from the
         -- envt (it won't be bound now) because we never look such things up.
    , Just res <- case () of
-                   _ | VoidRep <- typePrimRep rep_ty1
-                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-                     | VoidRep <- typePrimRep rep_ty2
-                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
+                   _ | isVoidTy rep_ty1 && not (isVoidTy rep_ty2)
+                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
+                     | isVoidTy rep_ty2 && not (isVoidTy rep_ty1)
+                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
                      | otherwise
                      -> Nothing
    = res
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
-   | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1)
-        -- Similarly, convert
-        --      case .... of x { (# a #) -> ... }
-        -- to
-        --      case .... of a { DEFAULT -> ... }
-   = --trace "automagic mashing of case alts (# a #)"  $
-     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-
-schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)])
-   | Just (tc, tys) <- splitTyConApp_maybe (idType bndr)
-   , isUnboxedTupleTyCon tc
-   , Just res <- case tys of
-        [ty]       | UnaryRep _ <- repType ty
-                   , let bind = bndr `setIdType` ty
-                   -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-        [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1
-                   , UnaryRep rep_ty2 <- repType ty2
-                   -> case () of
-                       _ | VoidRep <- typePrimRep rep_ty1
-                         , let bind2 = bndr `setIdType` ty2
-                         -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-                         | VoidRep <- typePrimRep rep_ty2
-                         , let bind1 = bndr `setIdType` ty1
-                         -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-                         | otherwise
-                         -> Nothing
-        _ -> Nothing
-   = res
+   | isUnboxedTupleCon dc
+   , repTypeArgs (idType bndr) `lengthIs` 1 -- handles unit tuples
+   = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
+
+schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
+   | isUnboxedTupleType (idType bndr)
+   , [ty] <- repTypeArgs (idType bndr)
+       -- handles any pattern with a single non-void binder; in particular I/O
+       -- monad returns (# RealWorld#, a #)
+   = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
 
 schemeE d s p (AnnCase scrut bndr _ alts)
    = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
@@ -647,14 +631,14 @@ schemeT d s p app
 
 
    -- Case 2: Constructor application
-   | Just con <- maybe_saturated_dcon,
-     isUnboxedTupleCon con
+   | Just con <- maybe_saturated_dcon
+   , isUnboxedTupleCon con
    = case args_r_to_l of
         [arg1,arg2] | isVAtom arg1 ->
                   unboxedTupleReturn d s p arg2
         [arg1,arg2] | isVAtom arg2 ->
                   unboxedTupleReturn d s p arg1
-        _other -> unboxedTupleException
+        _other -> multiValException
 
    -- Case 3: Ordinary data constructor
    | Just con <- maybe_saturated_dcon
@@ -792,8 +776,8 @@ doCase  :: Word -> Sequel -> BCEnv
         -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
         -> BcM BCInstrList
 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-  | UbxTupleRep _ <- repType (idType bndr)
-  = unboxedTupleException
+  | repTypeArgs (idType bndr) `lengthExceeds` 1
+  = multiValException
   | otherwise
   = do
      dflags <- getDynFlags
@@ -848,8 +832,6 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            | null real_bndrs = do
                 rhs_code <- schemeE d_alts s p_alts rhs
                 return (my_discr alt, rhs_code)
-           | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs
-           = unboxedTupleException
            -- algebraic alt with some binders
            | otherwise =
              let
@@ -872,8 +854,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 
         my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
         my_discr (DataAlt dc, _, _)
-           | isUnboxedTupleCon dc
-           = unboxedTupleException
+           | isUnboxedTupleCon dc || isUnboxedSumCon dc
+           = multiValException
            | otherwise
            = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
         my_discr (LitAlt l, _, _)
@@ -971,7 +953,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
          pargs _ [] = return []
          pargs d (a:az)
-            = let UnaryRep arg_ty = repType (exprType (deAnnotate' a))
+            = let [arg_ty] = repTypeArgs (exprType (deAnnotate' a))
 
               in case tyConAppTyCon_maybe arg_ty of
                     -- Don't push the FO; instead push the Addr# it
@@ -1104,10 +1086,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- this is a V (tag).
          r_sizeW   = fromIntegral (primRepSizeW dflags r_rep)
          d_after_r = d_after_Addr + fromIntegral r_sizeW
-         r_lit     = mkDummyLiteral r_rep
          push_r    = (if   returns_void
                       then nilOL
-                      else unitOL (PUSH_UBX r_lit r_sizeW))
+                      else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW))
 
          -- generate the marshalling code we're going to call
 
@@ -1176,7 +1157,7 @@ mkDummyLiteral pr
         FloatRep  -> MachFloat 0
         Int64Rep  -> MachInt64 0
         Word64Rep -> MachWord64 0
-        _         -> panic "mkDummyLiteral"
+        _         -> pprPanic "mkDummyLiteral" (ppr pr)
 
 
 -- Convert (eg)
@@ -1195,27 +1176,26 @@ mkDummyLiteral pr
 
 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
 maybe_getCCallReturnRep fn_ty
-   = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
-         maybe_r_rep_to_go
-            = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
-         r_reps = case repType r_ty of
-                      UbxTupleRep reps -> map typePrimRep reps
-                      UnaryRep _       -> blargh
-         ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
-                || r_reps == [VoidRep] )
-              && case maybe_r_rep_to_go of
-                    Nothing    -> True
-                    Just r_rep -> r_rep /= PtrRep
-                                  -- if it was, it would be impossible
-                                  -- to create a valid return value
-                                  -- placeholder on the stack
-
-         blargh :: a -- Used at more than one type
-         blargh = pprPanic "maybe_getCCallReturn: can't handle:"
-                           (pprType fn_ty)
+   = let
+       (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
+       r_reps = repTypeArgs r_ty
+
+       blargh :: a -- Used at more than one type
+       blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+                         (pprType fn_ty)
      in
-     --trace (showSDoc (ppr (a_reps, r_reps))) $
-     if ok then maybe_r_rep_to_go else blargh
+       case r_reps of
+         [] -> panic "empty repTypeArgs"
+         [ty]
+           | typePrimRep ty == PtrRep
+            -> blargh
+           | isVoidTy ty
+            -> Nothing
+           | otherwise
+            -> Just (typePrimRep ty)
+                 -- if it was, it would be impossible to create a
+                 -- valid return value placeholder on the stack
+         _  -> blargh
 
 maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
 -- Detect and extract relevant info for the tagToEnum kludge.
@@ -1227,14 +1207,14 @@ maybe_is_tagToEnum_call app
   = Nothing
   where
     extract_constr_Names ty
-           | UnaryRep rep_ty <- repType ty
-           , Just tyc <- tyConAppTyCon_maybe rep_ty,
-             isDataTyCon tyc
-             = map (getName . dataConWorkId) (tyConDataCons tyc)
-             -- NOTE: use the worker name, not the source name of
-             -- the DataCon.  See DataCon.hs for details.
+           | [rep_ty] <- repTypeArgs ty
+           , Just tyc <- tyConAppTyCon_maybe rep_ty
+           , isDataTyCon tyc
+           = map (getName . dataConWorkId) (tyConDataCons tyc)
+           -- NOTE: use the worker name, not the source name of
+           -- the DataCon.  See DataCon.hs for details.
            | otherwise
-             = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
+           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
 
 {- -----------------------------------------------------------------------------
 Note [Implementing tagToEnum#]
@@ -1334,7 +1314,7 @@ pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
    = pushAtom d p a
 
 pushAtom d p (AnnVar v)
-   | UnaryRep rep_ty <- repType (idType v)
+   | [rep_ty] <- repTypeArgs (idType v)
    , V <- typeArgRep rep_ty
    = return (nilOL, 0)
 
@@ -1556,18 +1536,14 @@ isVoidArg V = True
 isVoidArg _ = False
 
 bcIdUnaryType :: Id -> UnaryType
-bcIdUnaryType x = case repType (idType x) of
-    UnaryRep rep_ty -> rep_ty
-    UbxTupleRep [rep_ty] -> rep_ty
-    UbxTupleRep [rep_ty1, rep_ty2]
-      | VoidRep <- typePrimRep rep_ty1 -> rep_ty2
-      | VoidRep <- typePrimRep rep_ty2 -> rep_ty1
+bcIdUnaryType x = case repTypeArgs (idType x) of
+    [rep_ty] -> rep_ty
     _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x))
 
 -- See bug #1257
-unboxedTupleException :: a
-unboxedTupleException = throwGhcException (ProgramError
-  ("Error: bytecode compiler can't handle unboxed tuples.\n"++
+multiValException :: a
+multiValException = throwGhcException (ProgramError
+  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
    "  Possibly due to foreign import/export decls in source.\n"++
    "  Workaround: use -fobject-code, or compile this module to .o separately."))
 
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index 4e1c828a4d..25d4f4a257 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -17,7 +17,7 @@ import Name             ( Name, getName )
 import NameEnv
 import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
-import Type             ( flattenRepType, repType, typePrimRep )
+import RepType          ( typePrimRep, repTypeArgs )
 import StgCmmLayout     ( mkVirtHeapOffsets )
 import Util
 import Panic
@@ -55,7 +55,7 @@ make_constr_itbls hsc_env cons =
   mk_itbl dcon conNo = do
      let rep_args = [ (typePrimRep rep_arg,rep_arg)
                     | arg <- dataConRepArgTys dcon
-                    , rep_arg <- flattenRepType (repType arg) ]
+                    , rep_arg <- repTypeArgs arg ]
 
          (tot_wds, ptr_wds, _) =
              mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index f4076bb21b..7a59847fd1 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -34,6 +34,7 @@ import HscTypes
 
 import DataCon
 import Type
+import RepType
 import qualified Unify as U
 import Var
 import TcRnMonad
@@ -464,7 +465,7 @@ cPprTermBase y =
    ppr_list :: Precedence -> Term -> m SDoc
    ppr_list p (Term{subTerms=[h,t]}) = do
        let elems      = h : getListTerms t
-           isConsLast = not(termType(last elems) `eqType` termType h)
+           isConsLast = not (termType (last elems) `eqType` termType h)
            is_string  = all (isCharTy . ty) elems
 
        print_elems <- mapM (y cons_prec) elems
@@ -804,15 +805,15 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
            (ptr_i, ws, terms1) <- go ptr_i ws tys
            return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
       | otherwise
-      = case repType ty of
-          UnaryRep rep_ty -> do
+      = case repTypeArgs ty of
+          [rep_ty] ->  do
             (ptr_i, ws, term0)  <- go_rep ptr_i ws ty (typePrimRep rep_ty)
             (ptr_i, ws, terms1) <- go ptr_i ws tys
             return (ptr_i, ws, term0 : terms1)
-          UbxTupleRep rep_tys -> do
-            (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
-            (ptr_i, ws, terms1) <- go ptr_i ws tys
-            return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+          rep_tys -> do
+           (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
+           (ptr_i, ws, terms1) <- go ptr_i ws tys
+           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
 
     go_unary_types ptr_i ws [] = return (ptr_i, ws, [])
     go_unary_types ptr_i ws (rep_ty:rep_tys) = do
@@ -919,19 +920,25 @@ findPtrTys i ty
   = findPtrTyss i elem_tys
 
   | otherwise
-  = case repType ty of
+  = -- Can't directly call repTypeArgs here -- we lose type information in
+    -- some cases (e.g. singleton tuples)
+    case repType ty of
       UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)])
                       | otherwise                    -> return (i,     [])
-      UbxTupleRep rep_tys  -> foldM (\(i, extras) rep_ty -> if typePrimRep rep_ty == PtrRep
-                                                             then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
-                                                             else return (i, extras))
-                                    (i, []) rep_tys
+      MultiRep slot_tys ->
+        foldM (\(i, extras) rep_ty ->
+                if typePrimRep rep_ty == PtrRep
+                  then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
+                  else return (i, extras))
+              (i, []) (map slotTyToType slot_tys)
 
 findPtrTyss :: Int
             -> [Type]
             -> TR (Int, [(Int, Type)])
 findPtrTyss i tys = foldM step (i, []) tys
-  where step (i, discovered) elem_ty = findPtrTys i elem_ty >>= \(i, extras) -> return (i, discovered ++ extras)
+  where step (i, discovered) elem_ty = do
+          (i, extras) <- findPtrTys i elem_ty
+          return (i, discovered ++ extras)
 
 
 -- Compute the difference between a base type and the type found by RTTI