Add Strict data language pragmastrict-data

11 files changed, 117 insertions, 52 deletions

diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 2246169a2b..3ac1561046 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -597,11 +597,11 @@ eqHsBang _ _ = False
 
 -- | Is the field strict?
 isBanged :: DynFlags -> HsBang -> Bool
-isBanged dflags HsNoBang                  = xopt Opt_StrictData dflags
-isBanged dflags (HsSrcBang _ Nothing)     = xopt Opt_StrictData dflags
-isBanged dflags (HsSrcBang _ (Just bang)) = bang
-isBanged (HsUnpack {})                    = True
-isBanged (HsStrict {})                    = True
+isBanged dflags HsNoBang              = xopt Opt_StrictData dflags
+isBanged dflags (HsSrcBang _ Nothing) = xopt Opt_StrictData dflags
+isBanged _ (HsSrcBang _ (Just bang))  = bang
+isBanged _ (HsUnpack {})              = True
+isBanged _ (HsStrict {})              = True
 
 isMarkedStrict :: StrictnessMark -> Bool
 isMarkedStrict NotMarkedStrict = False
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index aa81b929d8..a610579513 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -585,14 +585,16 @@ dataConArgRep
       , [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
 
-dataConArgRep _ _ arg_ty HsNoBang
-  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+-- TODO: Might need to unpack.
+dataConArgRep dflags _ arg_ty HsNoBang
+  | xopt Opt_StrictData dflags = strict_but_not_unpacked arg_ty
+  | otherwise = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep _ _ arg_ty (HsSrcBang _ False)  -- No '!'
-  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+-- dataConArgRep _ _ arg_ty (HsSrcBang _ False)  -- No '!'
+--   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
 dataConArgRep dflags fam_envs arg_ty
-    (HsUserBang unpk_prag bang)  -- TODO: All constructors
+    (HsSrcBang unpk_prag bang)  -- TODO: All constructors
   | strict_field_requested
   , not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
           -- Don't unpack if we aren't optimising; rather arbitrarily,
@@ -724,13 +726,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 (HsUserBang (Just unpk) (Just bang)) = bang && unpk
-    attempt_unpack (HsUserBang (Just unpk) Nothing)     = xopt Opt_StrictData dflags && unpk
-    attempt_unpack (HsUserBang Nothing (Just bang))     = bang  -- Be conservative
-    attempt_unpack (HsUserBang Nothing Nothing)         = xopt Opt_StrictData dflags
-    attempt_unpack HsStrict                             = False
-    attempt_unpack HsNoBang                             = False
+    attempt_unpack (HsUnpack {})                       = True
+    attempt_unpack (HsSrcBang (Just unpk) (Just bang)) = bang && unpk
+    attempt_unpack (HsSrcBang (Just unpk) Nothing)     = xopt Opt_StrictData dflags && unpk
+    attempt_unpack (HsSrcBang Nothing (Just bang))     = bang  -- Be conservative
+    attempt_unpack (HsSrcBang Nothing Nothing)         = xopt Opt_StrictData dflags
+    attempt_unpack HsStrict                            = False
+    attempt_unpack HsNoBang                            = False
 
 {-
 Note [Unpack one-wide fields]
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index b7445a8e2b..28890a590b 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -651,9 +651,13 @@ repBangTy ty= do
   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)
+                   -- TODO: We probably need to look at DynFlags.
+                   L _ (HsBangTy (HsSrcBang (Just True) (Just True)) ty) ->
+                       (unpackedName,  ty)
+                   L _ (HsBangTy (HsSrcBang _     (Just True)) ty)       ->
+                       (isStrictName,  ty)
+                   _                                                     ->
+                       (notStrictName, ty)
 
 -------------------------------------------------------
 --                      Deriving clause
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 92af65170f..afb0fa56ed 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -436,8 +436,9 @@ cvtConstr (ForallC tvs ctxt con)
 
 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     True) ty' }
-cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang (Just True) True) ty' }
+-- TODO: Do we need output Nothing instead of (Just True) if we're using -XStrictData?
+cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang Nothing     (Just True)) ty' }
+cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang (Just True) (Just True)) ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4958e0c6a3..fb0818c1d5 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1351,13 +1351,16 @@ sigtypes1 :: { (OrdList (LHsType RdrName)) }      -- Always HsForAllTys
 -- Types
 
 strict_mark :: { Located ([AddAnn],HsBang) }
