Replace HsBang type with HsSrcBang and HsImplBang

Updates haddock submodule.

Reviewers: tibbe, goldfire, simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: goldfire, thomie, mpickering

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

15 files changed, 274 insertions, 175 deletions

diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 51b8d785d2..07ed069c51 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -10,8 +10,8 @@
 module DataCon (
         -- * Main data types
         DataCon, DataConRep(..),
-        HsBang(..), SrcStrictness(..), SrcUnpackedness(..),
-        HsSrcBang, HsImplBang,
+        SrcStrictness(..), SrcUnpackedness(..),
+        HsSrcBang(..), HsImplBang(..),
         StrictnessMark(..),
         ConTag,
 
@@ -68,6 +68,7 @@ import BasicTypes
 import FastString
 import Module
 import VarEnv
+import Binary
 
 import qualified Data.Data as Data
 import qualified Data.Typeable
@@ -347,13 +348,10 @@ data DataCon
                 -- The OrigResTy is T [a], but the dcRepTyCon might be :T123
 
         -- Now the strictness annotations and field labels of the constructor
-        dcSrcBangs :: [HsBang],
+        dcSrcBangs :: [HsSrcBang],
                 -- See Note [Bangs on data constructor arguments]
-                -- For DataCons defined in this module:
-                --    the [HsSrcBang] as written by the programmer.
-                -- For DataCons imported from an interface file:
-                --    the [HsImplBang] determined when compiling the
-                --    defining module
+                --
+                -- The [HsSrcBang] as written by the programmer.
                 --
                 -- Matches 1-1 with dcOrigArgTys
                 -- Hence length = dataConSourceArity dataCon
@@ -448,36 +446,34 @@ data DataConRep
 -- when we bring bits of unfoldings together.)
 
 -------------------------
--- | HsBang describes the strictness/unpack status of one
--- of the original data constructor arguments (i.e. *not*
--- of the representation data constructor which may have
--- more arguments after the originals have been unpacked)
--- See Note [Bangs on data constructor arguments]
-data HsBang
-  -- | What the user wrote in the source code.
-  --
-  -- (HsSrcBang _ SrcUnpack SrcLazy) and (HsSrcBang _ SrcUnpack
-  -- NoSrcStrictness) (without StrictData) makes no sense, we emit a
-  -- warning (in checkValidDataCon) and treat it like (HsSrcBang _
-  -- NoSrcUnpack SrcLazy)
-  = HsSrcBang
-       (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
-       SrcUnpackedness
-       SrcStrictness
-
-  -- Definite implementation commitments, generated by the compiler
-  -- after consulting HsSrcBang, flags, etc
-  | HsLazy -- ^ Definite commitment: Lazy field
-  | HsStrict -- ^ Definite commitment: Strict but not unpacked field
-  | HsUnpack (Maybe Coercion) -- co :: arg-ty ~ product-ty
-    -- ^ Definite commitment: Strict and unpacked field
 
+-- | Bangs on data constructor arguments as the user wrote them in the
+-- source code.
+--
+-- (HsSrcBang _ SrcUnpack SrcLazy) and
+-- (HsSrcBang _ SrcUnpack NoSrcStrict) (without StrictData) makes no sense, we
+-- emit a warning (in checkValidDataCon) and treat it like
+-- (HsSrcBang _ NoSrcUnpack SrcLazy)
+data HsSrcBang =
+  HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
+            SrcUnpackedness
+            SrcStrictness
+  deriving (Data.Data, Data.Typeable)
+
+-- | Bangs of data constructor arguments as generated by the compiler
+-- after consulting HsSrcBang, flags, etc.
+data HsImplBang
+  = HsLazy  -- ^ Lazy field
+  | HsStrict  -- ^ Strict but not unpacked field
+  | HsUnpack (Maybe Coercion)
+    -- ^ Strict and unpacked field
+    -- co :: arg-ty ~ product-ty HsBang
   deriving (Data.Data, Data.Typeable)
 
 -- | What strictness annotation the user wrote
 data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'
                    | SrcStrict -- ^ Strict, ie '!'
-                   | NoSrcStrictness -- ^ no strictness annotation
+                   | NoSrcStrict -- ^ no strictness annotation
      deriving (Eq, Data.Data, Data.Typeable)
 
 -- | What unpackedness the user requested
@@ -487,14 +483,6 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
      deriving (Eq, Data.Data, Data.Typeable)
 
 
--- Two type-insecure, but useful, synonyms
-
--- | What the user wrote; hence always HsSrcBang
-type HsSrcBang = HsBang
-
--- | A HsBang implementation decision, as determined by the compiler.
--- Never HsSrcBang
-type HsImplBang = HsBang
 
 -------------------------
 -- StrictnessMark is internal only, used to indicate strictness
@@ -523,10 +511,10 @@ Terminology:
     , HsSrcBang _ SrcUnpack SrcStrict
     , HsSrcBang _ NoSrcUnpack NoSrcStrictness]
 
