Implement UNPACK support for sum types.

This is based on osa's unpack_sums PR from ages past.

The meat of the patch is implemented in dataConArgUnpackSum
and described in Note [UNPACK for sum types].

22 files changed, 507 insertions, 58 deletions

diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index c2fff4596c..08d08b5008 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -23,7 +23,7 @@ module GHC.Core.Make (
         FloatBind(..), wrapFloat, wrapFloats, floatBindings,
 
         -- * Constructing small tuples
-        mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUbxSum,
+        mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum,
         mkCoreTupBoxity, unitExpr,
 
         -- * Constructing big tuples
@@ -405,8 +405,8 @@ mkCoreTup cs  = mkCoreBoxedTuple cs   -- non-1-tuples are uniform
 -- | Build an unboxed sum.
 --
 -- Alternative number ("alt") starts from 1.
-mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr
-mkCoreUbxSum arity alt tys exp
+mkCoreUnboxedSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr
+mkCoreUnboxedSum arity alt tys exp
   = assert (length tys == arity) $
     assert (alt <= arity) $
     mkCoreConApps (sumDataCon alt arity)
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 1d59d33d65..81dd594090 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -2097,7 +2097,7 @@ builtinBignumRules =
         x <- isNaturalLiteral a0
         y <- isNaturalLiteral a1
         -- return an unboxed sum: (# (# #) | Natural #)
-        let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v
+        let ret n v = pure $ mkCoreUnboxedSum 2 n [unboxedUnitTy,naturalTy] v
         platform <- getPlatform
         if x < y
             then ret 1 unboxedUnitExpr
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 017263db9d..9f81f6b0b3 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -369,7 +369,7 @@ dsExpr (ExplicitTuple _ tup_args boxity)
                         -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
 
 dsExpr (ExplicitSum types alt arity expr)
-  = mkCoreUbxSum arity alt types <$> dsLExpr expr
+  = mkCoreUnboxedSum arity alt types <$> dsLExpr expr
 
 dsExpr (HsPragE _ prag expr) =
   ds_prag_expr prag expr
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 5dd44bd2b1..41e37b7f69 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -56,7 +56,7 @@ import GHC.Core.Coercion
 import GHC.Core.Reduction
 import GHC.Core.Make
 import GHC.Core.FVs     ( mkRuleInfo )
-import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase )
+import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, coreAltsType )
 import GHC.Core.Unfold.Make
 import GHC.Core.SimpleOpt
 import GHC.Core.TyCon
@@ -85,6 +85,7 @@ import GHC.Utils.Panic.Plain
 
 import GHC.Data.FastString
 import GHC.Data.List.SetOps
