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, 70 insertions, 11 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 39ce506094..436ffc9ce6 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -433,9 +433,9 @@ $tab          { warnTab }
 }
 
 <0> {
-  "(#" / { ifExtension unboxedTuplesEnabled }
+  "(#" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }
          { token IToubxparen }
-  "#)" / { ifExtension unboxedTuplesEnabled }
+  "#)" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }
          { token ITcubxparen }
 }
 
@@ -995,6 +995,9 @@ atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
 ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
 ifExtension pred bits _ _ _ = pred bits
 
+orExtensions :: (ExtsBitmap -> Bool) -> (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
+orExtensions pred1 pred2 bits _ _ _ = pred1 bits || pred2 bits
+
 multiline_doc_comment :: Action
 multiline_doc_comment span buf _len = withLexedDocType (worker "")
   where
@@ -2094,6 +2097,7 @@ data ExtBits
   | RecursiveDoBit -- mdo
   | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
   | UnboxedTuplesBit -- (# and #)
+  | UnboxedSumsBit -- (# and #)
   | DatatypeContextsBit
   | TransformComprehensionsBit
   | QqBit -- enable quasiquoting
@@ -2141,6 +2145,8 @@ unicodeSyntaxEnabled :: ExtsBitmap -> Bool
 unicodeSyntaxEnabled = xtest UnicodeSyntaxBit
 unboxedTuplesEnabled :: ExtsBitmap -> Bool
 unboxedTuplesEnabled = xtest UnboxedTuplesBit
+unboxedSumsEnabled :: ExtsBitmap -> Bool
+unboxedSumsEnabled = xtest UnboxedSumsBit
 datatypeContextsEnabled :: ExtsBitmap -> Bool
 datatypeContextsEnabled = xtest DatatypeContextsBit
 qqEnabled :: ExtsBitmap -> Bool
@@ -2211,6 +2217,7 @@ mkParserFlags flags =
                .|. RecursiveDoBit              `setBitIf` xopt LangExt.RecursiveDo              flags
                .|. UnicodeSyntaxBit            `setBitIf` xopt LangExt.UnicodeSyntax            flags
                .|. UnboxedTuplesBit            `setBitIf` xopt LangExt.UnboxedTuples            flags
+               .|. UnboxedSumsBit              `setBitIf` xopt LangExt.UnboxedSums              flags
                .|. DatatypeContextsBit         `setBitIf` xopt LangExt.DatatypeContexts         flags
                .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.TransformListComp        flags
                .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.MonadComprehensions      flags
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index fea9203811..cd10a29703 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1682,6 +1682,8 @@ atype :: { LHsType RdrName }
                                              [mo $1,mc $2] }
         | '(#' comma_types1 '#)'      {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)
                                              [mo $1,mc $3] }
+        | '(#' bar_types2 '#)'        {% ams (sLL $1 $> $ HsSumTy $2)
+                                             [mo $1,mc $3] }
         | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  $2) [mos $1,mcs $3] }
         | '[:' ctype ':]'             {% ams (sLL $1 $> $ HsPArrTy  $2) [mo $1,mc $3] }
         | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   $2) [mop $1,mcp $3] }
@@ -1741,6 +1743,12 @@ comma_types1    :: { [LHsType RdrName] }  -- One or more:  ty,ty,ty
         | ctype  ',' comma_types1      {% addAnnotation (gl $1) AnnComma (gl $2)
                                           >> return ($1 : $3) }
 
+bar_types2    :: { [LHsType RdrName] }  -- Two or more:  ty|ty|ty
+        : ctype  '|' ctype             {% addAnnotation (gl $1) AnnVbar (gl $2)
+                                          >> return [$1,$3] }
+        | ctype  '|' bar_types2        {% addAnnotation (gl $1) AnnVbar (gl $2)
+                                          >> return ($1 : $3) }
+
 tv_bndrs :: { [LHsTyVarBndr RdrName] }
          : tv_bndr tv_bndrs             { $1 : $2 }
          | {- empty -}                  { [] }
@@ -2289,14 +2297,14 @@ aexp2   :: { LHsExpr RdrName }
         -- correct Haskell (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
         | '(' texp ')'                  {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] }
