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, 62 insertions, 43 deletions

diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 2d9ca8cb2a..cba139a532 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -21,6 +21,7 @@ import CoreArity        ( manifestArity )
 import StgSyn
 
 import Type
+import RepType
 import TyCon
 import MkId             ( coercionTokenId )
 import Id
@@ -45,7 +46,7 @@ import Demand           ( isUsedOnce )
 import PrimOp           ( PrimCall(..) )
 import UniqFM
 
-import Data.Maybe    (isJust)
+import Data.Maybe    (isJust, fromMaybe)
 import Control.Monad (liftM, ap)
 
 -- Note [Live vs free]
@@ -451,8 +452,7 @@ mkStgAltType bndr alts = case repType (idType bndr) of
                 | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                         PolyAlt
         Nothing                      -> PolyAlt
-    UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys)
-        -- UbxTupAlt includes nullary and and singleton unboxed tuples
+    MultiRep slots -> MultiValAlt (length slots)
   where
    _is_poly_alt_tycon tc
         =  isFunTyCon tc
@@ -537,7 +537,9 @@ coreToStgApp _ f args ticks = do
 
         res_ty = exprType (mkApps (Var f) args)
         app = case idDetails f of
-                DataConWorkId dc | saturated -> StgConApp dc args'
+                DataConWorkId dc
+                  | saturated    -> StgConApp dc args'
+                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
 
                 -- Some primitive operator that might be implemented as a library call.
                 PrimOpId op      -> ASSERT( saturated )
@@ -602,10 +604,10 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
 
         (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
         stg_arg = case arg'' of
-                       StgApp v []      -> StgVarArg v
-                       StgConApp con [] -> StgVarArg (dataConWorkId con)
-                       StgLit lit       -> StgLitArg lit
-                       _                -> pprPanic "coreToStgArgs" (ppr arg)
+                       StgApp v []        -> StgVarArg v
+                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)
+                       StgLit lit         -> StgLitArg lit
+                       _                  -> pprPanic "coreToStgArgs" (ppr arg)
 
         -- WARNING: what if we have an argument like (v `cast` co)
         --          where 'co' changes the representation type?
@@ -620,8 +622,8 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         arg_ty = exprType arg
         stg_arg_ty = stgArgType stg_arg
         bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
-                || (map typePrimRep (flattenRepType (repType arg_ty))
-                        /= map typePrimRep (flattenRepType (repType stg_arg_ty)))
+                || (map typePrimRep (repTypeArgs arg_ty)
+                        /= map typePrimRep (repTypeArgs stg_arg_ty))
         -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
         -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
         -- we can treat an unlifted value as lifted.  But the other way round
@@ -769,9 +771,11 @@ mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
                    (getFVs rhs_fvs)
                    ReEntrant
                    bndrs body
-  | StgConApp con args <- unticked_rhs
+  | StgConApp con args _ <- unticked_rhs
   , not (con_updateable con args)
-  = StgRhsCon noCCS con args
+  = -- CorePrep does this right, but just to make sure
+    ASSERT (not (isUnboxedTupleCon con || isUnboxedSumCon con))
+    StgRhsCon noCCS con args
   | otherwise
   = StgRhsClosure noCCS binder_info
                    (getFVs rhs_fvs)
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index b3f718241e..eb07e6b447 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -21,6 +21,7 @@ import Maybes
 import Name             ( getSrcLoc )
 import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
 import Type
+import RepType
 import TyCon
 import Util
 import SrcLoc
@@ -81,6 +82,7 @@ lintStgBindings whodunnit binds
 lintStgArg :: StgArg -> LintM (Maybe Type)
 lintStgArg (StgLitArg lit) = return (Just (literalType lit))
 lintStgArg (StgVarArg v)   = lintStgVar v
+lintStgArg (StgRubbishArg ty) = return (Just ty)
 
 lintStgVar :: Id -> LintM (Maybe Kind)
 lintStgVar v = do checkInScope v
@@ -133,9 +135,14 @@ lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
         body_ty <- MaybeT $ lintStgExpr expr
         return (mkFunTys (map idType binders) body_ty)
 
-lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do
-    arg_tys <- mapM (MaybeT . lintStgArg) args
-    MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
+lintStgRhs rhs@(StgRhsCon _ con args) = do
+    -- TODO: Check arg_tys
+    when (isUnboxedTupleCon con || isUnboxedSumCon con) $
+      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
+               ppr rhs)
+    runMaybeT $ do
+      arg_tys <- mapM (MaybeT . lintStgArg) args
+      MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
   where
     con_ty = dataConRepType con
 
@@ -148,7 +155,8 @@ lintStgExpr e@(StgApp fun args) = runMaybeT $ do
     arg_tys <- mapM (MaybeT . lintStgArg) args
     MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
 
-lintStgExpr e@(StgConApp con args) = runMaybeT $ do
+lintStgExpr e@(StgConApp con args _arg_tys) = runMaybeT $ do
+    -- TODO: Check arg_tys
     arg_tys <- mapM (MaybeT . lintStgArg) args
     MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
   where
@@ -189,16 +197,16 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
 
     in_scope <- MaybeT $ liftM Just $
      case alts_type of
-        AlgAlt tc    -> check_bndr tc >> return True
-        PrimAlt tc   -> check_bndr tc >> return True
-        UbxTupAlt _  -> return False -- Binder is always dead in this case
-        PolyAlt      -> return True
+        AlgAlt tc     -> check_bndr tc >> return True
+        PrimAlt tc    -> check_bndr tc >> return True
+        MultiValAlt _ -> return False -- Binder is always dead in this case
+        PolyAlt       -> return True
 
     MaybeT $ addInScopeVars [bndr | in_scope] $
              lintStgAlts alts scrut_ty
   where
     scrut_ty          = idType bndr
-    UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple
+    UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple or sum
     check_bndr tc = case tyConAppTyCon_maybe scrut_rep of
                         Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr
                         Nothing      -> addErrL bad_bndr
@@ -362,7 +370,7 @@ have long since disappeared.
 
 checkFunApp :: Type                 -- The function type
             -> [Type]               -- The arg type(s)
-            -> MsgDoc              -- Error message
+            -> MsgDoc               -- Error message
             -> LintM (Maybe Type)   -- Just ty => result type is accurate
 
 checkFunApp fun_ty arg_tys msg
@@ -414,8 +422,8 @@ stgEqType orig_ty1 orig_ty2
   = gos (repType orig_ty1) (repType orig_ty2)
   where
     gos :: RepType -> RepType -> Bool
-    gos (UbxTupleRep tys1) (UbxTupleRep tys2)
-      = equalLength tys1 tys2 && and (zipWith go tys1 tys2)
+    gos (MultiRep slots1) (MultiRep slots2)
+      = slots1 == slots2
     gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2
     gos _ _ = False
 
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index f3a02c83aa..2c22a29f76 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -59,13 +59,12 @@ import Packages    ( isDllName )
 import Platform
 import PprCore     ( {- instances -} )
 import PrimOp      ( PrimOp, PrimCall )
-import TyCon       ( PrimRep(..) )
-import TyCon       ( TyCon )
+import TyCon       ( PrimRep(..), TyCon )
 import Type        ( Type )
-import Type        ( typePrimRep )
+import RepType     ( typePrimRep )
+import UniqFM
 import UniqSet
 import Unique      ( Unique )