+import Data.List        ( zipWith4 )
 
 {-
 ************************************************************************
@@ -1028,14 +1029,8 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
         arg_ty' = case mb_co of
                     { Just redn -> scaledSet arg_ty (reductionReducedType redn)
                     ; Nothing   -> arg_ty }
-  , isUnpackableType bang_opts fam_envs (scaledThing arg_ty')
-  , (rep_tys, _) <- dataConArgUnpack arg_ty'
-  , case unpk_prag of
-      NoSrcUnpack ->
-        bang_opt_unbox_strict bang_opts
-            || (bang_opt_unbox_small bang_opts
-                && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]
-      srcUnpack -> isSrcUnpacked srcUnpack
+  , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty')
+  , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty'
   = case mb_co of
       Nothing   -> HsUnpack Nothing
       Just redn -> HsUnpack (Just $ reductionCoercion redn)
@@ -1043,7 +1038,6 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
   | otherwise -- Record the strict-but-no-unpack decision
   = HsStrict
 
-
 -- | Wrappers/Workers and representation following Unpack/Strictness
 -- decisions
 dataConArgRep
@@ -1059,8 +1053,7 @@ dataConArgRep arg_ty HsStrict
   = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
 
 dataConArgRep arg_ty (HsUnpack Nothing)
-  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
-  = (rep_tys, wrappers)
+  = dataConArgUnpack arg_ty
 
 dataConArgRep (Scaled w _) (HsUnpack (Just co))
   | let co_rep_ty = coercionRKind co
@@ -1097,50 +1090,231 @@ unitBoxer :: Boxer
 unitBoxer = UnitBox
 
 -------------------------
+
+{- Note [UNPACK for sum types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a data type D, for example:
+    data D = D1 [Int] [Bool]
+           | D2
+
+and another data type which unpacks a field of type D:
+    data U a = MkU {-# UNPACK #-} !D
+                   {-# UNPACK #-} !(a,a)
+                   {-# UNPACK #-} !D
+
+Then the wrapper and worker for MkU have these types
+
+  -- Wrapper
+  $WMkU :: D -> (a,a) -> D -> U a
+
+  -- Worker
+  MkU :: (# (# [Int],[Bool] #) | (# #) #)
+      -> a
+      -> a
+      -> (# (# [Int],[Bool] #) | (# #) #)
+      -> U a
+
+For each unpacked /sum/-type argument, the worker gets one argument.
+But for each unpacked /product/-type argument, the worker gets N
+arguments (here two).
+
+Why treat them differently?  See Note [Why sums and products are treated differently].
+
+The wrapper $WMkU looks like this:
+
+  $WMkU :: D -> (a,a) -> D -> U a
+  $WMkU x1 y x2
+    = case (case x1 of {
+              D1 a b -> (# (# a,b #) | #)
+              D2     -> (# | (# #) #) }) of { x1_ubx ->
+      case y of { (y1, y2) ->
+      case (case x2 of {
+              D1 a b -> (# (# a,b #) | #)
+              D2     -> (# | (# #) #) }) of { x2_ubx ->
+      MkU x1_ubx y1 y2 x2_ubx
+
+Notice the nested case needed for sums.
+
+This different treatment for sums and product is implemented in
+dataConArgUnpackSum and dataConArgUnpackProduct respectively.
+
+Note [Why sums and products are treated differently]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Can we handle sums like products, with each wrapper argument
+occupying multiple argument slots in the worker?  No: for a sum
+type the number of argument slots varies, and that's exactly what
+unboxed sums are designed for.
+
+Can we handle products like sums, with each wrapper argument occupying
+exactly one argument slot (and unboxed tuple) in the worker?  Yes,
+we could.  For example
+   data P = MkP {-# UNPACK #-} !Q
+   data Q = MkQ {-# NOUNPACK #-} !Int
+                {-# NOUNPACK #-} Int
+
+Currently could unpack P thus, taking two slots in the worker
+   $WMkP :: Q -> P
+   $WMkP x = case x of { MkQ a b -> MkP a b }
+   MkP :: Int -> Int -> P  -- Worker
+
+We could instead do this (uniformly with sums)
+
+   $WMkP1 :: Q -> P
+   $WMkP1 x = case (case x of { MkQ a b -> (# a, b #) }) of ubx_x
+              MkP1 ubx_x
+   MkP1 :: (# Int, Int #) -> P  -- Worker
+
+The representation of MkP and MkP1 would be identical (a constructor
+with two fields).
+
+BUT, with MkP (as with every data constructor) we record its argument
+strictness as a bit-vector, actually [StrictnessMark]
+   MkP strictness:  SL
+This information is used in Core to record which fields are sure to
+be evaluated.  (Look for calls to dataConRepStrictness.)  E.g. in Core
+    case v of MkP x y -> ....<here x is known to be evald>....
+
+Alas, with MkP1 this information is hidden by the unboxed pair,
+In Core there will be an auxiliary case expression to take apart the pair:
+    case v of MkP1 xy -> case xy of (# x,y #) -> ...
+And now we have no easy way to know that x is evaluated in the "...".
+
+Fixing this might be possible, but it'd be tricky.  So we avoid the
+problem entirely by treating sums and products differently here.
+-}
+
 dataConArgUnpack
    :: Scaled Type
    ->  ( [(Scaled Type, StrictnessMark)]   -- Rep types
        , (Unboxer, Boxer) )
-
-dataConArgUnpack (Scaled arg_mult arg_ty)
+dataConArgUnpack scaledTy@(Scaled _ arg_ty)
   | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
-  , Just con <- tyConSingleAlgDataCon_maybe tc
-      -- NB: check for an *algebraic* data type
-      -- A recursive newtype might mean that
-      -- 'arg_ty' is a newtype
-  , let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args
-  = assert (null (dataConExTyCoVars con))
-      -- Note [Unpacking GADTs and existentials]
-    ( rep_tys `zip` dataConRepStrictness con
-    ,( \ arg_id ->
-       do { rep_ids <- mapM (newLocal (fsLit "unbx")) rep_tys
-          ; let r_mult = idMult arg_id
-          ; let rep_ids' = map (scaleIdBy r_mult) rep_ids
-          ; let unbox_fn body
-                  = mkSingleAltCase (Var arg_id) arg_id
-                             (DataAlt con) rep_ids' body
-          ; return (rep_ids, unbox_fn) }
-     , Boxer $ \ subst ->
-       do { rep_ids <- mapM (newLocal (fsLit "bx") . TcType.substScaledTyUnchecked subst) rep_tys
-          ; return (rep_ids, Var (dataConWorkId con)
-                             `mkTyApps` (substTysUnchecked subst tc_args)
-                             `mkVarApps` rep_ids ) } ) )
+  = assert (not (isNewTyCon tc)) $
+    case tyConDataCons tc of
+      [con] -> dataConArgUnpackProduct scaledTy tc_args con
+      cons  -> dataConArgUnpackSum scaledTy tc_args cons
   | otherwise
   = pprPanic "dataConArgUnpack" (ppr arg_ty)
     -- An interface file specified Unpacked, but we couldn't unpack it
 
-isUnpackableType :: BangOpts -> FamInstEnvs -> Type -> Bool
--- True if we can unpack the UNPACK the argument type
+dataConArgUnpackProduct
+  :: Scaled Type
+  -> [Type]
+  -> DataCon
+  -> ( [(Scaled Type, StrictnessMark)]   -- Rep types
+     , (Unboxer, Boxer) )
+dataConArgUnpackProduct (Scaled arg_mult _) tc_args con =
+  assert (null (dataConExTyCoVars con)) $
+    -- Note [Unpacking GADTs and existentials]
+  let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args
+  in ( rep_tys `zip` dataConRepStrictness con
+     , ( \ arg_id ->
+         do { rep_ids <- mapM (newLocal (fsLit "unbx")) rep_tys
+            ; let r_mult = idMult arg_id
+            ; let rep_ids' = map (scaleIdBy r_mult) rep_ids
+            ; let unbox_fn body
+                    = mkSingleAltCase (Var arg_id) arg_id
+                               (DataAlt con) rep_ids' body
+            ; return (rep_ids, unbox_fn) }
+       , Boxer $ \ subst ->
+         do { rep_ids <- mapM (newLocal (fsLit "bx") . TcType.substScaledTyUnchecked subst) rep_tys
+            ; return (rep_ids, Var (dataConWorkId con)
+                               `mkTyApps` (substTysUnchecked subst tc_args)
+                               `mkVarApps` rep_ids ) } ) )
+
+dataConArgUnpackSum
+  :: Scaled Type
+  -> [Type]
+  -> [DataCon]
+  -> ( [(Scaled Type, StrictnessMark)]   -- Rep types
+     , (Unboxer, Boxer) )
+dataConArgUnpackSum (Scaled arg_mult arg_ty) tc_args cons =
+  ( [ (sum_ty, MarkedStrict) ] -- The idea: Unpacked variant will
+                               -- be one field only, and the type of the
+                               -- field will be an unboxed sum.
+  , ( unboxer, boxer ) )
+  where
+    !ubx_sum_arity = length cons
+    src_tys = map (\con -> map scaledThing $ dataConInstArgTys con tc_args) cons
+    sum_alt_tys = map mkUbxSumAltTy src_tys
+    sum_ty_unscaled = mkSumTy sum_alt_tys
+    sum_ty = Scaled arg_mult sum_ty_unscaled
+    newLocal' fs = newLocal fs . Scaled arg_mult
+
+    -- See Note [UNPACK for sum types]
+    unboxer :: Unboxer
+    unboxer arg_id = do
+      con_arg_binders <- mapM (mapM (newLocal' (fsLit "unbx"))) src_tys
+      ubx_sum_bndr <- newLocal (fsLit "unbx") sum_ty
+
+      let
+        mk_ubx_sum_alt :: Int -> DataCon -> [Var] -> CoreAlt
+        mk_ubx_sum_alt alt con [bndr] = Alt (DataAlt con) [bndr]
+            (mkCoreUnboxedSum ubx_sum_arity alt sum_alt_tys (Var bndr))
+
+        mk_ubx_sum_alt alt con bndrs =
+          let tuple = mkCoreUnboxedTuple (map Var bndrs)
+           in Alt (DataAlt con) bndrs (mkCoreUnboxedSum ubx_sum_arity alt sum_alt_tys tuple )
+
+        ubx_sum :: CoreExpr
+        ubx_sum =
+          let alts = zipWith3 mk_ubx_sum_alt [ 1 .. ] cons con_arg_binders
+           in Case (Var arg_id) arg_id (coreAltsType alts) alts
+
+        unbox_fn :: CoreExpr -> CoreExpr
+        unbox_fn body =
+          mkSingleAltCase ubx_sum ubx_sum_bndr DEFAULT [] body
+
+      return ([ubx_sum_bndr], unbox_fn)
+
+    boxer :: Boxer
+    boxer = Boxer $ \ subst -> do
+              unboxed_field_id <- newLocal' (fsLit "bx") (TcType.substTy subst sum_ty_unscaled)
+              tuple_bndrs <- mapM (newLocal' (fsLit "bx") . TcType.substTy subst) sum_alt_tys
+
+              let tc_args' = substTys subst tc_args
+                  arg_ty' = substTy subst arg_ty
+
+              con_arg_binders <-
+                mapM (mapM (newLocal' (fsLit "bx")) . map (TcType.substTy subst)) src_tys
+
+              let mk_sum_alt :: Int -> DataCon -> Var -> [Var] -> CoreAlt
+                  mk_sum_alt alt con _ [datacon_bndr] =
+                    ( Alt (DataAlt (sumDataCon alt ubx_sum_arity)) [datacon_bndr]
+                      (Var (dataConWorkId con) `mkTyApps`  tc_args'
+                                              `mkVarApps` [datacon_bndr] ))
+
+                  mk_sum_alt alt con tuple_bndr datacon_bndrs =
+                    ( Alt (DataAlt (sumDataCon alt ubx_sum_arity)) [tuple_bndr] (
+                      Case (Var tuple_bndr) tuple_bndr arg_ty'
+                        [ Alt (DataAlt (tupleDataCon Unboxed (length datacon_bndrs))) datacon_bndrs
+                            (Var (dataConWorkId con) `mkTyApps`  tc_args'
+                                                    `mkVarApps` datacon_bndrs ) ] ))
+
+              return ( [unboxed_field_id],
+                       Case (Var unboxed_field_id) unboxed_field_id arg_ty'
+                            (zipWith4 mk_sum_alt [ 1 .. ] cons tuple_bndrs con_arg_binders) )
+
+-- | Every alternative of an unboxed sum has exactly one field, and we use
+-- unboxed tuples when we need more than one field. This generates an unboxed
+-- tuple when necessary, to be used in unboxed sum alts.
+mkUbxSumAltTy :: [Type] -> Type
+mkUbxSumAltTy [ty] = ty
+mkUbxSumAltTy tys  = mkTupleTy Unboxed tys
+
+shouldUnpackTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
+-- True if we ought to unpack the UNPACK the argument type
 -- See Note [Recursive unboxing]
 -- We look "deeply" inside rather than relying on the DataCons
 -- we encounter on the way, because otherwise we might well
 -- end up relying on ourselves!
-isUnpackableType bang_opts fam_envs ty
-  | Just data_con <- unpackable_type ty
-  = ok_con_args emptyNameSet data_con
+shouldUnpackTy bang_opts prag fam_envs ty
+  | Just data_cons <- unpackable_type_datacons (scaledThing ty)
+  = all (ok_con_args emptyNameSet) data_cons && should_unpack data_cons
   | otherwise
   = False
   where
+    ok_con_args :: NameSet -> DataCon -> Bool
     ok_con_args dcs con
        | dc_name `elemNameSet` dcs
        = False
@@ -1153,17 +1327,20 @@ isUnpackableType bang_opts fam_envs ty
          dc_name = getName con
          dcs' = dcs `extendNameSet` dc_name
 
+    ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
     ok_arg dcs (Scaled _ ty, bang)
       = not (attempt_unpack bang) || ok_ty dcs norm_ty
       where
         norm_ty = topNormaliseType fam_envs ty
 
+    ok_ty :: NameSet -> Type -> Bool
     ok_ty dcs ty
-      | Just data_con <- unpackable_type ty
-      = ok_con_args dcs data_con
+      | Just data_cons <- unpackable_type_datacons ty
+      = all (ok_con_args dcs) data_cons
       | otherwise
       = True        -- NB True here, in contrast to False at top level
 
+    attempt_unpack :: HsSrcBang -> Bool
     attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
       = bang_opt_strict_data bang_opts
     attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
@@ -1174,16 +1351,40 @@ isUnpackableType bang_opts fam_envs ty
       = bang_opt_strict_data bang_opts -- Be conservative
     attempt_unpack _ = False
 
-    unpackable_type :: Type -> Maybe DataCon
-    -- Works just on a single level
-    unpackable_type ty
-      | Just (tc, _) <- splitTyConApp_maybe ty
-      , Just data_con <- tyConSingleAlgDataCon_maybe tc
-      , null (dataConExTyCoVars data_con)
-          -- See Note [Unpacking GADTs and existentials]
-      = Just data_con
-      | otherwise
-      = Nothing
+    -- Determine whether we ought to unpack a field based on user annotations if present and heuristics if not.
+    should_unpack data_cons =
+      case prag of
+        SrcNoUnpack -> False -- {-# NOUNPACK #-}
+        SrcUnpack   -> True  -- {-# UNPACK #-}
+        NoSrcUnpack -- No explicit unpack pragma, so use heuristics
+          | (_:_:_) <- data_cons
+          -> False -- don't unpack sum types automatically, but they can be unpacked with an explicit source UNPACK.
+          | otherwise
+          -> bang_opt_unbox_strict bang_opts
+             || (bang_opt_unbox_small bang_opts
+                 && rep_tys `lengthAtMost` 1)  -- See Note [Unpack one-wide fields]
+      where (rep_tys, _) = dataConArgUnpack ty
+
+
+-- Given a type already assumed to have been normalized by topNormaliseType,
+-- unpackable_type_datacons ty = Just datacons
+-- iff ty is of the form
+--     T ty1 .. tyn
+-- and T is an algebraic data type (not newtype), in which no data
+-- constructors have existentials, and datacons is the list of data
+-- constructors of T.
+unpackable_type_datacons :: Type -> Maybe [DataCon]
+unpackable_type_datacons ty
+  | Just (tc, _) <- splitTyConApp_maybe ty
+  , not (isNewTyCon tc)
+    -- Even though `ty` has been normalised, it could still
+    -- be a /recursive/ newtype, so we must check for that
+  , Just cons <- tyConDataCons_maybe tc
+  , not (null cons)
+  , all (null . dataConExTyCoVars) cons
+  = Just cons -- See Note [Unpacking GADTs and existentials]
+  | otherwise
+  = Nothing
 
 {-
 Note [Unpacking GADTs and existentials]
diff --git a/docs/users_guide/exts/pragmas.rst b/docs/users_guide/exts/pragmas.rst
index 6550fd88d8..0197a2fa1a 100644
--- a/docs/users_guide/exts/pragmas.rst
+++ b/docs/users_guide/exts/pragmas.rst
@@ -845,8 +845,14 @@ flattening the pair. Multi-level unpacking is also supported: ::
 will store two unboxed ``Int#``\ s directly in the ``T`` constructor.
 The unpacker can see through newtypes, too.
 
+Since 9.6.1, data types with multiple constructors can also be unpacked, effectively
+transforming the field into an unboxed sum of the unpackings of each
+constructor (see :extension:`UnboxedSums`).
+
 See also the :ghc-flag:`-funbox-strict-fields` flag, which essentially has the
-effect of adding ``{-# UNPACK #-}`` to every strict constructor field.
+effect of adding ``{-# UNPACK #-}`` to every strict constructor field which is
+of a single-constructor data type. Sum types won't be unpacked automatically
+by this though, only with the explicit pragma.
 
 .. [1]
    In fact, :pragma:`UNPACK` has no effect without :ghc-flag:`-O`, for technical
diff --git a/testsuite/tests/unboxedsums/Makefile b/testsuite/tests/unboxedsums/Makefile
new file mode 100644
index 0000000000..23548ec58c
--- /dev/null
+++ b/testsuite/tests/unboxedsums/Makefile
@@ -0,0 +1,11 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: unpack_sums_7
+
+unpack_sums_7:
+	$(RM) -f unpack_sums_7.o unpack_sums_7.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c unpack_sums_7.hs  -O -dsuppress-all -ddump-simpl | grep -q '\(# |_ #\)'
+	# This is a test to check for the presence of an unboxed sum in the core for a program using UNPACK
+	# on a sum type which is evidence that the field has been correctly unpacked.
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index d1278a4eb2..0d887c60ed 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -40,3 +40,18 @@ test('T22187',[only_ways(llvm_ways)],compile,[''])
 test('T22187_run',[only_ways(llvm_ways)
                   ,unless(arch('x86_64'), skip)],compile_and_run,[''])
 
+test('unpack_sums_1', normal, compile_and_run, ['-O'])
+test('unpack_sums_2', normal, compile, ['-O'])
+test('unpack_sums_3', normal, compile_and_run, ['-O'])
+test('unpack_sums_4', normal, compile_and_run, ['-O'])
+test('unpack_sums_5', normal, compile, ['-O'])
+test('unpack_sums_6', normal, compile_and_run, ['-O'])
+test('unpack_sums_7', [], makefile_test, [])
+test('unpack_sums_8', normal, compile_and_run, [""])
+test('unpack_sums_9', normal, compile, [""])
+
+# TODO: Need to run this in --slow mode only
+# test('sum_api_annots',
+#      [only_ways(['normal']),
+#       extra_files([ "unboxedsums" + str(i) + ".hs" for i in range(1, 12) ])],
+#      makefile_test, [])
diff --git a/testsuite/tests/unboxedsums/unpack_sums_1.hs b/testsuite/tests/unboxedsums/unpack_sums_1.hs
new file mode 100644
index 0000000000..91f286a9de
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_1.hs
@@ -0,0 +1,22 @@
+module Main where
+
+data T = T1 Int | T2 String
+  deriving (Show, Eq, Ord, Read)
+
+data T' = T' {-# UNPACK #-} !T
+  deriving (Show, Eq, Ord, Read)
+
+t1, t2 :: T
+t1 = T1 123
+t2 = T2 "OK"
+{-# NOINLINE t1 #-}
+{-# NOINLINE t2 #-}
+
+t'1, t'2 :: T'
+t'1 = T' t1
+t'2 = T' t2
+
+main :: IO ()
+main = do
+  print t'1
+  print t'2
diff --git a/testsuite/tests/unboxedsums/unpack_sums_1.stdout b/testsuite/tests/unboxedsums/unpack_sums_1.stdout
new file mode 100644
index 0000000000..0990251757
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_1.stdout
@@ -0,0 +1,2 @@
+T' (T1 123)
+T' (T2 "OK")
diff --git a/testsuite/tests/unboxedsums/unpack_sums_2.hs b/testsuite/tests/unboxedsums/unpack_sums_2.hs
new file mode 100644
index 0000000000..ff530974e2
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_2.hs
@@ -0,0 +1,9 @@
+module Lib where
+
+data Number = F {-# UNPACK #-} !Float | I {-# UNPACK #-} !Int
+
+-- This UNPACK was causing a panic:
+--   ghc-stage1: panic! (the 'impossible' happened)
+--     (GHC version 8.1.20160722 for x86_64-unknown-linux):
+--           LocalReg's live-in to graph crG {_grh::F32, _gri::I64}
+data T = T {-# UNPACK #-} !Number
diff --git a/testsuite/tests/unboxedsums/unpack_sums_3.hs b/testsuite/tests/unboxedsums/unpack_sums_3.hs
new file mode 100644
index 0000000000..01860f2d12
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_3.hs
@@ -0,0 +1,14 @@
+-- Check that we can unpack a strict Maybe Int field.
+import System.Exit
+
+data T = MkT {-# UNPACK #-} !(Maybe Int)
+
+xs = Nothing : [Just n | n <- [1..10]]
+
+ts = map MkT xs
+
+main = if xs == map (\(MkT m) -> m) ts
+  then return ()
+  else do
+    putStrLn "Error in packing and unpacking!"
+    exitFailure
diff --git a/testsuite/tests/unboxedsums/unpack_sums_4.hs b/testsuite/tests/unboxedsums/unpack_sums_4.hs
new file mode 100644
index 0000000000..0d28398cca
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_4.hs
@@ -0,0 +1,8 @@
+-- Check that nothing goes wrong with UNPACK in recursive case.
+data T = MkT {-# UNPACK #-} !(Maybe T)
+  deriving Show
+
+t :: T
+t = MkT (Just t)
+
+main = print $ take 100 (show t)
diff --git a/testsuite/tests/unboxedsums/unpack_sums_4.stdout b/testsuite/tests/unboxedsums/unpack_sums_4.stdout
new file mode 100644
index 0000000000..be36978242
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_4.stdout
@@ -0,0 +1 @@
+"MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (M"
diff --git a/testsuite/tests/unboxedsums/unpack_sums_5.hs b/testsuite/tests/unboxedsums/unpack_sums_5.hs
new file mode 100644
index 0000000000..87514f63cb
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_5.hs
@@ -0,0 +1,11 @@
+module UnpackSumsFive where
+-- Check that failure to unpack is warned about.
+
+data SMaybeT = NoT | JustT {-# UNPACK #-} !T
+  deriving Show
+
+data T = MkT {-# UNPACK #-} !SMaybeT
+  deriving Show
+
+t :: T
+t = MkT (JustT (MkT (JustT (MkT NoT))))
diff --git a/testsuite/tests/unboxedsums/unpack_sums_5.stderr b/testsuite/tests/unboxedsums/unpack_sums_5.stderr
new file mode 100644
index 0000000000..96e786895a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_5.stderr
@@ -0,0 +1,10 @@
+
+unpack_sums_5.hs:4:22: warning:
+    • Ignoring unusable UNPACK pragma on the first argument of ‘JustT’
+    • In the definition of data constructor ‘JustT’
+      In the data type declaration for ‘SMaybeT’
+
+unpack_sums_5.hs:7:10: warning:
+    • Ignoring unusable UNPACK pragma on the first argument of ‘MkT’
+    • In the definition of data constructor ‘MkT’
+      In the data type declaration for ‘T’
diff --git a/testsuite/tests/unboxedsums/unpack_sums_6.hs b/testsuite/tests/unboxedsums/unpack_sums_6.hs
new file mode 100644
index 0000000000..ec60966282
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_6.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE BangPatterns #-}
+-- This perhaps overly simple test check if code involving
+-- unbacked sums is faster than non-unpacked ones which at
+-- least in this case we expect to be the case.
+-- However this test isn't quite robust, should it fail in
+-- the future we might want to redo it or mark it fragile.
+import Data.Time.Clock
+
+import Data.Int
+import System.Exit
+
+data A = ANothing | AJust {-# UNPACK #-} !Int64
+data B = BNothing | BJust {-# UNPACK #-} !A
+data C = CNothing | CJust {-# UNPACK #-} !B
+data D = DNothing | DJust {-# UNPACK #-} !C
+
+data Unlayered = Unlayered {-# UNPACK #-} !D
+
+data Layered = Layered !(Maybe (Maybe (Maybe (Maybe Int64))))
+
+makeUnlayered :: Int64 -> [Unlayered]
+makeUnlayered n = Unlayered . DJust . CJust . BJust . AJust <$> [1..n]
+
+makeLayered :: Int64 -> [Layered]
+makeLayered n = Layered . Just . Just . Just . Just <$> [1..n]
+
+sumUnlayered :: [Unlayered] -> Int64
+sumUnlayered = go 0
+ where
+  go !n [] = n
+  go !n (w:ws) = case w of
+    Unlayered (DJust (CJust (BJust (AJust i)))) -> go (n+i) ws
+    Unlayered _ -> go n ws
+
+sumLayered :: [Layered] -> Int64
+sumLayered = go 0
+ where
+  go !n [] = n
+  go !n (w:ws) = case w of
+    Layered (Just (Just (Just (Just i)))) -> go (n+i) ws
+    Layered _ -> go n ws
+
+main :: IO ()
+main = do
+  let magnitude = 10000000
+      unlayeredInts = makeUnlayered magnitude
+      layeredInts = makeLayered magnitude
+  now <- getCurrentTime
+  print $ sumUnlayered unlayeredInts
+  unlayeredTime <- getCurrentTime
+  print $ sumLayered layeredInts
+  layeredTime <- getCurrentTime
+  case (unlayeredTime `diffUTCTime` now) < (layeredTime `diffUTCTime` unlayeredTime) of
+    True -> exitSuccess
+    False -> exitFailure
diff --git a/testsuite/tests/unboxedsums/unpack_sums_6.stdout b/testsuite/tests/unboxedsums/unpack_sums_6.stdout
new file mode 100644
index 0000000000..90a8e417bd
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_6.stdout
@@ -0,0 +1,2 @@
+50000005000000
+50000005000000
diff --git a/testsuite/tests/unboxedsums/unpack_sums_7.hs b/testsuite/tests/unboxedsums/unpack_sums_7.hs
new file mode 100644
index 0000000000..cefa317a01
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_7.hs
@@ -0,0 +1,10 @@
+-- NB: Compiling this module throws an exception involving Weak# at the end of compilation.
+-- This is unrelated to unpacked sums but we need to include the error in the expected output for the test to pass.
+
+module UnpackedSums7 where
+
+data T = MkT {-# UNPACK #-} !MI
+
+data MI = NoI | JI Int
+
+t = MkT (JI 5)
diff --git a/testsuite/tests/unboxedsums/unpack_sums_7.stderr b/testsuite/tests/unboxedsums/unpack_sums_7.stderr
new file mode 100644
index 0000000000..d37b1c154a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_7.stderr
@@ -0,0 +1,2 @@
+Exception during Weak# finalization (ignored): <stdout>: hFlush: resource vanished (Broken pipe)
+Exception during Weak# finalization (ignored): <stdout>: hFlush: resource vanished (Broken pipe)
diff --git a/testsuite/tests/unboxedsums/unpack_sums_8.hs b/testsuite/tests/unboxedsums/unpack_sums_8.hs
new file mode 100644
index 0000000000..9946cc4ada
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_8.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
+
+module Main where
+
+data Void
+data WithVoid = LV Void | RV
+data EnumT = L | R
+    deriving Show
+
+data BoxEnum = BoxEnum {-# UNPACK #-} !EnumT
+    deriving Show
+
+l = BoxEnum L
+r = BoxEnum R
+
+main = do
+    print l
+    print r
+
+
+data BoxWithVoid = BoxWithVoid {-# UNPACK #-} !WithVoid
+wv = BoxWithVoid (LV undefined)
+
+data BoxVoid = BoxVoid {-# UNPACK #-} Void
+bv = BoxVoid undefined
+
+data BoxSum = BoxS {-# UNPACK #-} !(# Int | Char #)
+bs = BoxS (# 1 | #)
diff --git a/testsuite/tests/unboxedsums/unpack_sums_8.stdout b/testsuite/tests/unboxedsums/unpack_sums_8.stdout
new file mode 100644
index 0000000000..eb719d1446
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_8.stdout
@@ -0,0 +1,2 @@
+BoxEnum L
+BoxEnum R
diff --git a/testsuite/tests/unboxedsums/unpack_sums_9.hs b/testsuite/tests/unboxedsums/unpack_sums_9.hs
new file mode 100644
index 0000000000..af12debb25
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_9.hs
@@ -0,0 +1,39 @@
+
+module UnpackedSums8 where
+
+-- Unpack a sum of 100 ints in each constructor
+data Unpackee
+   = U !Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+
+    | O Word Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+
+data Box = Box {-# UNPACK #-} !Unpackee
+
+b = Box $ U 0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0