diff options
-rw-r--r-- | compiler/basicTypes/DataCon.hs | 10 | ||||
-rw-r--r-- | compiler/basicTypes/MkId.hs | 26 | ||||
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 10 | ||||
-rw-r--r-- | compiler/hsSyn/Convert.hs | 5 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 17 | ||||
-rw-r--r-- | compiler/typecheck/TcExpr.hs | 28 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.hs | 13 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_run/DsStrictData.hs | 45 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_run/DsStrictData.stdout | 4 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_run/all.T | 1 |
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, ['']) |