-import UniqFM
 import Util
 
 {-
@@ -97,6 +96,10 @@ data GenStgArg occ
   = StgVarArg  occ
   | StgLitArg  Literal
 
+    -- A rubbish arg is a value that's not supposed to be used by the generated
+    -- code, but it may be a GC root (i.e. used by GC) if the type is boxed.
+  | StgRubbishArg Type
+
 -- | Does this constructor application refer to
 -- anything in a different *Windows* DLL?
 -- If so, we can't allocate it statically
@@ -138,6 +141,7 @@ isAddrRep _       = False
 stgArgType :: StgArg -> Type
 stgArgType (StgVarArg v)   = idType v
 stgArgType (StgLitArg lit) = literalType lit
+stgArgType (StgRubbishArg ty) = ty
 
 
 -- | Strip ticks of a given type from an STG expression
@@ -192,13 +196,14 @@ primitives, and literals.
 
   | StgLit      Literal
 
-        -- StgConApp is vital for returning unboxed tuples
+        -- StgConApp is vital for returning unboxed tuples or sums
         -- which can't be let-bound first
   | StgConApp   DataCon
                 [GenStgArg occ] -- Saturated
+                [Type]          -- See Note [Types in StgConApp] in UnariseStg
 
   | StgOpApp    StgOp           -- Primitive op or foreign call
-                [GenStgArg occ] -- Saturated
+                [GenStgArg occ] -- Saturated. Not rubbish.
                 Type            -- Result type
                                 -- We need to know this so that we can
                                 -- assign result registers
@@ -402,8 +407,9 @@ The second flavour of right-hand-side is for constructors (simple but important)
                          -- DontCareCCS, because we don't count static
                          -- data in heap profiles, and we don't set CCCS
                          -- from static closure.
-        DataCon          -- constructor
-        [GenStgArg occ]  -- args
+        DataCon          -- Constructor. Never an unboxed tuple or sum, as those
+                         -- are not allocated.
+        [GenStgArg occ]  -- Args
 
 stgRhsArity :: StgRhs -> Int
 stgRhsArity (StgRhsClosure _ _ _ _ bndrs _)
@@ -442,7 +448,7 @@ exprHasCafRefs (StgApp f args)
   = stgIdHasCafRefs f || any stgArgHasCafRefs args
 exprHasCafRefs StgLit{}
   = False
-exprHasCafRefs (StgConApp _ args)
+exprHasCafRefs (StgConApp _ args _)
   = any stgArgHasCafRefs args
 exprHasCafRefs (StgOpApp _ args _)
   = any stgArgHasCafRefs args
@@ -538,9 +544,9 @@ type GenStgAlt bndr occ
 
 data AltType
   = PolyAlt             -- Polymorphic (a type variable)
-  | UbxTupAlt Int       -- Unboxed tuple of this arity
-  | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
-  | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
+  | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
+  | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
+  | PrimAlt     TyCon   -- Primitive data type; the AltCons will be LitAlts
 
 {-
 ************************************************************************
@@ -660,6 +666,7 @@ instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
 pprStgArg (StgVarArg var) = ppr var
 pprStgArg (StgLitArg con) = ppr con
+pprStgArg (StgRubbishArg ty) = text "StgRubbishArg" <> dcolon <> ppr ty
 
 pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
            => GenStgExpr bndr bdee -> SDoc
@@ -670,8 +677,8 @@ pprStgExpr (StgLit lit)     = ppr lit
 pprStgExpr (StgApp func args)
   = hang (ppr func) 4 (sep (map (ppr) args))
 
-pprStgExpr (StgConApp con args)
-  = hsep [ ppr con, brackets (interppSP args)]
+pprStgExpr (StgConApp con args _)
+  = hsep [ ppr con, brackets (interppSP args) ]
 
 pprStgExpr (StgOpApp op args _)
   = hsep [ pprStgOp op, brackets (interppSP args)]
@@ -750,10 +757,10 @@ pprStgOp (StgPrimCallOp op)= ppr op
 pprStgOp (StgFCallOp op _) = ppr op
 
 instance Outputable AltType where
-  ppr PolyAlt        = text "Polymorphic"
-  ppr (UbxTupAlt n)  = text "UbxTup" <+> ppr n
-  ppr (AlgAlt tc)    = text "Alg"    <+> ppr tc
-  ppr (PrimAlt tc)   = text "Prim"   <+> ppr tc
+  ppr PolyAlt         = text "Polymorphic"
+  ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n
+  ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc
+  ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc
 
 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 pprStgLVs lvs
@@ -768,7 +775,7 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
 
 -- special case
 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
-  = hcat [ ppr cc,
+  = hsep [ ppr cc,
            pp_binder_info bi,
            brackets (ifPprDebug (ppr free_var)),
            text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]