Implementation of StrictData language extension
authorAdam Sandberg Eriksson <adam@sandbergericsson.se>
Mon, 27 Jul 2015 11:18:36 +0000 (13:18 +0200)
committerBen Gamari <ben@smart-cactus.org>
Mon, 27 Jul 2015 11:49:55 +0000 (13:49 +0200)
This implements the `StrictData` language extension, which lets the
programmer default to strict data fields in datatype declarations on a
per-module basis.

Specification and motivation can be found at
https://ghc.haskell.org/trac/ghc/wiki/StrictPragma

This includes a tricky parser change due to conflicts regarding `~` in
the type level syntax: all ~'s are parsed as strictness annotations (see
`strict_mark` in Parser.y) and then turned into equality constraints at
the appropriate places using `RdrHsSyn.splitTilde`.

Updates haddock submodule.

Test Plan: Validate through Harbormaster.

Reviewers: goldfire, austin, hvr, simonpj, tibbe, bgamari

Reviewed By: simonpj, tibbe, bgamari

Subscribers: lelf, simonpj, alanz, goldfire, thomie, bgamari, mpickering

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

GHC Trac Issues: #8347

24 files changed:
compiler/basicTypes/DataCon.hs
compiler/basicTypes/MkId.hs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsTypes.hs
compiler/iface/BuildTyCl.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/main/DynFlags.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/TysWiredIn.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/vectorise/Vectorise/Generic/PData.hs
docs/users_guide/flags.xml
docs/users_guide/glasgow_exts.xml
testsuite/tests/deSugar/should_run/DsStrictData.hs [new file with mode: 0644]
testsuite/tests/deSugar/should_run/DsStrictData.stdout [new file with mode: 0644]
testsuite/tests/deSugar/should_run/all.T
testsuite/tests/driver/T4437.hs
utils/haddock