-* However, if T was defined in an imported module, MkT's dcSrcBangs
-  field gives the [HsImplBang] recording the decisions of the
-  defining module.  The importing module must follow those decisions,
-  regardless of the flag settings in the importing module.
+* However, if T was defined in an imported module, the importing module
+  must follow the decisions made in the original module, regardless of
+  the flag settings in the importing module.
+  Also see Note [Bangs on imported data constructors] in MkId
 
 * The dcr_bangs field of the dcRep field records the [HsImplBang]
   If T was defined in this module, Without -O the dcr_bangs might be
@@ -595,17 +583,19 @@ instance Data.Data DataCon where
     gunfold _ _  = error "gunfold"
     dataTypeOf _ = mkNoRepType "DataCon"
 
-instance Outputable HsBang where
+instance Outputable HsSrcBang where
     ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark
+
+instance Outputable HsImplBang where
     ppr HsLazy                  = ptext (sLit "Lazy")
     ppr (HsUnpack Nothing)      = ptext (sLit "Unpacked")
     ppr (HsUnpack (Just co))    = ptext (sLit "Unpacked") <> parens (ppr co)
     ppr HsStrict                = ptext (sLit "StrictNotUnpacked")
 
 instance Outputable SrcStrictness where
-    ppr SrcLazy         = char '~'
-    ppr SrcStrict       = char '!'
-    ppr NoSrcStrictness = empty
+    ppr SrcLazy     = char '~'
+    ppr SrcStrict   = char '!'
+    ppr NoSrcStrict = empty
 
 instance Outputable SrcUnpackedness where
     ppr SrcUnpack   = ptext (sLit "{-# UNPACK #-}")
@@ -613,13 +603,35 @@ instance Outputable SrcUnpackedness where
     ppr NoSrcUnpack = empty
 
 instance Outputable StrictnessMark where
-  ppr MarkedStrict     = ptext (sLit "!")
-  ppr NotMarkedStrict  = empty
-
+    ppr MarkedStrict    = ptext (sLit "!")
+    ppr NotMarkedStrict = empty
+
+instance Binary SrcStrictness where
+    put_ bh SrcLazy     = putByte bh 0
+    put_ bh SrcStrict   = putByte bh 1
+    put_ bh NoSrcStrict = putByte bh 2
+
+    get bh =
+      do h <- getByte bh
+         case h of
+           0 -> return SrcLazy
+           1 -> return SrcLazy
+           _ -> return NoSrcStrict
+
+instance Binary SrcUnpackedness where
+    put_ bh SrcNoUnpack = putByte bh 0
+    put_ bh SrcUnpack   = putByte bh 1
+    put_ bh NoSrcUnpack = putByte bh 2
+
+    get bh =
+      do h <- getByte bh
+         case h of
+           0 -> return SrcNoUnpack
+           1 -> return SrcUnpack
+           _ -> return NoSrcUnpack
 
 -- | Compare strictness annotations
-eqHsBang :: HsBang -> HsBang -> Bool
-eqHsBang (HsSrcBang _ u1 b1)  (HsSrcBang _ u2 b2) = u1==u2 && b1==b2
+eqHsBang :: HsImplBang -> HsImplBang -> Bool
 eqHsBang HsLazy               HsLazy              = True
 eqHsBang HsStrict             HsStrict            = True
 eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)  = True
@@ -631,8 +643,6 @@ isBanged :: HsImplBang -> Bool
 isBanged (HsUnpack {}) = True
 isBanged (HsStrict {}) = True
 isBanged HsLazy        = False
-isBanged (HsSrcBang {})
-  = panic "DataCon.isBanged: Cannot check bangedness of HsSrcBang."
 
 isSrcStrict :: SrcStrictness -> Bool
 isSrcStrict SrcStrict = True
@@ -657,8 +667,7 @@ isMarkedStrict _               = True   -- All others are strict
 -- | Build a new data constructor
 mkDataCon :: Name
           -> Bool           -- ^ Is the constructor declared infix?
-          -> [HsBang]       -- ^ Strictness/unpack annotations, from user; or,
-                            -- for imported DataCons, from the interface file
+          -> [HsSrcBang]       -- ^ Strictness/unpack annotations, from user
           -> [FieldLabel]   -- ^ Field labels for the constructor,
                             -- if it is a record, otherwise empty
           -> [TyVar]        -- ^ Universally quantified type variables