-        | '(' tup_exprs ')'             {% ams (sLL $1 $> (ExplicitTuple $2 Boxed))
-                                               [mop $1,mcp $3] }
+        | '(' tup_exprs ')'             {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) $2
+                                              ; ams (sLL $1 $> e) [mop $1,mcp $3] } }
 
         | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple [L (gl $2)
                                                          (Present $2)] Unboxed))
                                                [mo $1,mc $3] }
-        | '(#' tup_exprs '#)'           {% ams (sLL $1 $> (ExplicitTuple $2 Unboxed))
-                                               [mo $1,mc $3] }
+        | '(#' tup_exprs '#)'           {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) $2
+                                              ; ams (sLL $1 $> e) [mo $1,mc $3] } }
 
         | '[' list ']'      {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
         | '[:' parr ':]'    {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }
@@ -2384,16 +2392,25 @@ texp :: { LHsExpr RdrName }
        -- View patterns get parenthesized above
         | exp '->' texp   {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] }
 
--- Always at least one comma
-tup_exprs :: { [LHsTupArg RdrName] }
+-- Always at least one comma or bar.
+tup_exprs :: { SumOrTuple }
            : texp commas_tup_tail
                           {% do { addAnnotation (gl $1) AnnComma (fst $2)
-                                ; return ((sL1 $1 (Present $1)) : snd $2) } }
+                                ; return (Tuple ((sL1 $1 (Present $1)) : snd $2)) } }
+
+           | texp bars
+                          {% do { mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $2)
+                                ; return (Sum 1  (snd $2 + 1) $1) } }
 
            | commas tup_tail
                 {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
                       ; return
-                           (map (\l -> L l missingTupArg) (fst $1) ++ $2) } }
+                           (Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } }
+
+           | bars texp bars0
+                {% do { mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $1)
+                      ; mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $3)
+                      ; return (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } }
 
 -- Always starts with commas; always follows an expr
 commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) }
@@ -3121,6 +3138,14 @@ commas :: { ([SrcSpan],Int) }   -- One or more commas
         : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }
         | ','                    { ([gl $1],1) }
 
+bars0 :: { ([SrcSpan],Int) }     -- Zero or more bars
+        : bars                   { $1 }
+        |                        { ([], 0) }
+
+bars :: { ([SrcSpan],Int) }     -- One or more bars
+        : bars '|'               { ((fst $1)++[gl $2],snd $1 + 1) }
+        | '|'                    { ([gl $1],1) }
+
 -----------------------------------------------------------------------------
 -- Documentation comments
 
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index af1e53e866..4fc1c9c274 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -59,7 +59,9 @@ module RdrHsSyn (
         mkModuleImpExp,
         mkTypeImpExp,
         mkImpExpSubSpec,
-        checkImportSpec
+        checkImportSpec,
+
+        SumOrTuple (..), mkSumOrTuple
 
     ) where
 
@@ -866,6 +868,10 @@ checkAPat msg loc e0 = do
                                    return (TuplePat ps b [])
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
+   ExplicitSum alt arity expr _ -> do
+     p <- checkLPat msg expr
+     return (SumPat p alt arity placeHolderType)
+
    RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
                         -> do fs <- mapM (checkPatField msg) fs
                               return (ConPatIn c (RecCon (HsRecFields fs dd)))
@@ -1475,3 +1481,24 @@ mkImpExpSubSpec xs =
 
 parseErrorSDoc :: SrcSpan -> SDoc -> P a
 parseErrorSDoc span s = failSpanMsgP span s
+
+data SumOrTuple
+  = Sum ConTag Arity (LHsExpr RdrName)
+  | Tuple [LHsTupArg RdrName]
+
+mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr RdrName)
+
+-- Tuple
+mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity)
+
+-- Sum
+mkSumOrTuple Unboxed _ (Sum alt arity e) =
+    return (ExplicitSum alt arity e PlaceHolder)
+mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
+    parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
+  where
+    ppr_boxed_sum :: ConTag -> Arity -> HsExpr RdrName -> SDoc
+    ppr_boxed_sum alt arity e =
+      text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
+
+    ppr_bars n = hsep (replicate n (Outputable.char '|'))