index a70bcbd..51b8d78 100644 (file)
@@ -10,7 +10,8 @@
 module DataCon (
         -- * Main data types
         DataCon, DataConRep(..),
-        HsBang(..), HsSrcBang, HsImplBang,
+        HsBang(..), SrcStrictness(..), SrcUnpackedness(..),
+        HsSrcBang, HsImplBang,
         StrictnessMark(..),
         ConTag,
 
@@ -39,7 +40,7 @@ module DataCon (
         -- ** Predicates on DataCons
         isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
         isVanillaDataCon, classDataCon, dataConCannotMatch,
-        isBanged, isMarkedStrict, eqHsBang,
+        isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
 
         -- ** Promotion related functions
         promoteKind, promoteDataCon, promoteDataCon_maybe
@@ -348,12 +349,12 @@ data DataCon
         -- Now the strictness annotations and field labels of the constructor
         dcSrcBangs :: [HsBang],
                 -- See Note [Bangs on data constructor arguments]
-                -- For DataCons defined in this module: 
+                -- 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
-                -- 
+                --
                 -- Matches 1-1 with dcOrigArgTys
                 -- Hence length = dataConSourceArity dataCon
 
@@ -447,38 +448,53 @@ data DataConRep
 -- when we bring bits of unfoldings together.)
 
 -------------------------
--- HsBang describes the strictness/unpack status of one
+-- 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
-  = HsNoBang     -- Equivalent to (HsSrcBang Nothing False)
-
-  | HsSrcBang    -- What the user wrote in the source code
+  -- | 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
-       (Maybe Bool)       -- Just True    {-# UNPACK #-}
-                          -- Just False   {-# NOUNPACK #-}
-                          -- Nothing      no pragma
-       Bool               -- True <=> '!' specified
-       -- (HsSrcBang (Just True) False) makes no sense
-       -- We emit a warning (in checkValidDataCon) and treat it
-       -- just like (HsSrcBang Nothing False)
+       SrcUnpackedness
+       SrcStrictness
 
   -- Definite implementation commitments, generated by the compiler
-  -- after consulting HsSrcBang (if any), flags, etc
-  | HsUnpack              -- Definite commitment: this field is strict and unboxed
-       (Maybe Coercion)   --    co :: arg-ty ~ product-ty
+  -- 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
 
-  | HsStrict              -- Definite commitment: this field is strict but not unboxed
   deriving (Data.Data, Data.Typeable)
 
+-- | What strictness annotation the user wrote
+data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'
+                   | SrcStrict -- ^ Strict, ie '!'
+                   | NoSrcStrictness -- ^ no strictness annotation
+     deriving (Eq, Data.Data, Data.Typeable)
+
+-- | What unpackedness the user requested
+data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
+                     | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified
+                     | NoSrcUnpack -- ^ no unpack pragma
+     deriving (Eq, Data.Data, Data.Typeable)
+
+
 -- Two type-insecure, but useful, synonyms
-type HsSrcBang = HsBang   -- What the user wrote; hence always HsNoBang or HsSrcBang
 
-type HsImplBang = HsBang   -- A HsBang implementation decision,
-                           -- as determined by the compiler
-                           -- Never HsSrcBang
+-- | 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
@@ -492,38 +508,40 @@ Consider
 
 When compiling the module, GHC will decide how to represent
 MkT, depending on the optimisation level, and settings of
-flags like -funbox-small-strict-fields.  
+flags like -funbox-small-strict-fields.
 
 Terminology:
   * HsSrcBang:  What the user wrote
-                Constructors: HsNoBang, HsUserBang
+                Constructors: HsSrcBang
 
   * HsImplBang: What GHC decided
-                Constructors: HsNoBang, HsStrict, HsUnpack
+                Constructors: HsLazy, HsStrict, HsUnpack
 
-* If T was defined in this module, MkT's dcSrcBangs field 
+* If T was defined in this module, MkT's dcSrcBangs field
   records the [HsSrcBang] of what the user wrote; in the example
-    [ HsSrcBang Nothing True
-    , HsSrcBang (Just True) True
-    , HsNoBang]
+    [ HsSrcBang _ NoSrcUnpack SrcStrict
+    , 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 
+  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.
 
 * 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
-    [HsStrict, HsStrict, HsNoBang]
+    [HsStrict, HsStrict, HsLazy]
   With -O it might be
-    [HsStrict, HsUnpack, HsNoBang]
+    [HsStrict, HsUnpack _, HsLazy]
   With -funbox-small-strict-fields it might be
-    [HsUnpack, HsUnpack, HsNoBang]
+    [HsUnpack, HsUnpack _, HsLazy]
+  With -XStrictData it might be
+    [HsStrict, HsUnpack _, HsStrict]
 
 Note [Data con representation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The dcRepType field contains the type of the representation of a contructor
-This may differ from the type of the contructor *Id* (built
+This may differ from the type of the constructor *Id* (built
 by MkId.mkDataConId) for two reasons:
         a) the constructor Id may be overloaded, but the dictionary isn't stored
            e.g.    data Eq a => T a = MkT a a
@@ -578,35 +596,51 @@ instance Data.Data DataCon where
     dataTypeOf _ = mkNoRepType "DataCon"
 
 instance Outputable HsBang where
-    ppr HsNoBang                = empty
-    ppr (HsSrcBang _ prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
-    ppr (HsUnpack Nothing)      = ptext (sLit "Unpk")
-    ppr (HsUnpack (Just co))    = ptext (sLit "Unpk") <> parens (ppr co)
-    ppr HsStrict                = ptext (sLit "SrictNotUnpacked")
-
-pp_unpk :: Maybe Bool -> SDoc
-pp_unpk Nothing      = empty
-pp_unpk (Just True)  = ptext (sLit "{-# UNPACK #-}")
-pp_unpk (Just False) = ptext (sLit "{-# NOUNPACK #-}")
+    ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark
+    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
+
+instance Outputable SrcUnpackedness where
+    ppr SrcUnpack   = ptext (sLit "{-# UNPACK #-}")
+    ppr SrcNoUnpack = ptext (sLit "{-# NOUNPACK #-}")
+    ppr NoSrcUnpack = empty
 
 instance Outputable StrictnessMark where
   ppr MarkedStrict     = ptext (sLit "!")
   ppr NotMarkedStrict  = empty
 
 
+-- | Compare strictness annotations
 eqHsBang :: HsBang -> HsBang -> Bool
-eqHsBang HsNoBang             HsNoBang             = True
-eqHsBang HsStrict             HsStrict             = True
-eqHsBang (HsSrcBang _ u1 b1)  (HsSrcBang _ u2 b2)  = u1==u2 && b1==b2
-eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)   = True
-eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
-eqHsBang _ _ = False
-
-isBanged :: HsBang -> Bool
-isBanged HsNoBang             = False
-isBanged (HsSrcBang _ _ bang) = bang
-isBanged (HsUnpack {})        = True
-isBanged (HsStrict {})        = True
+eqHsBang (HsSrcBang _ u1 b1)  (HsSrcBang _ u2 b2) = u1==u2 && b1==b2
+eqHsBang HsLazy               HsLazy              = True
+eqHsBang HsStrict             HsStrict            = True
+eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)  = True
+eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))
+  = eqType (coercionType c1) (coercionType c2)
+eqHsBang _ _                                       = False
+
+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
+isSrcStrict _ = False
+
+isSrcUnpacked :: SrcUnpackedness -> Bool
+isSrcUnpacked SrcUnpack = True
+isSrcUnpacked _ = False
 
 isMarkedStrict :: StrictnessMark -> Bool
 isMarkedStrict NotMarkedStrict = False
@@ -622,22 +656,22 @@ 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 
-          -> [FieldLabel]       -- ^ Field labels for the constructor, if it is a record,
-                                --   otherwise empty
-          -> [TyVar]            -- ^ Universally quantified type variables
-          -> [TyVar]            -- ^ Existentially quantified type variables
-          -> [(TyVar,Type)]     -- ^ GADT equalities
-          -> ThetaType          -- ^ Theta-type occuring before the arguments proper
-          -> [Type]             -- ^ Original argument types
-          -> Type               -- ^ Original result type
-          -> TyCon              -- ^ Representation type constructor
-          -> ThetaType          -- ^ The "stupid theta", context of the data declaration
-                                --   e.g. @data Eq a => T a ...@
-          -> Id                 -- ^ Worker Id
-          -> DataConRep         -- ^ Representation
+          -> Bool           -- ^ Is the constructor declared infix?
+          -> [HsBang]       -- ^ Strictness/unpack annotations, from user; or,
+                            -- for imported DataCons, from the interface file
+          -> [FieldLabel]   -- ^ Field labels for the constructor,
+                            -- if it is a record, otherwise empty
+          -> [TyVar]        -- ^ Universally quantified type variables
+          -> [TyVar]        -- ^ Existentially quantified type variables
+          -> [(TyVar,Type)] -- ^ GADT equalities
+          -> ThetaType      -- ^ Theta-type occuring before the arguments proper
+          -> [Type]         -- ^ Original argument types
+          -> Type           -- ^ Original result type
+          -> TyCon          -- ^ Representation type constructor
+          -> ThetaType      -- ^ The "stupid theta", context of the data
+                            -- declaration e.g. @data Eq a => T a ...@
+          -> Id             -- ^ Worker Id
+          -> DataConRep     -- ^ Representation
           -> DataCon
   -- Can get the tag from the TyCon
 
@@ -835,7 +869,7 @@ dataConImplBangs :: DataCon -> [HsImplBang]
 -- source program argument to the data constructor
 dataConImplBangs dc
   = case dcRep dc of
-      NoDataConRep              -> replicate (dcSourceArity dc) HsNoBang
+      NoDataConRep              -> replicate (dcSourceArity dc) HsLazy
       DCR { dcr_bangs = bangs } -> bangs
 
 dataConBoxer :: DataCon -> Maybe DataConBoxer
index 4edf268..bdcaf72 100644 (file)
@@ -490,7 +490,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
              wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
              wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
              mk_dmd str | isBanged str = evalDmd
-                        | otherwise    = topDmd
+                        | otherwise           = topDmd
                  -- The Cpr info can be important inside INLINE rhss, where the
                  -- wrapper constructor isn't inlined.
                  -- And the argument strictness can be important too; we
@@ -534,9 +534,9 @@ mkDataConRep dflags fam_envs wrap_name data_con
     (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
 
     wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
-                && (any isBanged orig_bangs   -- Some forcing/unboxing
-                                              -- (includes eq_spec)
-                    || isFamInstTyCon tycon)  -- Cast result
+                && (any isBanged wrap_bangs -- Some forcing/unboxing
+                                            -- (includes eq_spec)
+                    || isFamInstTyCon tycon) -- Cast result
 
     initial_wrap_app = Var (dataConWorkId data_con)
                       `mkTyApps`  res_ty_args
@@ -593,34 +593,42 @@ dataConArgRep
       , [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
 
-dataConArgRep _ _ arg_ty HsNoBang
-  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+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)
 
-dataConArgRep _ _ arg_ty (HsSrcBang _ _ False)  -- No '!'
-  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+  | otherwise                  -- no StrictData => lazy field
+  = (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+
+dataConArgRep _ _ arg_ty (HsSrcBang _ _ SrcLazy)
+  = (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
 dataConArgRep dflags fam_envs arg_ty
-    (HsSrcBang _ unpk_prag True)  -- {-# UNPACK #-} !
+    (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,
           -- we use -fomit-iface-pragmas as the indication
   , let mb_co   = topNormaliseType_maybe fam_envs arg_ty
                      -- Unwrap type families and newtypes
         arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
-  , isUnpackableType fam_envs arg_ty'
+  , isUnpackableType dflags fam_envs arg_ty'
   , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
   , case unpk_prag of
-      Nothing -> gopt Opt_UnboxStrictFields dflags
-              || (gopt Opt_UnboxSmallStrictFields dflags
-                   && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
-      Just unpack_me -> unpack_me
+      NoSrcUnpack ->
+        gopt Opt_UnboxStrictFields dflags
+            || (gopt Opt_UnboxSmallStrictFields dflags
+                && 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)
 
-  | otherwise  -- Record the strict-but-no-unpack decision
+  | otherwise -- Record the strict-but-no-unpack decision
   = strict_but_not_unpacked arg_ty
 
+dataConArgRep _ _ arg_ty HsLazy
+  = (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+
 dataConArgRep _ _ arg_ty HsStrict
   = strict_but_not_unpacked arg_ty
 
@@ -695,13 +703,13 @@ dataConArgUnpack arg_ty
   = pprPanic "dataConArgUnpack" (ppr arg_ty)
     -- An interface file specified Unpacked, but we couldn't unpack it
 
-isUnpackableType :: FamInstEnvs -> Type -> Bool
+isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
 -- True if we can 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 fam_envs ty
+isUnpackableType dflags fam_envs ty
   | Just (tc, _) <- splitTyConApp_maybe ty
   , Just con <- tyConSingleAlgDataCon_maybe tc
   , isVanillaDataCon con
@@ -728,11 +736,21 @@ isUnpackableType 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 (HsSrcBang _ (Just unpk) bang) = bang && unpk
-    attempt_unpack (HsSrcBang _  Nothing bang)     = bang  -- Be conservative
-    attempt_unpack HsStrict                       = False
-    attempt_unpack HsNoBang                       = False
+    attempt_unpack (HsUnpack {})
+      = True
+    attempt_unpack HsStrict
+      = False
+    attempt_unpack HsLazy
+      = False
+    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrictness)
+      = xopt Opt_StrictData dflags
+    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
+      = True
+    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)
+      = True  -- Be conservative
+    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrictness)
+      = xopt Opt_StrictData dflags -- Be conservative
+    attempt_unpack _ = False
 
 {-
 Note [Unpack one-wide fields]
@@ -797,10 +815,10 @@ heavy lifting.  This one line makes every GADT take a word less
 space for each equality predicate, so it's pretty important!
 -}
 
-mk_pred_strict_mark :: PredType -> HsSrcBang
+mk_pred_strict_mark :: PredType -> HsImplBang
 mk_pred_strict_mark pred
   | isEqPred pred = HsUnpack Nothing    -- Note [Unpack equality predicates]
-  | otherwise     = HsNoBang
+  | otherwise     = HsLazy
 
 {-
 ************************************************************************
index d4a811f..c222b33 100644 (file)
@@ -648,15 +648,17 @@ mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
 
 
 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
-repBangTy ty= do
+repBangTy ty = do
   MkC s <- rep2 str []
   MkC t <- repLTy ty'
   rep2 strictTypeName [s, t]
   where
     (str, ty') = case ty of
-         L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName,  ty)
-         L _ (HsBangTy (HsSrcBang _ _     True) ty)       -> (isStrictName,  ty)
-         _                                                -> (notStrictName, ty)
+         L _ (HsBangTy (HsSrcBang _ SrcUnpack SrcStrict) ty)
+           -> (unpackedName,  ty)
+         L _ (HsBangTy (HsSrcBang _ _         SrcStrict) ty)
+           -> (isStrictName,  ty)
+         _ -> (notStrictName, ty)
 
 -------------------------------------------------------
 --                      Deriving clause
@@ -2129,5 +2131,3 @@ notHandled what doc = failWithDs msg
   where
     msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
              2 doc
-
-
index 4a0e013..d4a0b54 100644 (file)
@@ -438,10 +438,10 @@ cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 cvt_arg (NotStrict, ty) = cvtType ty
 cvt_arg (IsStrict,  ty)
   = do { ty' <- cvtType ty
-       ; returnL $ HsBangTy (HsSrcBang Nothing Nothing     True) ty' }
+       ; returnL $ HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcStrict) ty' }
 cvt_arg (Unpacked,  ty)
   = do { ty' <- cvtType ty
-       ; returnL $ HsBangTy (HsSrcBang Nothing (Just True) True) ty' }
+       ; returnL $ HsBangTy (HsSrcBang Nothing SrcUnpack   SrcStrict) ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
index 9526a8c..e123277 100644 (file)
@@ -29,6 +29,7 @@ module HsTypes (
         HsIPName(..), hsIPNameFS,
 
         LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang,
+        SrcStrictness(..), SrcUnpackedness(..),
         getBangType, getBangStrictness,
 
         ConDeclField(..), LConDeclField, pprConDeclFields,
@@ -62,7 +63,8 @@ import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
 
 import Name( Name )
 import RdrName( RdrName )
-import DataCon( HsBang(..), HsSrcBang, HsImplBang )
+import DataCon( HsBang(..), HsSrcBang, HsImplBang,
+                SrcStrictness(..), SrcUnpackedness(..) )
 import TysPrim( funTyConName )
 import Type
 import HsDoc
@@ -97,7 +99,7 @@ getBangType ty                    = ty
 
 getBangStrictness :: LHsType a -> HsSrcBang
 getBangStrictness (L _ (HsBangTy s _)) = s
-getBangStrictness _                    = HsNoBang
+getBangStrictness _ = HsSrcBang Nothing NoSrcUnpack NoSrcStrictness
 
 {-
 ************************************************************************
index b6db5dc..28a5f68 100644 (file)
@@ -272,7 +272,7 @@ 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 HsNoBang) args)
+                                   (map (const HsLazy) args)
                                    [{- No fields -}]
                                    tvs [{- no existentials -}]
                                    [{- No GADT equalities -}]
index 753c81a..2b8a212 100644 (file)
@@ -1728,7 +1728,7 @@ tyConToIfaceDecl env tycon
           to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
 toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
-toIfaceBang _    HsNoBang            = IfNoBang
+toIfaceBang _    HsLazy              = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
 toIfaceBang _   HsStrict             = IfStrict
index a7c340f..3e97747 100644 (file)
@@ -542,9 +542,9 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
 
         ; 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
+                       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
@@ -554,7 +554,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
     tc_strict :: IfaceBang -> IfL HsImplBang
-    tc_strict IfNoBang = return HsNoBang
+    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
index 74e9bf3..35e5dc5 100644 (file)
@@ -653,6 +653,7 @@ data ExtensionFlag
    | Opt_PartialTypeSignatures
    | Opt_NamedWildCards
    | Opt_StaticPointers
+   | Opt_StrictData
    deriving (Eq, Enum, Show)
 
 type SigOf = Map ModuleName Module
@@ -3207,6 +3208,7 @@ xFlags = [
   flagSpec "ScopedTypeVariables"              Opt_ScopedTypeVariables,
   flagSpec "StandaloneDeriving"               Opt_StandaloneDeriving,
   flagSpec "StaticPointers"                   Opt_StaticPointers,
+  flagSpec "StrictData"                       Opt_StrictData,
   flagSpec' "TemplateHaskell"                 Opt_TemplateHaskell
                                               setTemplateHaskellLoc,
   flagSpec "TraditionalRecordSyntax"          Opt_TraditionalRecordSyntax,
index 99abf16..815c8cb 100644 (file)
@@ -1566,18 +1566,21 @@ sigtypes1 :: { (OrdList (LHsType RdrName)) }      -- Always HsForAllTys
 -- Types
 
 strict_mark :: { Located ([AddAnn],HsBang) }
-        : '!'                        { sL1 $1 ([mj AnnBang $1]
-                                              ,HsSrcBang Nothing                       Nothing      True) }
-        | '{-# UNPACK' '#-}'         { sLL $1 $> ([mo $1,mc $2]
-                                              ,HsSrcBang (Just $ getUNPACK_PRAGs $1)   (Just True)  False) }
-        | '{-# NOUNPACK' '#-}'       { sLL $1 $> ([mo $1,mc $2]
-                                              ,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) False) }
-        | '{-# UNPACK' '#-}' '!'     { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3]
-                                              ,HsSrcBang (Just $ getUNPACK_PRAGs $1)   (Just True)  True) }
-        | '{-# NOUNPACK' '#-}' '!'   { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3]
-                                              ,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) True) }
-        -- Although UNPACK with no '!' is illegal, we get a
-        -- better error message if we parse it here
+        : 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 strictness { sLL $1 $> (let { (a, prag, unpk) = unLoc $1
+                                                   ; (a', str) = unLoc $2 }
+                                                in (a ++ a', HsSrcBang prag unpk str)) }
+        -- Although UNPACK with no '!' without StrictData and UNPACK with '~' are illegal,
+        -- we get a better error message if we parse them here
+
+strictness :: { Located ([AddAnn], SrcStrictness) }
+        : '!' { sL1 $1 ([mj AnnBang $1], SrcStrict) }
+        | '~' { sL1 $1 ([mj AnnTilde $1], SrcLazy) }
+
+unpackedness :: { Located ([AddAnn], Maybe SourceText, SrcUnpackedness) }
+        : '{-# UNPACK' '#-}'   { sLL $1 $> ([mo $1, mc $2], Just $ getUNPACK_PRAGs $1, SrcUnpack) }
+        | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], Just $ getNOUNPACK_PRAGs $1, SrcNoUnpack) }
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
@@ -1626,47 +1629,39 @@ ctypedoc :: { LHsType RdrName }
 -- to permit an individual equational constraint without parenthesis.
 -- Thus for some reason we allow    f :: a~b => blah
 -- but not                          f :: ?x::Int => blah
+-- See Note [Parsing ~]
 context :: { LHsContext RdrName }
-        : btype '~'      btype          {% do { (anns,ctx) <- checkContext
-                                                 (sLL $1 $> $ HsEqTy $1 $3)
-                                              ; ams ctx (mj AnnTilde $2:anns) } }
-        | btype                         {% do { (anns,ctx) <- checkContext $1
-                                              ; if null (unLoc ctx)
-                                                 then addAnnotation (gl $1) AnnUnit (gl $1)
-                                                 else return ()
-                                              ; ams ctx anns
-                                              } }
-
+        :  btype                        {% do { (anns,ctx) <- checkContext (splitTilde $1)
+                                                ; if null (unLoc ctx)
+                                                   then addAnnotation (gl $1) AnnUnit (gl $1)
+                                                   else return ()
+                                                ; ams ctx anns
+                                                } }
+-- See Note [Parsing ~]
 type :: { LHsType RdrName }
-        : btype                         { $1 }
+        : btype                         { splitTilde $1 }
         | btype qtyconop type           { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
         | btype tyvarop  type           { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
         | btype '->'     ctype          {% ams $1 [mj AnnRarrow $2]
-                                        >> ams (sLL $1 $> $ HsFunTy $1 $3)
+                                        >> ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3)
                                                [mj AnnRarrow $2] }
-        | btype '~'      btype          {% ams (sLL $1 $> $ HsEqTy $1 $3)
-                                               [mj AnnTilde $2] }
-                                        -- see Note [Promotion]
         | btype SIMPLEQUOTE qconop type  {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
                                                 [mj AnnSimpleQuote $2] }
         | btype SIMPLEQUOTE varop  type  {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
                                                 [mj AnnSimpleQuote $2] }
-
+-- See Note [Parsing ~]
 typedoc :: { LHsType RdrName }
-        : btype                          { $1 }
-        | btype docprev                  { sLL $1 $> $ HsDocTy $1 $2 }
+        : btype                          { splitTilde $1 }
+        | btype docprev                  { sLL $1 $> $ HsDocTy (splitTilde $1) $2 }
         | btype qtyconop type            { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
         | btype qtyconop type docprev    { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
         | btype tyvarop  type            { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
         | btype tyvarop  type docprev    { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
-        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy $1 $3)
+        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3)
                                                 [mj AnnRarrow $2] }
-        | btype docprev '->' ctypedoc    {% ams (sLL $1 $> $ HsFunTy (L (comb2 $1 $2)
+        | btype docprev '->' ctypedoc    {% ams (sLL $1 $> $ HsFunTy (L (comb2 (splitTilde $1) $2)
                                                             (HsDocTy $1 $2)) $4)
                                                 [mj AnnRarrow $3] }
-        | btype '~'      btype           {% ams (sLL $1 $> $ HsEqTy $1 $3)
-                                                [mj AnnTilde $2] }
-                                        -- see Note [Promotion]
         | btype SIMPLEQUOTE qconop type  {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
                                                 [mj AnnSimpleQuote $2] }
         | btype SIMPLEQUOTE varop  type  {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
@@ -1791,6 +1786,23 @@ varids0 :: { Located [Located RdrName] }
         : {- empty -}                   { noLoc [] }
         | varids0 tyvar                 { sLL $1 $> ($2 : unLoc $1) }
 
+{-
+Note [Parsing ~]
+~~~~~~~~~~~~~~~~
+
+Due to parsing conflicts between lazyness annotations in data type
+declarations (see strict_mark) and equality types ~'s are always
+parsed as lazyness annotations, and turned into HsEqTy's in the
+correct places using RdrHsSyn.splitTilde.
+
+Since strict_mark is parsed as part of atype which is part of type,
+typedoc and context (where HsEqTy previously appeared) it made most
+sense and was simplest to parse ~ as part of strict_mark and later
+turn them into HsEqTy's.
+
+-}
+
+
 -----------------------------------------------------------------------------
 -- Kinds
 
index aa0b8cf..357512b 100644 (file)
@@ -52,6 +52,7 @@ module RdrHsSyn (
         checkDoAndIfThenElse,
         checkRecordSyntax,
         parseErrorSDoc,
+        splitTilde,
 
         -- Help with processing exports
         ImpExpSubSpec(..),
@@ -1059,6 +1060,21 @@ isFunLhs e = go e [] []
    go _ _ _ = return Nothing
 
 
+-- | Transform btype with strict_mark's into HsEqTy's
+-- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
+splitTilde :: LHsType RdrName -> LHsType RdrName
+splitTilde t = go t
+  where go (L loc (HsAppTy t1 t2))
+          | L _ (HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcLazy) t2') <- t2
+          = L loc (HsEqTy (go t1) t2')
+          | otherwise
+          = case go t1 of
+              (L _ (HsEqTy tl tr)) ->
+                L loc (HsEqTy tl (L (combineLocs tr t2) (HsAppTy tr t2)))
+              t -> L loc (HsAppTy t t2)
+
+        go t = t
+
 ---------------------------------------------------------------------------
 -- Check for monad comprehensions
 --
index f7d08ff..8359968 100644 (file)
@@ -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 HsNoBang) arg_tys)
+                (map (const HsLazy) arg_tys)
                 []      -- No labelled fields
                 tyvars
                 []      -- No existential type variables
index cc09d23..605ba57 100644 (file)
@@ -1371,7 +1371,7 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
       = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl)
            ; return Nothing }
 
-checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
+checkMissingFields ::  DataCon -> HsRecordBinds Name -> TcM ()
 checkMissingFields data_con rbinds
   | null field_labels   -- Not declared as a record;
                         -- But C{} is still valid if no strict fields
@@ -1408,7 +1408,7 @@ checkMissingFields data_con rbinds
                           field_labels
                           field_strs
 
-    field_strs = dataConSrcBangs data_con
+    field_strs = dataConImplBangs data_con
 
 {-
 ************************************************************************
index c46a217..010a679 100644 (file)
@@ -838,8 +838,8 @@ checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
                -> TyThing -> TyThing -> TcM ()
 checkBootDeclM is_boot boot_thing real_thing
   = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err ->
-    addErrAt (nameSrcSpan (getName boot_thing))
-             (bootMisMatch is_boot err real_thing boot_thing)
+       addErrAt (nameSrcSpan (getName boot_thing))
+                (bootMisMatch is_boot err real_thing boot_thing)
 
 -- | Compares the two things for equivalence between boot-file and normal
 -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
@@ -1017,8 +1017,7 @@ checkBootTyCon tc1 tc2
          check (dataConIsInfix c1 == dataConIsInfix c2)
                (text "The fixities of" <+> pname1 <+>
                 text "differ") `andThenCheck`
-         check (eqListBy eqHsBang
-                         (dataConSrcBangs c1) (dataConSrcBangs c2))
+         check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))
                (text "The strictness annotations for" <+> pname1 <+>
                 text "differ") `andThenCheck`
          check (dataConFieldLabels c1 == dataConFieldLabels c2)
index d8dde33..4a414a2 100644 (file)
@@ -1490,12 +1490,13 @@ reifyFixity name
       conv_dir BasicTypes.InfixN = TH.InfixN
 
 reifyStrict :: DataCon.HsSrcBang -> TH.Strict
-reifyStrict HsNoBang                       = TH.NotStrict
-reifyStrict (HsSrcBang _ _ False)          = TH.NotStrict
-reifyStrict (HsSrcBang _ (Just True) True) = TH.Unpacked
-reifyStrict (HsSrcBang _ _     True)       = TH.IsStrict
-reifyStrict HsStrict                       = TH.IsStrict
-reifyStrict (HsUnpack {})                  = TH.Unpacked
+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
 
 ------------------------------
 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
index 9c14055..b7a959e 100644 (file)
@@ -1613,15 +1613,24 @@ checkValidDataCon dflags existential_ok tc con
     }
   where
     ctxt = ConArgCtxt (dataConName con)
-    check_bang (HsSrcBang _ (Just want_unpack) has_bang, rep_bang, n)
-      | want_unpack, not has_bang
+
+    check_bang (HsSrcBang _ _ SrcLazy, _, n)
+      | not (xopt Opt_StrictData dflags)
+      = addErrTc
+          (bad_bang n (ptext (sLit "Lazy annotation (~) without StrictData")))
+    check_bang (HsSrcBang _ want_unpack strict_mark, rep_bang, n)
+      | isSrcUnpacked want_unpack, not is_strict
       = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'")))
-      | want_unpack
+      | isSrcUnpacked want_unpack
       , case rep_bang of { HsUnpack {} -> False; _ -> True }
       , not (gopt Opt_OmitInterfacePragmas dflags)
            -- If not optimising, se don't unpack, so don't complain!
            -- See MkId.dataConArgRep, the (HsBang True) case
       = 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
 
     check_bang _
       = return ()
@@ -1634,7 +1643,7 @@ checkNewDataCon :: DataCon -> TcM ()
 -- Further checks for the data constructor of a newtype
 checkNewDataCon con
   = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
-                -- One argument
+              -- One argument
 
         ; check_con (null eq_spec) $
           ptext (sLit "A newtype constructor must have a return type of form T a1 ... an")
@@ -1647,15 +1656,20 @@ checkNewDataCon con
           ptext (sLit "A newtype constructor cannot have existential type variables")
                 -- No existentials
 
-        ; checkTc (not (any isBanged (dataConSrcBangs con)))
+        ; checkTc (all ok_bang (dataConSrcBangs con))
                   (newtypeStrictError con)
-                -- No strictness
+                -- No strictness annotations
     }
   where
     (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
+
     check_con what msg
        = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))
 
+    ok_bang (HsSrcBang _ _ SrcStrict) = False
+    ok_bang (HsSrcBang _ _ SrcLazy)   = False
+    ok_bang _                         = True
+
 -------------------------------
 checkValidClass :: Class -> TcM ()
 checkValidClass cls
@@ -1704,7 +1718,7 @@ checkValidClass cls
                 -- Here, MonadState has a fundep m->b, so newBoard is fine
 
         ; unless constrained_class_methods $
-          mapM_ check_constraint (tail (theta1 ++ theta2)) 
+          mapM_ check_constraint (tail (theta1 ++ theta2))
 
         ; case dm of
             GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
@@ -2164,7 +2178,7 @@ classFunDepsErr cls
 
 badMethPred :: Id -> TcPredType -> SDoc
 badMethPred sel_id pred
-  = vcat [ hang (ptext (sLit "Constraint") <+> quotes (ppr pred) 
+  = vcat [ hang (ptext (sLit "Constraint") <+> quotes (ppr pred)
                  <+> ptext (sLit "in the type of") <+> quotes (ppr sel_id))
               2 (ptext (sLit "constrains only the class type variables"))
          , ptext (sLit "Use ConstrainedClassMethods to allow it") ]
index ed127b4..e9a1133 100644 (file)
@@ -5,7 +5,7 @@
 --   We should be able to factor out the common parts.
 module Vectorise.Generic.PData
   ( buildPDataTyCon
-  , buildPDatasTyCon ) 
+  , buildPDatasTyCon )
 where
 
 import Vectorise.Monad
@@ -31,7 +31,7 @@ import Control.Monad
 -- buildPDataTyCon ------------------------------------------------------------
 -- | Build the PData instance tycon for a given type constructor.
 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
-buildPDataTyCon orig_tc vect_tc repr 
+buildPDataTyCon orig_tc vect_tc repr
  = fixV $ \fam_inst ->
    do let repr_tc = dataFamInstRepTyCon fam_inst
       name' <- mkLocalisedName mkPDataTyConOcc orig_name
@@ -79,7 +79,7 @@ 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 HsNoBang) comp_tys)
+                            (map (const HsLazy) comp_tys)
                             []                     -- no field labels
                             tvs
                             []                     -- no existentials
@@ -93,7 +93,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
 -- buildPDatasTyCon -----------------------------------------------------------
 -- | Build the PDatas instance tycon for a given type constructor.
 buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
-buildPDatasTyCon orig_tc vect_tc repr 
+buildPDatasTyCon orig_tc vect_tc repr
  = fixV $ \fam_inst ->
    do let repr_tc = dataFamInstRepTyCon fam_inst
       name'       <- mkLocalisedName mkPDatasTyConOcc orig_name
@@ -118,7 +118,7 @@ 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 HsNoBang) comp_tys)
+                            (map (const HsLazy) comp_tys)
                             []                     -- no field labels
                             tvs
                             []                     -- no existentials
@@ -131,7 +131,7 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
 
 -- Utils ----------------------------------------------------------------------
 -- | Flatten a SumRepr into a list of data constructor types.
-mkSumTys 
+mkSumTys
         :: (SumRepr -> Type)
         -> (Type -> VM Type)
         -> SumRepr
@@ -158,4 +158,3 @@ mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
 mk_fam_inst fam_tc arg_tc
   = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
 -}
-
index c918600..39b4872 100644 (file)
         <tbody>
           <row>
             <entry><option>-fconstraint-solver-iterations=</option><replaceable>n</replaceable></entry>
-           <entry>Set the iteration limit for the type-constraint solver. 
+            <entry>Set the iteration limit for the type-constraint solver.
                    The default limit is 4. Typically one iteration
                    suffices; so please yell if you find you need to set
                    it higher than the default. Zero means infinity. </entry>
          </row>
           <row>
             <entry><option>-freduction-depth=</option><replaceable>n</replaceable></entry>
-           <entry>Set the <link linkend="undecidable-instances">limit for type simplification</link>. 
+           <entry>Set the <link linkend="undecidable-instances">limit for type simplification</link>.
                    Default is 200; zero means infinity.</entry>
            <entry>dynamic</entry>
            <entry></entry>
           </row>
           <row>
             <entry><option>-XRelaxedPolyRec</option></entry>
-            <entry><emphasis>(deprecated)</emphasis> Relaxed checking for 
+            <entry><emphasis>(deprecated)</emphasis> Relaxed checking for
               <link linkend="typing-binds">mutually-recursive polymorphic functions</link>.</entry>
             <entry>dynamic</entry>
             <entry><option>-XNoRelaxedPolyRec</option></entry>
             <entry>6.8.1</entry>
           </row>
           <row>
+            <entry><option>-XStrictData</option></entry>
+            <entry>Enable <link linkend="strict-data">default strict datatype fields</link>.</entry>
+            <entry>dynamic</entry>
+            <entry><option>-XNoStrictData</option></entry>
+          </row>
+          <row>
             <entry><option>-XTemplateHaskell</option></entry>
             <entry>Enable <link linkend="template-haskell">Template Haskell</link>.</entry>
             <entry>dynamic</entry>
index 9685b1d..e3368f2 100644 (file)
@@ -1114,7 +1114,7 @@ on <literal>MkT</literal>. But the same pattern match also <emphasis>provides</e
 </para>
 <para>
 Exactly the same reasoning applies to <literal>ExNumPat</literal>:
-matching against <literal>ExNumPat</literal> <emphasis>requires</emphasis> 
+matching against <literal>ExNumPat</literal> <emphasis>requires</emphasis>
 the constraints <literal>(Num a, Eq a)</literal>, and <emphasis>provides</emphasis>
 the constraint <literal>(Show b)</literal>.
 </para>
@@ -4707,7 +4707,7 @@ class type variable (in this case <literal>a</literal>).
 </para>
 <para>
 GHC lifts this restriction with language extension <option>-XConstrainedClassMethods</option>.
-The restriction is a pretty stupid one in the first place, 
+The restriction is a pretty stupid one in the first place,
 so <option>-XConstrainedClassMethods</option> is implied by <option>-XMultiParamTypeClasses</option>.
 </para>
 </sect3>
@@ -5235,7 +5235,7 @@ termination: see <xref linkend="instance-termination"/>.
 <para>
 Regardless of <option>-XFlexibleInstances</option> and <option>-XFlexibleContexts</option>,
 instance declarations must conform to some rules that ensure that instance resolution
-will terminate.  The restrictions can be lifted with <option>-XUndecidableInstances</option> 
+will terminate.  The restrictions can be lifted with <option>-XUndecidableInstances</option>
 (see <xref linkend="undecidable-instances"/>).
 </para>
 <para>
@@ -6908,8 +6908,8 @@ T :: (k -> *) -> k -> *
 </para></listitem>
 
 <listitem><para>
-GHC does not usually print explicit <literal>forall</literal>s, including kind <literal>forall</literal>s. 
-You can make GHC show them explicitly with <option>-fprint-explicit-foralls</option> 
+GHC does not usually print explicit <literal>forall</literal>s, including kind <literal>forall</literal>s.
+You can make GHC show them explicitly with <option>-fprint-explicit-foralls</option>
 (see <xref linkend="options-help"/>):
 <programlisting>
 ghci> :set -XPolyKinds
@@ -6981,7 +6981,7 @@ very convenient, and it is not clear what the syntax for explicit quantification
 Generally speaking, when <option>-XPolyKinds</option> is on, GHC tries to infer the most
 general kind for a declaration.  For example:
 <programlisting>
-data T f a = MkT (f a)   -- GHC infers:  
+data T f a = MkT (f a)   -- GHC infers:
                          -- T :: forall k. (k->*) -> k -> *
 </programlisting>
 In this case the definition has a right-hand side to inform kind inference.
@@ -6990,9 +6990,9 @@ But that is not always the case.  Consider
 type family F a
 </programlisting>
 Type family declarations have no right-hand side, but GHC must still infer a kind
-for <literal>F</literal>.  Since there are no constraints, it could infer 
-<literal>F :: forall k1 k2. k1 -> k2</literal>, but that seems <emphasis>too</emphasis> 
-polymorphic.  So GHC defaults those entirely-unconstrained kind variables to <literal>*</literal> and 
+for <literal>F</literal>.  Since there are no constraints, it could infer
+<literal>F :: forall k1 k2. k1 -> k2</literal>, but that seems <emphasis>too</emphasis>
+polymorphic.  So GHC defaults those entirely-unconstrained kind variables to <literal>*</literal> and
 we get <literal>F :: * -> *</literal>.  You can still declare <literal>F</literal> to be
 kind-polymorphic using kind signatures:
 <programlisting>
@@ -7014,23 +7014,23 @@ by the class method signatures.
 </para></listitem>
 <listitem><para>
 <emphasis>When there is no right hand side, GHC defaults argument and result kinds to <literal>*</literal>,
-except when directed otherwise by a kind signature</emphasis>.  
+except when directed otherwise by a kind signature</emphasis>.
 Examples: data and type family declarations.
 </para></listitem>
 </itemizedlist>
-This rule has occasionally-surprising consequences 
+This rule has occasionally-surprising consequences
 (see <ulink url="https://ghc.haskell.org/trac/ghc/ticket/10132">Trac 10132</ulink>).
 <programlisting>
 class C a where    -- Class declarations are generalised
                    -- so C :: forall k. k -> Constraint
-  data D1 a        -- No right hand side for these two family 
+  data D1 a        -- No right hand side for these two family
   type F1 a        -- declarations, but the class forces (a :: k)
                    -- so   D1, F1 :: forall k. k -> *
 
 data D2 a   -- No right-hand side so D2 :: * -> *
 type F2 a   -- No right-hand side so F2 :: * -> *
 </programlisting>
-The kind-polymorphism from the class declaration makes <literal>D1</literal> 
+The kind-polymorphism from the class declaration makes <literal>D1</literal>
 kind-polymorphic, but not so <literal>D2</literal>; and similarly <literal>F1</literal>, <literal>F1</literal>.
 </para>
 </sect2>
@@ -8500,7 +8500,7 @@ for rank-2 types.
 <title>Impredicative polymorphism
 </title>
 <para>In general, GHC will only instantiate a polymorphic function at
-a monomorphic type (one with no foralls). For example, 
+a monomorphic type (one with no foralls). For example,
 <programlisting>
 runST :: (forall s. ST s a) -> a
 id :: forall b. b -> b
@@ -13303,10 +13303,48 @@ Here are some examples:</para>
 
 </sect1>
 
+<sect1 id="strict-haskell">
+  <title>Strict Haskell</title>
+  <indexterm><primary>strict haskell</primary></indexterm>
+
+  <para>High-performance Haskell code (e.g. numeric code) can
+  sometimes be littered with bang patterns, making it harder to
+  read. The reason is that lazy evaluation isn't the right default in
+  this particular code but the programmer has no way to say that
+  except by repeatedly adding bang patterns. Below
+  <option>-XStrictData</option> is detailed that allows the programmer
+  to switch the default behavior on a per-module basis.</para>
+
+  <sect2 id="strict-data">
+    <title>Strict-by-default data types</title>
+
+    <para>Informally the <literal>StrictData</literal> language
+    extension switches data type declarations to be strict by default
+    allowing fields to be lazy by adding a <literal>~</literal> in
+    front of the field.</para>
+
+    <para>When the user writes</para>
+
+    <programlisting>
+      data T = C a
+      data T' = C' ~a
+    </programlisting>
+
+    <para>we interpret it as if she had written</para>
+
+    <programlisting>
+      data T = C !a
+      data T' = C' a
+    </programlisting>
+
+    <para>The extension only affects definitions in this module.</para>
+  </sect2>
+
+</sect1>
+
 <!-- Emacs stuff:
      ;;; Local Variables: ***
      ;;; sgml-parent-document: ("users_guide.xml" "book" "chapter" "sect1") ***
      ;;; ispell-local-dictionary: "british" ***
      ;;; End: ***
  -->
-
diff --git a/testsuite/tests/deSugar/should_run/DsStrictData.hs b/testsuite/tests/deSugar/should_run/DsStrictData.hs
new file mode 100644 (file)
index 0000000..f1898a5
--- /dev/null
@@ -0,0 +1,48 @@
+{-# LANGUAGE ScopedTypeVariables, StrictData, GADTs #-}
+
+-- | Tests the StrictData LANGUAGE pragma.
+module Main where
+
+import qualified Control.Exception as E
+import System.IO.Unsafe (unsafePerformIO)
+
+data Strict a = S a
+data Strict2 b = S2 !b
+data Strict3 c where
+  S3 :: c -> Strict3 c
+
+data UStrict = US {-# UNPACK #-} Int
+
+data Lazy d = L ~d
+data Lazy2 e where
+  L2 :: ~e -> Lazy2 e
+
+main :: IO ()
+main =
+  do print (isBottom (S bottom))
+     print (isBottom (S2 bottom))
+     print (isBottom (US bottom))
+     print (isBottom (S3 bottom))
+     putStrLn ""
+     print (not (isBottom (L bottom)))
+     print (not (isBottom (L2 bottom)))
+     print (not (isBottom (Just bottom))) -- sanity check
+
+------------------------------------------------------------------------
+-- Support for testing for bottom
+
+bottom :: a
+bottom = error "_|_"
+
+isBottom :: a -> Bool
+isBottom f = unsafePerformIO $
+  (E.evaluate f >> return False) `E.catches`
+    [ E.Handler (\(_ :: E.ArrayException)   -> return True)
+    , E.Handler (\(_ :: E.ErrorCall)        -> return True)
+    , E.Handler (\(_ :: E.NoMethodError)    -> return True)
+    , E.Handler (\(_ :: E.NonTermination)   -> return True)
+    , E.Handler (\(_ :: E.PatternMatchFail) -> return True)
+    , E.Handler (\(_ :: E.RecConError)      -> return True)
+    , E.Handler (\(_ :: E.RecSelError)      -> return True)
+    , E.Handler (\(_ :: E.RecUpdError)      -> return True)
+    ]
diff --git a/testsuite/tests/deSugar/should_run/DsStrictData.stdout b/testsuite/tests/deSugar/should_run/DsStrictData.stdout
new file mode 100644 (file)
index 0000000..b34f35d
--- /dev/null
@@ -0,0 +1,8 @@
+True
+True
+True
+True
+
+True
+True
+True
index 5787816..228b90d 100644 (file)
@@ -47,3 +47,4 @@ test('DsStaticPointers',
      compile_and_run, [''])
 test('T8952', normal, compile_and_run, [''])
 test('T9844', normal, compile_and_run, [''])
+test('DsStrictData', normal, compile_and_run, [''])
index dde6da7..3c6de35 100644 (file)
@@ -33,7 +33,8 @@ expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
-                             "StaticPointers"]
+                             "StaticPointers",
+                             "StrictData"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
@@ -47,4 +48,3 @@ expectedCabalOnlyExtensions = ["Generics",
                                "Safe",
                                "Unsafe",
                                "Trustworthy"]
-
index 553c719..5eb0785 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 553c719236972f3a1d445146352ec94614979b63
+Subproject commit 5eb0785cde60997f072c3bdfefaf8c389c96d42e