@@ -828,8 +837,10 @@ dataConFieldType con label
       Just ty -> ty
       Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
 
--- | The strictness markings written by the porgrammer.
+-- | Strictness/unpack annotations, from user; or, for imported
+-- DataCons, from the interface file
 -- The list is in one-to-one correspondence with the arity of the 'DataCon'
+
 dataConSrcBangs :: DataCon -> [HsSrcBang]
 dataConSrcBangs = dcSrcBangs
 
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 29e0e64c9b..6895677a8f 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -465,8 +465,14 @@ newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
                        -- Bind these src-level vars, returning the
                        -- rep-level vars to bind in the pattern
 
-mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
-mkDataConRep dflags fam_envs wrap_name data_con
+mkDataConRep :: DynFlags
+             -> FamInstEnvs
+             -> Name
+             -> Maybe [HsImplBang]
+                -- See Note [Bangs on imported data constructors]
+             -> DataCon
+             -> UniqSM DataConRep
+mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
   | not wrapper_reqd
   = return NoDataConRep
 
@@ -488,7 +494,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
                              -- so it not make sure that the CAF info is sane
 
              wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
-             wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
+             wrap_arg_dmds = map mk_dmd arg_ibangs
              mk_dmd str | isBanged str = evalDmd
                         | otherwise           = topDmd
                  -- The Cpr info can be important inside INLINE rhss, where the
@@ -511,7 +517,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
                      , dcr_boxer   = mk_boxer boxers
                      , dcr_arg_tys = rep_tys
                      , dcr_stricts = rep_strs