-        : '!'                        { sL1 $1    ([],            HsSrcBang Nothing      True) }
-        | '{-# UNPACK' '#-}'         { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  False) }
-        | '{-# NOUNPACK' '#-}'       { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) False) }
-        | '{-# UNPACK' '#-}' '!'     { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  True) }
-        | '{-# NOUNPACK' '#-}' '!'   { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) True) }
-        -- Although UNPACK with no '!' is illegal, we get a
-        -- better error message if we parse it here
+        : '!'                        { sL1 $1    ([],            HsSrcBang Nothing      (Just True)) }
+        | '~'                        { sL1 $1    ([],            HsSrcBang Nothing      (Just False)) }
+        | '{-# UNPACK' '#-}'         { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  Nothing) }
+        | '{-# NOUNPACK' '#-}'       { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) Nothing) }
+        | '{-# UNPACK' '#-}' '!'     { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  (Just True)) }
+        | '{-# NOUNPACK' '#-}' '!'   { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) (Just True)) }
+        | '{-# UNPACK' '#-}' '~'     { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  (Just False)) }
+        | '{-# NOUNPACK' '#-}' '~'   { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) (Just False)) }
+        -- Although UNPACK with no '!' and UNPACK with '~' are illegal, we get a
+        -- better error message if we parse them here
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index a3a9be3f80..6ed4d9aa95 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1383,29 +1383,31 @@ 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
-  = if any isBanged field_strs then
-        -- Illegal if any arg is strict
-        addErrTc (missingStrictFields data_con [])
-    else
-        return ()
+  = do dflags <- getDynFlags
+       if any (isBanged dflags) field_strs then
+           -- Illegal if any arg is strict
+           addErrTc (missingStrictFields data_con [])
+       else
+           return ()
 
   | otherwise = do              -- A record
-    unless (null missing_s_fields)
-           (addErrTc (missingStrictFields data_con missing_s_fields))
+    dflags <- getDynFlags
+    unless (null (missing_s_fields dflags))
+           (addErrTc (missingStrictFields data_con (missing_s_fields dflags)))
 
     warn <- woptM Opt_WarnMissingFields
-    unless (not (warn && notNull missing_ns_fields))
-           (warnTc True (missingFields data_con missing_ns_fields))
+    unless (not (warn && notNull (missing_ns_fields dflags)))
+           (warnTc True (missingFields data_con (missing_ns_fields dflags)))
 
   where
-    missing_s_fields
+    missing_s_fields dflags
         = [ fl | (fl, str) <- field_info,
-                 isBanged str,
+                 isBanged dflags str,
                  not (fl `elem` field_names_used)
           ]
-    missing_ns_fields
+    missing_ns_fields dflags
         = [ fl | (fl, str) <- field_info,
-                 not (isBanged str),
+                 not (isBanged dflags str),
                  not (fl `elem` field_names_used)
           ]
 
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 020722c594..756d12096f 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1621,12 +1621,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
+-- TODO: Do we need to look for e.g. -XStrictData here?
+reifyStrict HsNoBang                            = TH.NotStrict
+reifyStrict (HsSrcBang _ (Just False))          = TH.NotStrict
+reifyStrict (HsSrcBang (Just True) (Just True)) = TH.Unpacked
+reifyStrict (HsSrcBang _     (Just True))       = TH.IsStrict
+reifyStrict HsStrict                            = TH.IsStrict
+reifyStrict (HsUnpack {})                       = TH.Unpacked
 
 ------------------------------
 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 27e2d45a03..484b89bb19 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1589,15 +1589,16 @@ 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 (Just want_unpack) mb_bang, rep_bang, n)
+      | want_unpack, not is_strict
       = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'")))
       | 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!
+           -- If not optimising, we 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 = mb_bang == Just True || xopt Opt_StrictData dflags
 
     check_bang _
       = return ()
@@ -1623,7 +1624,8 @@ checkNewDataCon con
           ptext (sLit "A newtype constructor cannot have existential type variables")
                 -- No existentials
 
-        ; checkTc (not (any isBanged (dataConSrcBangs con)))
+        ; dflags <- getDynFlags
+        ; checkTc (not (any (isBanged dflags) (dataConSrcBangs con)))
                   (newtypeStrictError con)
                 -- No strictness
     }
diff --git a/testsuite/tests/deSugar/should_run/DsStrictData.hs b/testsuite/tests/deSugar/should_run/DsStrictData.hs
new file mode 100644
index 0000000000..05fc1ca9a7
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrictData.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE ScopedTypeVariables, StrictData #-}
+
+-- | 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 UStrict = US {-# UNPACK #-} Int
+
+data Lazy a = L a
+
+main = do
+    -- Should be _|_:
+    print $ isBottom $ S dummy
+    print $ isBottom $ US dummy
+
+    putStrLn ""
+
+    -- Should not be _|_:
+    print $ not $ isBottom $ L dummy
+
+-- A dummy value to return from functions that are _|_.
+dummy :: Int
+dummy = 1
+
+------------------------------------------------------------------------
+-- 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
index 0000000000..245f971438
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrictData.stdout
@@ -0,0 +1,4 @@
+True
+True
+
+True
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index 87ebe8ecaf..4806f9b61b 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -44,3 +44,4 @@ test('DsStaticPointers',
      when(compiler_lt('ghc', '7.9'), skip), compile_and_run, [''])
 test('T8952', normal, compile_and_run, [''])
 test('T9844', normal, compile_and_run, [''])
+test('DsStrictData', normal, compile_and_run, [''])