-                     , dcr_bangs   = dropList ev_tys wrap_bangs }) }
+                     , dcr_bangs   = arg_ibangs }) }
 
   where
     (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con
@@ -519,8 +525,9 @@ mkDataConRep dflags fam_envs wrap_name data_con
     tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
     wrap_ty      = dataConUserType data_con
     ev_tys       = eqSpecPreds eq_spec ++ theta
-    all_arg_tys  = ev_tys                         ++ orig_arg_tys
-    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con
+    all_arg_tys  = ev_tys ++ orig_arg_tys
+    ev_ibangs    = map mk_pred_strict_mark ev_tys
+    orig_bangs   = dataConSrcBangs data_con
 
     wrap_arg_tys = theta ++ orig_arg_tys
     wrap_arity   = length wrap_arg_tys
@@ -528,14 +535,21 @@ mkDataConRep dflags fam_envs wrap_name data_con
              -- Because we are going to apply the eq_spec args manually in the
              -- wrapper
 
-    (wrap_bangs, rep_tys_w_strs, wrappers)
-       = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
+    arg_ibangs =
+      case mb_bangs of
+        Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)
+                              orig_arg_tys orig_bangs
+        Just bangs -> bangs
+
+    (rep_tys_w_strs, wrappers)
+      = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))
+
     (unboxers, boxers) = unzip wrappers
     (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
 
     wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
-                && (any isBanged wrap_bangs -- Some forcing/unboxing
-                                            -- (includes eq_spec)
+                && (any isBanged (ev_ibangs ++ arg_ibangs)
+                      -- Some forcing/unboxing (includes eq_spec)
                     || isFamInstTyCon tycon) -- Cast result
 
     initial_wrap_app = Var (dataConWorkId data_con)
@@ -572,38 +586,52 @@ mkDataConRep dflags fam_envs wrap_name data_con
            ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
            ; return (unbox_fn expr) }
 
+{-
+Note [Bangs on imported data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs
+from imported modules.
+
+- Nothing <=> use HsSrcBangs
+- Just bangs <=> use HsImplBangs
+
+For imported types we can't work it all out from the HsSrcBangs,
+because we want to be very sure to follow what the original module
+(where the data type was declared) decided, and that depends on what
+flags were enabled when it was compiled. So we record the decisions in
+the interface file.
+
+The HsImplBangs passed are in 1-1 correspondence with the
+dataConOrigArgTys of the DataCon.
+
+-}
+
 -------------------------
 newLocal :: Type -> UniqSM Var
 newLocal ty = do { uniq <- getUniqueM
                  ; return (mkSysLocal (fsLit "dt") uniq ty) }
 
--------------------------
-dataConArgRep
+-- | Unpack/Strictness decisions from source module
+dataConSrcToImplBang
    :: DynFlags
    -> FamInstEnvs
    -> Type
-   -> HsSrcBang     -- For DataCons defined in this module, this is the
-                    --    bang/unpack annotation that the programmer wrote
-                    -- For DataCons imported from an interface file, this
-                    --    is the HsImplBang implementation decision taken
-                    --    by the compiler in the defining module; just follow
-                    --    it slavishly, so that we make the same decision as
-                    --    in the defining module
-   -> ( HsImplBang                 -- Implementation decision about unpack strategy
-      , [(Type, StrictnessMark)]   -- Rep types
-      , (Unboxer, Boxer) )
-
-dataConArgRep dflags fam_envs arg_ty (HsSrcBang ann unpk NoSrcStrictness)
-  | xopt Opt_StrictData dflags -- StrictData => strict field
-  = dataConArgRep dflags fam_envs arg_ty (HsSrcBang ann unpk SrcStrict)
+   -> HsSrcBang
+   -> HsImplBang
 
-  | otherwise                  -- no StrictData => lazy field
-  = (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+dataConSrcToImplBang dflags fam_envs arg_ty
+              (HsSrcBang ann unpk NoSrcStrict)
+  | xopt Opt_StrictData dflags -- StrictData => strict field
+  = dataConSrcToImplBang dflags fam_envs arg_ty
+                  (HsSrcBang ann unpk SrcStrict)
+  | otherwise -- no StrictData => lazy field
+  = HsLazy
 
-dataConArgRep _ _ arg_ty (HsSrcBang _ _ SrcLazy)
-  = (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
+  = HsLazy
 
-dataConArgRep dflags fam_envs arg_ty
+dataConSrcToImplBang dflags fam_envs arg_ty
     (HsSrcBang _ unpk_prag SrcStrict)
   | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
           -- Don't unpack if we aren't optimising; rather arbitrarily,
@@ -612,7 +640,7 @@ dataConArgRep dflags fam_envs arg_ty
                      -- Unwrap type families and newtypes
         arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
   , isUnpackableType dflags fam_envs arg_ty'
-  , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
+  , (rep_tys, _) <- dataConArgUnpack arg_ty'
   , case unpk_prag of
       NoSrcUnpack ->
         gopt Opt_UnboxStrictFields dflags
@@ -620,30 +648,36 @@ dataConArgRep dflags fam_envs arg_ty
                 && length rep_tys <= 1) -- See Note [Unpack one-wide fields]
       srcUnpack -> isSrcUnpacked srcUnpack
   = case mb_co of
-      Nothing          -> (HsUnpack Nothing,   rep_tys, wrappers)
-      Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)
+      Nothing     -> HsUnpack Nothing
+      Just (co,_) -> HsUnpack (Just co)
 
   | otherwise -- Record the strict-but-no-unpack decision
-  = strict_but_not_unpacked arg_ty
+  = HsStrict
 
-dataConArgRep _ _ arg_ty HsLazy
-  = (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep _ _ arg_ty HsStrict
-  = strict_but_not_unpacked arg_ty
+-- | Wrappers/Workser and representation following Unpack/Strictness
+-- decisions
+dataConArgRep
+  :: Type
+  -> HsImplBang
+  -> ([(Type,StrictnessMark)] -- Rep types
+     ,(Unboxer,Boxer))
+
+dataConArgRep arg_ty HsLazy
+  = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep _ _ arg_ty (HsUnpack Nothing)
+dataConArgRep arg_ty HsStrict
+  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
+
+dataConArgRep arg_ty (HsUnpack Nothing)
   | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
-  = (HsUnpack Nothing, rep_tys, wrappers)
+  = (rep_tys, wrappers)
 
-dataConArgRep _ _ _ (HsUnpack (Just co))
+dataConArgRep _ (HsUnpack (Just co))
   | let co_rep_ty = pSnd (coercionKind co)
   , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
-  = (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
+  = (rep_tys, wrapCo co co_rep_ty wrappers)
 
-strict_but_not_unpacked :: Type -> (HsImplBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
-strict_but_not_unpacked arg_ty
-  = (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
 
 -------------------------
 wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
@@ -736,19 +770,13 @@ isUnpackableType dflags fam_envs ty
          -- NB: dataConSrcBangs gives the *user* request;
          -- We'd get a black hole if we used dataConImplBangs
 
-    attempt_unpack (HsUnpack {})
-      = True
-    attempt_unpack HsStrict
-      = False
-    attempt_unpack HsLazy
-      = False
-    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrictness)
+    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
       = xopt Opt_StrictData dflags
     attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
       = True
     attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)
       = True  -- Be conservative
-    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrictness)
+    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)
       = xopt Opt_StrictData dflags -- Be conservative
     attempt_unpack _ = False
 
@@ -817,7 +845,8 @@ space for each equality predicate, so it's pretty important!
 
 mk_pred_strict_mark :: PredType -> HsImplBang
 mk_pred_strict_mark pred
-  | isEqPred pred = HsUnpack Nothing    -- Note [Unpack equality predicates]
+  | isEqPred pred = HsUnpack Nothing
+  -- Note [Unpack equality predicates]
   | otherwise     = HsLazy
 
 {-
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index e123277851..2a09ebf0c3 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -28,7 +28,8 @@ module HsTypes (
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
 
-        LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang,
+        LBangType, BangType,
+        HsSrcBang(..), HsImplBang(..),
         SrcStrictness(..), SrcUnpackedness(..),
         getBangType, getBangStrictness,
 
@@ -63,7 +64,7 @@ import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
 
 import Name( Name )
 import RdrName( RdrName )
-import DataCon( HsBang(..), HsSrcBang, HsImplBang,
+import DataCon( HsSrcBang(..), HsImplBang(..),
                 SrcStrictness(..), SrcUnpackedness(..) )
 import TysPrim( funTyConName )
 import Type
@@ -99,7 +100,7 @@ getBangType ty                    = ty
 
 getBangStrictness :: LHsType a -> HsSrcBang
 getBangStrictness (L _ (HsBangTy s _)) = s
-getBangStrictness _ = HsSrcBang Nothing NoSrcUnpack NoSrcStrictness
+getBangStrictness _ = (HsSrcBang Nothing NoSrcUnpack NoSrcStrict)
 
 {-
 ************************************************************************
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 28a5f68f47..0a922e86e1 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -129,20 +129,22 @@ mkNewTyConRhs tycon_name tycon con
 ------------------------------------------------------
 buildDataCon :: FamInstEnvs
             -> Name -> Bool
-            -> [HsBang]
-            -> [Name]                   -- Field labels
-            -> [TyVar] -> [TyVar]       -- Univ and ext
-            -> [(TyVar,Type)]           -- Equality spec
-            -> ThetaType                -- Does not include the "stupid theta"
-                                        -- or the GADT equalities
-            -> [Type] -> Type           -- Argument and result types
-            -> TyCon                    -- Rep tycon
-            -> TcRnIf m n DataCon
+            -> [HsSrcBang]
+            -> Maybe [HsImplBang]
+                -- See Note [Bangs on imported data constructors] in MkId
+           -> [Name]                   -- Field labels
+           -> [TyVar] -> [TyVar]       -- Univ and ext
+           -> [(TyVar,Type)]           -- Equality spec
+           -> ThetaType                -- Does not include the "stupid theta"
+                                       -- or the GADT equalities
+           -> [Type] -> Type           -- Argument and result types
+           -> TyCon                    -- Rep tycon
+           -> TcRnIf m n DataCon
 -- A wrapper for DataCon.mkDataCon that
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --      allocating its unique (hence monadic)
-buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
+buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
              univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
@@ -155,12 +157,13 @@ buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
         ; let
                 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
                 data_con = mkDataCon src_name declared_infix
-                                     arg_stricts field_lbls
+                                     src_bangs field_lbls
                                      univ_tvs ex_tvs eq_spec ctxt
                                      arg_tys res_ty rep_tycon
                                      stupid_ctxt dc_wrk dc_rep
                 dc_wrk = mkDataConWorkId work_name data_con
-                dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con)
+                dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
+                                                  impl_bangs data_con)
 
         ; return data_con }
 
@@ -272,7 +275,8 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
         ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
                                    datacon_name
                                    False        -- Not declared infix
-                                   (map (const HsLazy) args)
+                                   (map (const no_bang) args)
+                                   (Just (map (const HsLazy) args))
                                    [{- No fields -}]
                                    tvs [{- no existentials -}]
                                    [{- No GADT equalities -}]
@@ -308,6 +312,8 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
         ; traceIf (text "buildClass" <+> ppr tycon)
         ; return result }
   where
+    no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
+
     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
     mk_op_item rec_clas (op_name, dm_spec, _)
       = do { dm_info <- case dm_spec of
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 2673e111ff..fc5053b58c 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -15,7 +15,9 @@ module IfaceSyn (
         IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
         IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
-        IfaceBang(..), IfaceAxBranch(..),
+        IfaceBang(..),
+        IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
+        IfaceAxBranch(..),
         IfaceTyConParent(..),
 
         -- Misc
@@ -57,6 +59,7 @@ import TyCon (Role (..))
 import StaticFlags (opt_PprStyle_Debug)
 import Util( filterOut )
 import InstEnv
+import DataCon (SrcStrictness(..), SrcUnpackedness(..))
 
 import Control.Monad
 import System.IO.Unsafe
@@ -196,20 +199,28 @@ data IfaceConDecl
         -- but it's not so easy for the original TyCon/DataCon
         -- So this guarantee holds for IfaceConDecl, but *not* for DataCon
 
-        ifConExTvs   :: [IfaceTvBndr],          -- Existential tyvars
-        ifConEqSpec  :: IfaceEqSpec,            -- Equality constraints
-        ifConCtxt    :: IfaceContext,           -- Non-stupid context
-        ifConArgTys  :: [IfaceType],            -- Arg types
-        ifConFields  :: [IfaceTopBndr],         -- ...ditto... (field labels)
-        ifConStricts :: [IfaceBang]}            -- Empty (meaning all lazy),
-                                                -- or 1-1 corresp with arg tys
+        ifConExTvs   :: [IfaceTvBndr],      -- Existential tyvars
+        ifConEqSpec  :: IfaceEqSpec,        -- Equality constraints
+        ifConCtxt    :: IfaceContext,       -- Non-stupid context
+        ifConArgTys  :: [IfaceType],        -- Arg types
+        ifConFields  :: [IfaceTopBndr],     -- ...ditto... (field labels)
+        ifConStricts :: [IfaceBang],
+          -- Empty (meaning all lazy),
+          -- or 1-1 corresp with arg tys
+          -- See Note [Bangs on imported data constructors] in MkId
+        ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts
 
 type IfaceEqSpec = [(IfLclName,IfaceType)]
 
-data IfaceBang  -- This corresponds to an HsImplBang; that is, the final
-                -- implementation decision about the data constructor arg
+-- | This corresponds to an HsImplBang; that is, the final
+-- implementation decision about the data constructor arg
+data IfaceBang
   = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion
 
+-- | This corresponds to HsSrcBang
+data IfaceSrcBang
+  = IfSrcBang SrcUnpackedness SrcStrictness
+
 data IfaceClsInst
   = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with
                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
@@ -1506,7 +1517,7 @@ instance Binary IfaceConDecls where
             _ -> liftM IfNewTyCon $ get bh
 
 instance Binary IfaceConDecl where
-    put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
+    put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
         put_ bh a1
         put_ bh a2
         put_ bh a3
@@ -1516,6 +1527,7 @@ instance Binary IfaceConDecl where
         put_ bh a7
         put_ bh a8
         put_ bh a9
+        put_ bh a10
     get bh = do
         a1 <- get bh
         a2 <- get bh
@@ -1526,7 +1538,8 @@ instance Binary IfaceConDecl where
         a7 <- get bh
         a8 <- get bh
         a9 <- get bh
-        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
+        a10 <- get bh
+        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
 
 instance Binary IfaceBang where
     put_ bh IfNoBang        = putByte bh 0
@@ -1542,6 +1555,16 @@ instance Binary IfaceBang where
               2 -> do return IfUnpack
               _ -> do { a <- get bh; return (IfUnpackCo a) }
 
+instance Binary IfaceSrcBang where
+    put_ bh (IfSrcBang a1 a2) =
+      do put_ bh a1
+         put_ bh a2
+
+    get bh =
+      do a1 <- get bh
+         a2 <- get bh
+         return (IfSrcBang a1 a2)
+
 instance Binary IfaceClsInst where
     put_ bh (IfaceClsInst cls tys dfun flag orph) = do
         put_ bh cls
@@ -1609,7 +1632,7 @@ instance Binary IfaceIdDetails where
         case h of
             0 -> return IfVanillaId
             1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
-            _ -> return IfDFunId 
+            _ -> return IfDFunId
 
 instance Binary IfaceIdInfo where
     put_ bh NoInfo      = putByte bh 0
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 6771925094..714777adaf 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1710,7 +1710,10 @@ tyConToIfaceDecl env tycon
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
                     ifConFields  = map getOccName
                                        (dataConFieldLabels data_con),
-                    ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con) }
+                    ifConStricts = map (toIfaceBang con_env2)
+                                       (dataConImplBangs data_con),
+                    ifConSrcStricts = map toIfaceSrcBang
+                                          (dataConSrcBangs data_con)}
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
@@ -1732,7 +1735,9 @@ toIfaceBang _    HsLazy              = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
 toIfaceBang _   HsStrict             = IfStrict
-toIfaceBang _   (HsSrcBang {})       = panic "toIfaceBang"
+
+toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
+toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
 
 classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
 classToIfaceDecl env clas
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 30ce0cd769..2cd256b030 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -515,7 +515,8 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
                          ifConExTvs = ex_tvs,
                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                          ifConArgTys = args, ifConFields = field_lbls,
-                         ifConStricts = if_stricts})
+                         ifConStricts = if_stricts,
+                         ifConSrcStricts = if_src_stricts})
      = -- Universally-quantified tyvars are shared with
        -- parent TyCon, and are alrady in scope
        bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
@@ -542,25 +543,32 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
                                 (substTyVars (mkTopTvSubst eq_spec) tc_tyvars)
 
         ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
-                       name is_infix
-                       stricts -- Pass the HsImplBangs (i.e. final decisions)
-                               -- to buildDataCon; it'll use these to guide
-                               -- the construction of a worker
-                       lbl_names
-                       tc_tyvars ex_tyvars
-                       eq_spec theta
-                       arg_tys orig_res_ty tycon
+                   name is_infix
+                   (map src_strict if_src_stricts)
+                   (Just stricts)
+                     -- Pass the HsImplBangs (i.e. final
+                     -- decisions) to buildDataCon; it'll use
+                     -- these to guide the construction of a
+                     -- worker.
+                     -- See Note [Bangs on imported data constructors] in MkId
+                   lbl_names
+                   tc_tyvars ex_tyvars
+                   eq_spec theta
+                   arg_tys orig_res_ty tycon
         ; traceIf (text "Done interface-file tc_con_decl" <+> ppr name)
         ; return con }
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
     tc_strict :: IfaceBang -> IfL HsImplBang
-    tc_strict IfNoBang = return HsLazy
-    tc_strict IfStrict = return HsStrict
+    tc_strict IfNoBang = return (HsLazy)
+    tc_strict IfStrict = return (HsStrict)
     tc_strict IfUnpack = return (HsUnpack Nothing)
     tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
                                       ; return (HsUnpack (Just co)) }
 
+    src_strict :: IfaceSrcBang -> HsSrcBang
+    src_strict (IfSrcBang unpk bang) = HsSrcBang Nothing unpk bang
+
 tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)]
 tcIfaceEqSpec spec
   = mapM do_item spec
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4b8eca6b5a..1b4df16d28 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1459,9 +1459,9 @@ sigtypes1 :: { (OrdList (LHsType RdrName)) }      -- Always HsForAllTys
 -----------------------------------------------------------------------------
 -- Types
 
-strict_mark :: { Located ([AddAnn],HsBang) }
+strict_mark :: { Located ([AddAnn],HsSrcBang) }
         : strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang Nothing NoSrcUnpack str)) }
-        | unpackedness { sL1 $1 (let (a, prag, unpk) = unLoc $1 in (a, HsSrcBang prag unpk NoSrcStrictness)) }
+        | unpackedness { sL1 $1 (let (a, prag, unpk) = unLoc $1 in (a, HsSrcBang prag unpk NoSrcStrict)) }
         | unpackedness strictness { sLL $1 $> (let { (a, prag, unpk) = unLoc $1
                                                    ; (a', str) = unLoc $2 }
                                                 in (a ++ a', HsSrcBang prag unpk str)) }
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 83599682e9..54f237c1d3 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -285,7 +285,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
   = data_con
   where
     data_con = mkDataCon dc_name declared_infix
-                (map (const HsLazy) arg_tys)
+                (map (const no_bang) arg_tys)
                 []      -- No labelled fields
                 tyvars
                 []      -- No existential type variables
@@ -297,6 +297,8 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
                 (mkDataConWorkId wrk_name data_con)
                 NoDataConRep    -- Wired-in types are too simple to need wrappers
 
+    no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
+
     modu     = ASSERT( isExternalName dc_name )
                nameModule dc_name
     wrk_occ  = mkDataConWorkerOcc (nameOccName dc_name)
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index e14796f96b..7c9882b028 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1488,13 +1488,10 @@ reifyFixity name
       conv_dir BasicTypes.InfixN = TH.InfixN
 
 reifyStrict :: DataCon.HsSrcBang -> TH.Strict
-reifyStrict HsLazy                                  = TH.NotStrict
-reifyStrict (HsSrcBang _ _         SrcLazy)         = TH.NotStrict
-reifyStrict (HsSrcBang _ _         NoSrcStrictness) = TH.NotStrict
-reifyStrict (HsSrcBang _ SrcUnpack SrcStrict)       = TH.Unpacked
-reifyStrict (HsSrcBang _ _         SrcStrict)       = TH.IsStrict
-reifyStrict HsStrict                                = TH.IsStrict
-reifyStrict (HsUnpack {})                           = TH.Unpacked
+reifyStrict (HsSrcBang _ _         SrcLazy)     = TH.NotStrict
+reifyStrict (HsSrcBang _ _         NoSrcStrict) = TH.NotStrict
+reifyStrict (HsSrcBang _ SrcUnpack SrcStrict)   = TH.Unpacked
+reifyStrict (HsSrcBang _ _         SrcStrict)   = TH.IsStrict
 
 ------------------------------
 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 3750be8d6b..2eb2dafa48 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1240,7 +1240,7 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl        -- Data types
            buildOneDataCon (L _ name) = do
              { is_infix <- tcConIsInfix name hs_details res_ty
              ; buildDataCon fam_envs name is_infix
-                            stricts field_lbls
+                            stricts Nothing field_lbls
                             univ_tvs ex_tvs eq_preds ctxt arg_tys
                             res_ty' rep_tycon
                   -- NB:  we put data_tc, the type constructor gotten from the
@@ -1660,8 +1660,8 @@ checkValidDataCon dflags existential_ok tc con
       = addWarnTc (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma")))
       where
         is_strict = case strict_mark of
-                      NoSrcStrictness -> xopt Opt_StrictData dflags
-                      bang            -> isSrcStrict bang
+                      NoSrcStrict -> xopt Opt_StrictData dflags
+                      bang        -> isSrcStrict bang
 
     check_bang _
       = return ()
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index e9a1133348..fc0192c744 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -79,7 +79,8 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
       fam_envs  <- readGEnv global_fam_inst_env
       liftDs $ buildDataCon fam_envs dc_name
                             False                  -- not infix
-                            (map (const HsLazy) comp_tys)
+                            (map (const no_bang) comp_tys)
+                            (Just $ map (const HsLazy) comp_tys)
                             []                     -- no field labels
                             tvs
                             []                     -- no existentials
@@ -88,6 +89,8 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
                             comp_tys
                             (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
                             repr_tc
+  where
+    no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
 
 
 -- buildPDatasTyCon -----------------------------------------------------------
@@ -118,7 +121,8 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
       fam_envs <- readGEnv global_fam_inst_env
       liftDs $ buildDataCon fam_envs dc_name
                             False                  -- not infix
-                            (map (const HsLazy) comp_tys)
+                            (map (const no_bang) comp_tys)
+                            (Just $ map (const HsLazy) comp_tys)
                             []                     -- no field labels
                             tvs
                             []                     -- no existentials
@@ -127,6 +131,8 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
                             comp_tys
                             (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
                             repr_tc
+  where
+     no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
 
 
 -- Utils ----------------------------------------------------------------------
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 0ef679d3ed..910aba473a 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -83,13 +83,13 @@ vectTyConDecl tycon name'
            -- return the type constructor of the vectorised class
        ; return tycon'
        }
-                      
+
        -- Regular algebraic type constructor — for now, Haskell 2011-style only
   | isAlgTyCon tycon
   = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
            do dflags <- getDynFlags
               cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
-  
+
            -- vectorise the data constructor of the class tycon
        ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
 
@@ -98,7 +98,7 @@ vectTyConDecl tycon name'
              gadt_flag = isGadtSyntaxTyCon tycon
 
            -- build the vectorised type constructor
-       ; return $ buildAlgTyCon 
+       ; return $ buildAlgTyCon
                     name'                   -- new name
                     (tyConTyVars tycon)     -- keep original type vars
                     (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
@@ -108,7 +108,7 @@ vectTyConDecl tycon name'
                     rec_flag                -- whether recursive
                     False                   -- Not promotable
                     gadt_flag               -- whether in GADT syntax
-                    NoParentTyCon           
+                    NoParentTyCon
        }
 
   -- some other crazy thing that we don't handle
@@ -185,6 +185,7 @@ vectDataCon dc
                     name'
                     (dataConIsInfix dc)            -- infix if the original is
                     (dataConSrcBangs dc)           -- strictness as original constructor
+                    (Just $ dataConImplBangs dc)
                     []                             -- no labelled fields for now
                     univ_tvs                       -- universally quantified vars
                     []                             -- no existential tvs for now
diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml
index b02650744e..386095e1d9 100644
--- a/docs/users_guide/7.12.1-notes.xml
+++ b/docs/users_guide/7.12.1-notes.xml
@@ -378,7 +378,17 @@
                 <para>
                     TODO FIXME.
                </para>
-           </listitem>
+            </listitem>
+            <listitem>
+              <para>
+                The <literal>HsBang</literal> type has been removed in
+                favour of <literal>HsSrcBang</literal> and
+                <literal>HsImplBang</literal>. Data constructors now
+                always carry around their strictness annotations as
+                the user wrote them, whether from an imported module
+                or not.
+              </para>
+            </listitem>
        </itemizedlist>
     </sect3>
 
diff --git a/utils/haddock b/utils/haddock
-Subproject 3436273f6e87d9358f6c23ad5b6b2838ce57389
+Subproject 62f3a12863121fa5b6c2787185e62cfa3f44bdd