Implement the Strict language extension

Add a new language extension `-XStrict` which turns all bindings strict
as if the programmer had written a `!` before it. This also upgrades
ordinary Haskell to allow recursive and polymorphic strict bindings.

See the wiki[1] and the Note [Desugar Strict binds] in DsBinds for
specification and implementation details.

[1] https://ghc.haskell.org/trac/ghc/wiki/StrictPragma

Reviewers: austin, tibbe, simonpj, bgamari

Reviewed By: tibbe, bgamari

Subscribers: thomie

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

GHC Trac Issues: #8347

26 files changed, 720 insertions, 141 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 47a3419bcc..f29353b47b 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -70,7 +70,7 @@ import DynFlags
 import FastString
 import Util
 import MonadUtils
-import Control.Monad(liftM,when)
+import Control.Monad(liftM,when,foldM)
 
 {-**********************************************************************
 *                                                                      *
@@ -78,65 +78,99 @@ import Control.Monad(liftM,when)
 *                                                                      *
 **********************************************************************-}
 
+-- | Desugar top level binds, strict binds are treated like normal
+-- binds since there is no good time to force before first usage.
 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
-dsTopLHsBinds binds = ds_lhs_binds binds
+dsTopLHsBinds binds = fmap (toOL . snd) (ds_lhs_binds binds)
 
-dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
-                      ; return (fromOL binds') }
+-- | Desugar all other kind of bindings, Ids of strict binds are returned to
+-- later be forced in the binding gorup body, see Note [Desugar Strict binds]
+dsLHsBinds :: LHsBinds Id
+           -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBinds binds = do { (force_vars, binds') <- ds_lhs_binds binds
+                      ; return (force_vars, binds') }
 
 ------------------------
-ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
-
-ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
-                        ; return (foldBag appOL id nilOL ds_bs) }
-
-dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
-dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind
-
-dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
-
-dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
-  = do  { dflags <- getDynFlags
-        ; core_expr <- dsLExpr expr
 
+ds_lhs_binds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)])
+
+ds_lhs_binds binds
+  = do { ds_bs <- mapBagM dsLHsBind binds
+       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
+                         id ([], []) ds_bs) }
+
+dsLHsBind :: LHsBind Id
+          -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBind (L loc bind) = do dflags <- getDynFlags
+                            putSrcSpanDs loc $ dsHsBind dflags bind
+
+-- | Desugar a single binding (or group of recursive binds).
+dsHsBind :: DynFlags
+         -> HsBind Id
+         -> DsM ([Id], [(Id,CoreExpr)])
+         -- ^ The Ids of strict binds, to be forced in the body of the
+         -- binding group see Note [Desugar Strict binds] and all
+         -- bindings and their desugared right hand sides.
+
+dsHsBind dflags
+         (VarBind { var_id = var
+                  , var_rhs = expr
+                  , var_inline = inline_regardless })
+  = do  { core_expr <- dsLExpr expr
                 -- Dictionary bindings are always VarBinds,
                 -- so we only need do this here
         ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
                    | otherwise         = var
-
-        ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
-
-dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
+        ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr
+              force_var = if xopt Opt_Strict dflags
+                          then [id]
+                          else []
+        ; return (force_var, [core_bind]) }
+
+dsHsBind dflags
+         (FunBind { fun_id = L _ fun, fun_matches = matches
                   , fun_co_fn = co_fn, fun_tick = tick })
- = do   { dflags <- getDynFlags
-        ; (args, body) <- matchWrapper (FunRhs (idName fun)) matches
+ = do   { (args, body) <- matchWrapper (FunRhs (idName fun)) matches
         ; let body' = mkOptTickBox tick body
         ; rhs <- dsHsWrapper co_fn (mkLams args body')
+        ; let core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
+              force_var =
+                if xopt Opt_Strict dflags
+                   && matchGroupArity matches == 0 -- no need to force lambdas
+                then [id]
+                else []
         ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
-           return (unitOL (makeCorePair dflags fun False 0 rhs)) }
+           return (force_var, [core_binds]) }
 
-dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
+dsHsBind dflags
+         (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
                   , pat_ticks = (rhs_tick, var_ticks) })
   = do  { body_expr <- dsGuarded grhss ty
         ; let body' = mkOptTickBox rhs_tick body_expr
-        ; sel_binds <- mkSelectorBinds var_ticks pat body'
+              (is_strict,pat') = getUnBangedLPat dflags pat
+        ; (force_var,sel_binds) <-
+            mkSelectorBinds is_strict var_ticks pat' body'
           -- We silently ignore inline pragmas; no makeCorePair
           -- Not so cool, but really doesn't matter
-    ; return (toOL sel_binds) }
+        ; let force_var' = if is_strict
+                           then maybe [] (\v -> [v]) force_var
+                           else []
+        ; return (force_var', sel_binds) }
 
-        -- A common case: one exported variable
+        -- A common case: one exported variable, only non-strict binds
         -- Non-recursive bindings come through this way
         -- So do self-recursive bindings, and recursive bindings
         -- that have been chopped up with type signatures
-dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+dsHsBind dflags
+         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    , abs_exports = [export]
                    , abs_ev_binds = ev_binds, abs_binds = binds })
   | ABE { abe_wrap = wrap, abe_poly = global
         , abe_mono = local, abe_prags = prags } <- export
-  = do  { dflags <- getDynFlags
-        ; bind_prs <- ds_lhs_binds binds
-        ; let core_bind = Rec (fromOL bind_prs)
+  , not (xopt Opt_Strict dflags)                 -- handle strict binds
+  , not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case
+  = do  { (_, bind_prs) <- ds_lhs_binds binds
+        ; let core_bind = Rec bind_prs
         ; ds_binds <- dsTcEvBinds_s ev_binds
         ; rhs <- dsHsWrapper wrap $  -- Usually the identity
                             mkLams tyvars $ mkLams dicts $
@@ -150,20 +184,21 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                 main_bind = makeCorePair dflags global' (isDefaultMethod prags)
                                          (dictArity dicts) rhs
 
-        ; return (main_bind `consOL` spec_binds) }
+        ; return ([], main_bind : fromOL spec_binds) }
 
-dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+dsHsBind dflags
+         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    , abs_exports = exports, abs_ev_binds = ev_binds
                    , abs_binds = binds })
          -- See Note [Desugaring AbsBinds]
-  = do  { dflags <- getDynFlags
-        ; bind_prs    <- ds_lhs_binds binds
+  = do  { (local_force_vars, bind_prs) <- ds_lhs_binds binds
         ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
-                              | (lcl_id, rhs) <- fromOL bind_prs ]
+                              | (lcl_id, rhs) <- bind_prs ]
                 -- Monomorphic recursion possible, hence Rec
-
+              new_force_vars = get_new_force_vars local_force_vars
               locals       = map abe_mono exports
-              tup_expr     = mkBigCoreVarTup locals
+              all_locals   = locals ++ new_force_vars
+              tup_expr     = mkBigCoreVarTup all_locals
               tup_ty       = exprType tup_expr
         ; ds_binds <- dsTcEvBinds_s ev_binds
         ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
@@ -173,12 +208,17 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
 
         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
 
+        -- Find corresponding global or make up a new one: sometimes
+        -- we need to make new export to desugar strict binds, see
+        -- Note [Desugar Strict binds]
+        ; (exported_force_vars, extra_exports) <- get_exports local_force_vars
+
         ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
                            , abe_mono = local, abe_prags = spec_prags })
                 = do { tup_id  <- newSysLocalDs tup_ty
                      ; rhs <- dsHsWrapper wrap $
                                  mkLams tyvars $ mkLams dicts $
-                                 mkTupleSelector locals local tup_id $
+                                 mkTupleSelector all_locals local tup_id $
                                  mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
                      ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
                      ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
@@ -187,12 +227,13 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                            -- Kill the INLINE pragma because it applies to
                            -- the user written (local) function.  The global
                            -- Id is just the selector.  Hmm.
-                     ; return ((global', rhs) `consOL` spec_binds) }
+                     ; return ((global', rhs) : fromOL spec_binds) }
 
-        ; export_binds_s <- mapM mk_bind exports
+        ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
 
-        ; return ((poly_tup_id, poly_tup_rhs) `consOL`
-                    concatOL export_binds_s) }
+        ; return (exported_force_vars
+                 ,(poly_tup_id, poly_tup_rhs) :
+                   concat export_binds_s) }
   where
     inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with
                              -- the inline pragma from the source
@@ -205,7 +246,40 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
     add_inline :: Id -> Id    -- tran
     add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
 
-dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+    global_env :: IdEnv Id -- Maps local Id to its global exported Id
+    global_env =
+      mkVarEnv [ (local, global)
+               | ABE { abe_mono = local, abe_poly = global } <- exports
+               ]
+
+    -- find variables that are not exported
+    get_new_force_vars lcls =
+      foldr (\lcl acc -> case lookupVarEnv global_env lcl of
+                           Just _ -> acc
+                           Nothing -> lcl:acc)
+            [] lcls
+
+    -- find exports or make up new exports for force variables
+    get_exports :: [Id] -> DsM ([Id], [ABExport Id])
+    get_exports lcls =
+      foldM (\(glbls, exports) lcl ->
+              case lookupVarEnv global_env lcl of
+                Just glbl -> return (glbl:glbls, exports)
+                Nothing   -> do export <- mk_export lcl
+                                let glbl = abe_poly export
+                                return (glbl:glbls, export:exports))
+            ([],[]) lcls
+
+    mk_export local =
+      do global <- newSysLocalDs
+                     (exprType (mkLams tyvars (mkLams dicts (Var local))))
+         return (ABE {abe_poly = global
+                     ,abe_mono = local
+                     ,abe_wrap = WpHole
+                     ,abe_prags = SpecPrags []})
+
+dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+
 
 ------------------------
 makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
@@ -261,8 +335,8 @@ dictArity :: [Var] -> Arity
 dictArity dicts = count isId dicts
 
 {-
-[Desugaring AbsBinds]
-~~~~~~~~~~~~~~~~~~~~~
+Note [Desugaring AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
 In the general AbsBinds case we desugar the binding to this:
 
        tup a (d:Num a) = let fm = ...gm...
@@ -387,6 +461,80 @@ gotten from the binding for fromT_1.
 
 It might be better to have just one level of AbsBinds, but that requires more
 thought!
+
+
+Note [Desugar Strict binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Desugaring strict variable bindings looks as follows (core below ==>)
+
+  let !x = rhs
+  in  body
+==>
+  let x = rhs
+  in x `seq` body -- seq the variable
+
+and if it is a pattern binding the desugaring looks like
+
+  let !pat = rhs
+  in body
+==>
+  let x = rhs -- bind the rhs to a new variable
+      pat = x
+  in x `seq` body -- seq the new variable
+
+if there is no variable in the pattern desugaring looks like
+
+  let False = rhs
+  in body
+==>
+  let x = case rhs of {False -> (); _ -> error "Match failed"}
+  in x `seq` body
+
+In order to force the Ids in the binding group they are passed around
+in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind.
+
+Consider a recursive group like this
+
+  letrec
+     f : g = rhs[f,g]
+  in <body>
+
+Without `Strict`, we get a translation like this:
+
+  let t = /\a. letrec tm = rhs[fm,gm]
+                      fm = case t of fm:_ -> fm
+                      gm = case t of _:gm -> gm
+                in
+                (fm,gm)
+
+  in let f = /\a. case t a of (fm,_) -> fm
+  in let g = /\a. case t a of (_,gm) -> gm
+  in <body>
+
+Here `tm` is the monomorphic binding for `rhs`.
+
+With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
+Alas, `tm` isn't in scope in the `in <body>` part.
+
+The simplest thing is to return it in the polymoprhic
+tuple `t`, thus:
+
+  let t = /\a. letrec tm = rhs[fm,gm]
+                      fm = case t of fm:_ -> fm
+                      gm = case t of _:gm -> gm
+                in
+                (tm, fm, gm)
+
+  in let f = /\a. case t a of (_,fm,_) -> fm
+  in let g = /\a. case t a of (_,_,gm) -> gm
+  in let tm = /\a. case t a of (tm,_,_) -> tm
+  in tm `seq` <body>
+
+
+See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more
+detailed explanation of the desugaring of strict bindings.
+
 -}
 
 ------------------------
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index dc6be9cddd..886961c4d0 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -109,16 +109,17 @@ ds_val_bind (NonRecursive, hsbinds) body
         -- ToDo: in some bizarre case it's conceivable that there
         --       could be dict binds in the 'binds'.  (See the notes
         --       below.  Then pattern-match would fail.  Urk.)
-    strictMatchOnly bind
-  = putSrcSpanDs loc (dsStrictBind bind body)
+    unliftedMatchOnly bind
+  = putSrcSpanDs loc (dsUnliftedBind bind body)
 
 -- Ordinary case for bindings; none should be unlifted
 ds_val_bind (_is_rec, binds) body
-  = do  { prs <- dsLHsBinds binds
+  = do  { (force_vars,prs) <- dsLHsBinds binds
+        ; let body' = foldr seqVar body force_vars
         ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
           case prs of
             [] -> return body
-            _  -> return (Let (Rec prs) body) }
+            _  -> return (Let (Rec prs) body') }
         -- Use a Rec regardless of is_rec.
         -- Why? Because it allows the binds to be all
         -- mixed up, which is what happens in one rare case
@@ -131,29 +132,31 @@ ds_val_bind (_is_rec, binds) body
         --    only have to deal with lifted ones now; so Rec is ok
 
 ------------------
-dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
-dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
+dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
+dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
                , abs_exports = exports
                , abs_ev_binds = ev_binds
                , abs_binds = lbinds }) body
   = do { let body1 = foldr bind_export body exports
              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
-       ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
+       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
                             body1 lbinds
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; return (mkCoreLets ds_binds body2) }
 
-dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
-                      , fun_tick = tick }) body
-                -- Can't be a bang pattern (that looks like a PatBind)
-                -- so must be simply unboxed
-  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun )) matches
+dsUnliftedBind (FunBind { fun_id = L _ fun
+                        , fun_matches = matches
+                        , fun_co_fn = co_fn
+                        , fun_tick = tick }) body
+               -- Can't be a bang pattern (that looks like a PatBind)
+               -- so must be simply unboxed
+  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) matches
        ; MASSERT( null args ) -- Functions aren't lifted
        ; MASSERT( isIdHsWrapper co_fn )
        ; let rhs' = mkOptTickBox tick rhs
        ; return (bindNonRec fun rhs' body) }
 
-dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
+dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
   =     -- let C x# y# = rhs in body
         -- ==> case rhs of C x# y# -> body
     do { rhs <- dsGuarded grhss ty
@@ -164,19 +167,19 @@ dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
        ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
        ; return (bindNonRec var rhs result) }
 
-dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
+dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 
 ----------------------
-strictMatchOnly :: HsBind Id -> Bool
-strictMatchOnly (AbsBinds { abs_binds = lbinds })
-  = anyBag (strictMatchOnly . unLoc) lbinds
-strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
+unliftedMatchOnly :: HsBind Id -> Bool
+unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
+  = anyBag (unliftedMatchOnly . unLoc) lbinds
+unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
   =  isUnLiftedType rhs_ty
-  || isStrictLPat lpat
+  || isUnliftedLPat lpat
   || any (isUnLiftedType . idType) (collectPatBinders lpat)
-strictMatchOnly (FunBind { fun_id = L _ id })
+unliftedMatchOnly (FunBind { fun_id = L _ id })
   = isUnLiftedType (idType id)
-strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
+unliftedMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
 
 {-
 ************************************************************************
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 503e29de46..a14c608d1c 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -35,7 +35,7 @@ module DsUtils (
         mkSelectorBinds,
 
         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox
+        mkOptTickBox, mkBinaryTickBox, getUnBangedLPat
     ) where
 
 #include "HsVersions.h"
@@ -612,20 +612,24 @@ cases like
      (p,q) = e
 -}
 
-mkSelectorBinds :: [[Tickish Id]] -- ticks to add, possibly
-                -> LPat Id      -- The pattern
-                -> CoreExpr     -- Expression to which the pattern is bound
-                -> DsM [(Id,CoreExpr)]
-
-mkSelectorBinds ticks (L _ (VarPat v)) val_expr
-  = return [(v, case ticks of
-                  [t] -> mkOptTickBox t val_expr
-                  _   -> val_expr)]
-
-mkSelectorBinds ticks pat val_expr
-  | null binders
-  = return []
-
+mkSelectorBinds :: Bool           -- ^ is strict
+                -> [[Tickish Id]] -- ^ ticks to add, possibly
+                -> LPat Id        -- ^ The pattern
+                -> CoreExpr       -- ^ Expression to which the pattern is bound
+                -> DsM (Maybe Id,[(Id,CoreExpr)])
+                -- ^ Id the rhs is bound to, for desugaring strict
+                -- binds (see Note [Desugar Strict binds] in DsBinds)
+                -- and all the desugared binds
+
+mkSelectorBinds _ ticks (L _ (VarPat v)) val_expr
+  = return (Just v
+           ,[(v, case ticks of
+                    [t] -> mkOptTickBox t val_expr
+                    _   -> val_expr)])
+
+mkSelectorBinds is_strict ticks pat val_expr
+  | null binders, not is_strict
+  = return (Nothing, [])
   | isSingleton binders || is_simple_lpat pat
     -- See Note [mkSelectorBinds]
   = do { val_var <- newSysLocalDs (hsLPatType pat)
@@ -648,19 +652,31 @@ mkSelectorBinds ticks pat val_expr
        ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat)
        ; err_var <- newSysLocalDs (mkForAllTy alphaTyVar alphaTy)
        ; binds   <- zipWithM (mk_bind val_var err_var) ticks' binders
-       ; return ( (val_var, val_expr) :
-                  (err_var, Lam alphaTyVar err_app) :
-                  binds ) }
+       ; return (Just val_var
+                ,(val_var, val_expr) :
+                 (err_var, Lam alphaTyVar err_app) :
+                 binds) }
 
   | otherwise
-  = do { error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
-       ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
+  = do { val_var <- newSysLocalDs (hsLPatType pat)
+       ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
+       ; tuple_expr
+           <- matchSimply (Var val_var) PatBindRhs pat local_tuple error_expr
        ; tuple_var <- newSysLocalDs tuple_ty
        ; let mk_tup_bind tick binder
               = (binder, mkOptTickBox tick $
                             mkTupleSelector local_binders binder
                                             tuple_var (Var tuple_var))
-       ; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) }
+         -- if strict and no binders we want to force the case
+         -- expression to force an error if the pattern match
+         -- failed. See Note [Desugar Strict binds] in DsBinds.
+       ; let force_var = if null binders && is_strict
+                         then tuple_var
+                         else val_var
+       ; return (Just force_var
+                ,(val_var,val_expr) :
+                 (tuple_var, tuple_expr) :
+                 zipWith mk_tup_bind ticks' binders) }
   where
     binders       = collectPatBinders pat
     ticks'        = ticks ++ repeat []
@@ -842,3 +858,31 @@ mkBinaryTickBox ixT ixF e = do
                        [ (DataAlt falseDataCon, [], falseBox)
                        , (DataAlt trueDataCon,  [], trueBox)
                        ]
+
+
+
+-- *******************************************************************
+
+
+-- | Remove any bang from a pattern and say if it is a strict bind,
+-- also make irrefutable patterns ordinary patterns if -XStrict.
+--
+-- Example:
+-- ~pat    => False, pat -- when -XStrict
+-- ~pat    => False, ~pat -- without -XStrict
+-- ~(~pat) => False, ~pat -- when -XStrict
+-- pat     => True, pat -- when -XStrict
+-- !pat    => True, pat -- always
+getUnBangedLPat :: DynFlags
+                -> LPat id  -- ^ Original pattern
+                -> (Bool, LPat id) -- is bind strict?, pattern without bangs
+getUnBangedLPat dflags (L l (ParPat p))
+  = let (is_strict, p') = getUnBangedLPat dflags p
+    in (is_strict, L l (ParPat p'))
+getUnBangedLPat _ (L _ (BangPat p))
+  = (True,p)
+getUnBangedLPat dflags (L _ (LazyPat p))
+  | xopt Opt_Strict dflags
+  = (False,p)
+getUnBangedLPat dflags p
+  = (xopt Opt_Strict dflags,p)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index fc92bad79d..e23f223d76 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -545,7 +545,7 @@ tidy1 v (AsPat (L _ var) pat)
 -}
 
 tidy1 v (LazyPat pat)
-  = do  { sel_prs <- mkSelectorBinds [] pat (Var v)
+  = do  { (_,sel_prs) <- mkSelectorBinds False [] pat (Var v)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 
@@ -804,10 +804,15 @@ matchWrapper ctxt (MG { mg_alts = L _ matches
         ; return (new_vars, result_expr) }
   where
     mk_eqn_info (L _ (Match _ pats _ grhss))
-      = do { let upats = map unLoc pats
+      = do { dflags <- getDynFlags
+           ; let upats = map (strictify dflags) pats
            ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
 
+    strictify dflags pat =
+      let (is_strict, pat') = getUnBangedLPat dflags pat
+      in if is_strict then BangPat pat' else unLoc pat'
+
     handleWarnings = if isGenerated origin
                      then discardWarningsDs
                      else id
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 3fd6f73202..0f47cf6145 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -27,8 +27,9 @@ module HsPat (
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
-        isStrictHsBind, looksLazyPatBind,
-        isStrictLPat, hsPatNeedsParens,
+        isUnliftedHsBind, looksLazyPatBind,
+        isUnliftedLPat, isBangedLPat, isBangedPatBind,
+        hsPatNeedsParens,
         isIrrefutableHsPat,
 
         pprParendLPat, pprConArgs
@@ -493,17 +494,25 @@ patterns are treated specially, of course.
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 -}
 
-isStrictLPat :: LPat id -> Bool
-isStrictLPat (L _ (ParPat p))             = isStrictLPat p
-isStrictLPat (L _ (BangPat {}))           = True
-isStrictLPat (L _ (TuplePat _ Unboxed _)) = True
-isStrictLPat _                            = False
+isUnliftedLPat :: LPat id -> Bool
+isUnliftedLPat (L _ (ParPat p))             = isUnliftedLPat p
+isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True
+isUnliftedLPat _                            = False
 
-isStrictHsBind :: HsBind id -> Bool
+isUnliftedHsBind :: HsBind id -> Bool
 -- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
 -- Defined in this module because HsPat is above HsBinds in the import graph
-isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p
-isStrictHsBind _                         = False
+isUnliftedHsBind (PatBind { pat_lhs = p }) = isUnliftedLPat p
+isUnliftedHsBind _                         = False
+
+isBangedPatBind :: HsBind id -> Bool
+isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
+isBangedPatBind _ = False
+
+isBangedLPat :: LPat id -> Bool
+isBangedLPat (L _ (ParPat p))   = isBangedLPat p
+isBangedLPat (L _ (BangPat {})) = True
+isBangedLPat _                  = False
 
 looksLazyPatBind :: HsBind id -> Bool
 -- Returns True of anything *except*
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 39f4a0487f..f91857f112 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -653,6 +653,7 @@ data ExtensionFlag
    | Opt_PartialTypeSignatures
    | Opt_NamedWildCards
    | Opt_StaticPointers
+   | Opt_Strict
    | Opt_StrictData
    deriving (Eq, Enum, Show)
 
@@ -3212,6 +3213,7 @@ xFlags = [
   flagSpec "ScopedTypeVariables"              Opt_ScopedTypeVariables,
   flagSpec "StandaloneDeriving"               Opt_StandaloneDeriving,
   flagSpec "StaticPointers"                   Opt_StaticPointers,
+  flagSpec "Strict"                           Opt_Strict,
   flagSpec "StrictData"                       Opt_StrictData,
   flagSpec' "TemplateHaskell"                 Opt_TemplateHaskell
                                               setTemplateHaskellLoc,
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index ff97fecd50..3115179c2f 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -1731,7 +1731,7 @@ decideGeneralisationPlan
    :: DynFlags -> TcTypeEnv -> [Name]
    -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
-  | strict_pat_binds                          = NoGen
+  | unlifted_pat_binds                          = NoGen
   | Just (lbind, sig) <- one_funbind_with_sig = if isPartialSig sig
     -- See Note [Partial type signatures and generalisation]
                                                 then infer_plan
@@ -1743,8 +1743,8 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
     bndr_set = mkNameSet bndr_names
     binds = map unLoc lbinds
 
-    strict_pat_binds = any isStrictHsBind binds
-       -- Strict patterns (top level bang or unboxed tuple) must not
+    unlifted_pat_binds = any isUnliftedHsBind binds
+       -- Unlifted patterns (unboxed tuple) must not
        -- be polymorphic, because we are going to force them
        -- See Trac #4498, #8762
 
@@ -1843,7 +1843,7 @@ checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
     return ()
   where
     any_unlifted_bndr  = any is_unlifted poly_ids
-    any_strict_pat     = any (isStrictHsBind   . unLoc) orig_binds
+    any_strict_pat     = any (isUnliftedHsBind . unLoc) orig_binds
     any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
 
     is_unlifted id = case tcSplitSigmaTy (idType id) of
@@ -1873,7 +1873,7 @@ polyBindErr :: [LHsBind Name] -> SDoc
 polyBindErr binds
   = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
        2 (vcat [vcat (map ppr binds),
-                ptext (sLit "Probable fix: use a bang pattern")])
+                ptext (sLit "Probable fix: add a type signature")])
 
 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
 strictBindErr flavour any_unlifted_bndr binds
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index ec026947be..ed47dae6a0 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -10332,22 +10332,12 @@ the top level of a ``let`` or ``where`` binding makes the binding
 strict, regardless of the pattern. (We say "apparent" exception because
 the Right Way to think of it is that the bang at the top of a binding is
 not part of the *pattern*; rather it is part of the syntax of the
-*binding*, creating a "bang-pattern binding".) For example:
+*binding*, creating a "bang-pattern binding".) See :ref:`Strict recursive and
+polymorphic let bindings <recursive-and-polymorphic-let-bindings> for
+how bang-pattern bindings are compiled.
 
-::
-
-    let ![x,y] = e in b
-
-is a bang-pattern binding. Operationally, it behaves just like a case
-expression:
-
-::
-
-    case e of [x,y] -> b
-
-Like a case expression, a bang-pattern binding must be non-recursive,
-and is monomorphic. However, *nested* bangs in a pattern binding behave
-uniformly with all other forms of pattern matching. For example
+However, *nested* bangs in a pattern binding behave uniformly with all
+other forms of pattern matching. For example
 
 ::
 
@@ -12434,10 +12424,11 @@ Strict Haskell
 
 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 ``-XStrictData`` is detailed that allows the programmer
-to switch the default behavior on a per-module basis.
+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 ``-XStrictData`` and ``-XStrict`` are detailed
+that allows the programmer to switch the default behavior on a
+per-module basis.
 
 .. _strict-data:
 
@@ -12455,7 +12446,7 @@ When the user writes
           data T = C a
           data T' = C' ~a
 
-we interpret it as if she had written
+we interpret it as if they had written
 
 ::
 
@@ -12463,3 +12454,281 @@ we interpret it as if she had written
           data T' = C' a
 
 The extension only affects definitions in this module.
+
+
+.. _strict:
+
+Strict-by-default pattern bindings
+----------------------------------
+
+Informally the ``Strict`` language extension switches functions, data
+types, and bindings to be strict by default, allowing optional laziness
+by adding ``~`` in front of a variable. This essentially reverses the
+present situation where laziness is default and strictness can be
+optionally had by adding ``!`` in front of a variable.
+
+``Strict`` implies :ref:`StrictData <strict-data>`.
+
+-  **Function definitions.**
+
+   When the user writes ::
+
+       f x = ...
+
+   we interpret it as if they had written ::
+
+       f !x = ...
+
+   Adding ``~`` in front of ``x`` gives the regular lazy behavior.
+
+-  **Let/where bindings.**
+
+   When the user writes ::
+
+     let x = ...
+     let pat = ...
+
+   we interpret it as if they had written ::
+
+     let !x = ...
+     let !pat = ...
+
+   Adding ``~`` in front of ``x`` gives the regular lazy
+   behavior. Notice that we do not put bangs on nested patterns. For
+   example ::
+
+     let (p,q) = if flob then (undefined, undefined) else (True, False)
+     in ...
+
+   will behave like ::
+
+     let !(p,q) = if flob then (undefined, undefined) else (True,False)
+     in ...
+
+   which will strictly evaluate the right hand side, and bind ``p``
+   and ``q`` to the components of the pair. But the pair itself is
+   lazy (unless we also compile the ``Prelude`` with ``Strict``; see
+   :ref:`strict-modularity` below). So ``p`` and ``q`` may end up bound to
+   undefined. See also :ref:`recursive-and-polymorphic-let-bindings` below.
+
+-  **Case expressions.**
+
+   The patterns of a case expression get an implicit bang, unless
+   disabled with ``~``. For example ::
+
+       case x of (a,b) -> rhs
+
+   is interpreted as ::
+
+       case x of !(a,b) -> rhs
+
+   Since the semantics of pattern matching in case expressions is
+   strict, this usually has no effect whatsoever. But it does make a
+   difference in the degenerate case of variables and newtypes. So ::
+
+       case x of y -> rhs
+
+   is lazy in Haskell, but with ``Strict`` is interpreted as ::
+
+       case x of !y -> rhs
+
+   which evalutes ``x``. Similarly, if ``newtype Age = MkAge Int``, then ::
+
+       case x of MkAge i -> rhs
+
+   is lazy in Haskell; but with ``Strict`` the added bang makes it
+   strict.
+
+-  **Top level bindings.**
+
+   are unaffected by ``Strict``. For example: ::
+
+       x = factorial 20
+       (y,z) = if x > 10 then True else False
+
+   Here ``x`` and the pattern binding ``(y,z)`` remain lazy. Reason:
+   there is no good moment to force them, until first use.
+
+-  **Newtypes.**
+
+   There is no effect on newtypes, which simply rename existing types.
+   For example: ::
+
+       newtype T = C a
+       f (C x)  = rhs1
+       g !(C x) = rhs2
+
+   In ordinary Haskell, ``f`` is lazy in its argument and hence in
+   ``x``; and ``g`` is strict in its argument and hence also strict in
+   ``x``. With ``Strict``, both become strict because ``f``'s argument
+   gets an implict bang.
+
+
+.. _strict-modularity:
+
+Modularity
+----------
+
+``Strict`` and ``StrictData`` only affects definitions in the module
+they are used in. Functions and data types imported from other modules
+are unaffected. For example, we won't evaluate the argument to
+``Just`` before applying the constructor.  Similarly we won't evaluate
+the first argument to ``Data.Map.findWithDefault`` before applying the
+function.
+
+This is crucial to preserve correctness. Entities defined in other
+modules might rely on laziness for correctness (whether functional or
+performance).
+
+Tuples, lists, ``Maybe``, and all the other types from ``Prelude``
+continue to have their existing, lazy, semantics.
+
+.. _recursive-and-polymorphic-let-bindings:
+
+Recursive and polymorphic let bindings
+--------------------------------------
+
+**Static semantics**
+
+Exactly as in Haskell, unaffected by ``Strict``. This is more permissive
+than past rules for bang patterns in let bindings, because it supports
+bang-patterns for polymorphic and recursive bindings.
+
+**Dynamic semantics**
+
+Consider the rules in the box of `Section 3.12 of the Haskell
+report <http://www.haskell.org/onlinereport/exps.html#sect3.12>`__.
+Replace these rules with the following ones, where ``v`` stands for a
+variable:
+
+.. admonition:: FORCE
+
+    Replace any binding ``!p = e`` with ``v = e; p = v`` and replace
+    ``e0`` with ``v seq e0``, where ``v`` is fresh. This translation works fine if
+    ``p`` is already a variable ``x``, but can obviously be optimised by not
+    introducing a fresh variable ``v``.
+
+.. admonition:: SPLIT
+
+    Replace any binding ``p = e``, where ``p`` is not a variable, with
+    ``v = e; x1 = case v of p -> x1; ...; xn = case v of p -> xn``, where
+    ``v`` is fresh and ``x1``.. ``xn`` are the bound variables of ``p``.
+    Again if ``e`` is a variable, you can optimised his by not introducing a
+    fresh variable.
+
+The result will be a (possibly) recursive set of bindings, binding
+only simple variables on the left hand side. (One could go one step
+further, as in the Haskell Report and make the recursive bindings
+non-recursive using ``fix``, but we do not do so in Core, and it only
+obfuscates matters, so we do not do so here.)
+
+Here are some examples of how this translation works. The first
+expression of each sequence is Haskell source; the subsequent ones are
+Core.
+
+Here is a simple non-recursive case: ::
+
+    let x :: Int     -- Non-recursive
+        !x = factorial y
+    in body
+
+    ===> (FORCE)
+        let x = factorial y in x `seq` body
+
+    ===> (inline seq)
+        let x = factorial y in case x of x -> body
+
+    ===> (inline x)
+        case factorial y of x -> body
+
+Same again, only with a pattern binding: ::
+
+    let !(x,y) = if blob then (factorial p, factorial q) else (0,0)
+    in body
+
+    ===> (FORCE)
+        let v = if blob then (factorial p, factorial q) else (0,0)
+            (x,y) = v
+        in v `seq` body
+
+    ===> (SPLIT)
+        let v = if blob then (factorial p, factorial q) else (0,0)
+            x = case v of (x,y) -> x
+            y = case v of (x,y) -> y
+        in v `seq` body
+
+    ===> (inline seq, float x,y bindings inwards)
+        let v = if blob then (factorial p, factorial q) else (0,0)
+        in case v of v -> let x = case v of (x,y) -> x
+                                y = case v of (x,y) -> y
+                            in body
+
+    ===> (fluff up v's pattern; this is a standard Core optimisation)
+        let v = if blob then (factorial p, factorial q) else (0,0)
+        in case v of v@(p,q) -> let x = case v of (x,y) -> x
+                                    y = case v of (x,y) -> y
+                                in body
+
+    ===> (case of known constructor)
+        let v = if blob then (factorial p, factorial q) else (0,0)
+        in case v of v@(p,q) -> let x = p
+                                    y = q
+                                in body
+
+    ===> (inline x,y)
+        let v = if blob then (factorial p, factorial q) else (0,0)
+        in case v of (p,q) -> body[p/x, q/y]
+
+The final form is just what we want: a simple case expression.
+
+Here is a recursive case ::
+
+    letrec xs :: [Int]  -- Recursive
+            !xs = factorial y : xs
+    in body
+
+    ===> (FORCE)
+        letrec xs = factorial y : xs in xs `seq` body
+
+    ===> (inline seq)
+        letrec xs = factorial y : xs in case xs of xs -> body
+
+    ===> (eliminate case of value)
+        letrec xs = factorial y : xs in body
+
+and a polymorphic one: ::
+
+    let f :: forall a. [a] -> [a]    -- Polymorphic
+        !f = fst (reverse, True)
+    in body
+
+    ===> (FORCE)
+        let f = /\a. fst (reverse a, True) in f `seq` body
+    ===> (inline seq, inline f)
+        case (/\a. fst (reverse a, True)) of f -> body
+
+Notice that the ``seq`` is added only in the translation to Core
+If we did it in Haskell source, thus ::
+
+   let f = ... in f `seq` body
+
+then ``f``\ 's polymorphic type would get intantiated, so the Core
+translation would be ::
+
+   let f = ... in f Any `seq` body
+
+
+When overloading is involved, the results might be slightly counter
+intuitive: ::
+
+    let f :: forall a. Eq a => a -> [a] -> Bool    -- Overloaded
+        !f = fst (member, True)
+    in body
+
+    ===> (FORCE)
+        let f = /\a \(d::Eq a). fst (member, True) in f `seq` body
+
+    ===> (inline seq, case of value)
+        let f = /\a \(d::Eq a). fst (member, True) in body
+
+Note that the bang has no effect at all in this case
diff --git a/testsuite/tests/deSugar/should_compile/DsStrictWarn.hs b/testsuite/tests/deSugar/should_compile/DsStrictWarn.hs
new file mode 100644
index 0000000000..81b337d05b
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/DsStrictWarn.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}
+{-# LANGUAGE Strict #-}
+module DsStrictWarn where
+
+-- should warn about non-exhaustive pattern match
+w :: String -> String
+w x = let (_:_) = x in "1"
diff --git a/testsuite/tests/deSugar/should_compile/DsStrictWarn.stderr b/testsuite/tests/deSugar/should_compile/DsStrictWarn.stderr
new file mode 100644
index 0000000000..974e51c38c
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/DsStrictWarn.stderr
@@ -0,0 +1,4 @@
+
+DsStrictWarn.hs:7:11: warning:
+    Pattern match(es) are non-exhaustive
+    In a pattern binding: Patterns not matched: []
diff --git a/testsuite/tests/deSugar/should_compile/T5455.hs b/testsuite/tests/deSugar/should_compile/T5455.hs
index b6d44b8bcb..26c1a79384 100644
--- a/testsuite/tests/deSugar/should_compile/T5455.hs
+++ b/testsuite/tests/deSugar/should_compile/T5455.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}
 module T5455 where
 
--- No error message for this one: 
+-- No error message for this one:
 -- the pattern will never be demanded
 
 w :: String -> String
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index 543e01e8b3..c6b024f1b9 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -84,7 +84,7 @@ test('T4870',
 test('T5117', normal, compile, [''])
 test('T5252',
      extra_clean(['T5252a.hi', 'T5252a.o']),
-     run_command, 
+     run_command,
      ['$MAKE -s --no-print-directory T5252'])
 test('T5455', normal, compile, [''])
 test('T5001',
@@ -96,10 +96,11 @@ test('T5001',
 # T5252Take2 failed when compiled *wihtout* optimisation
 test('T5252Take2',
      extra_clean(['T5252Take2a.hi', 'T5252Take2a.o']),
-     run_command, 
+     run_command,
      ['$MAKE -s --no-print-directory T5252Take2'])
 test('T2431', normal, compile, ['-ddump-simpl -dsuppress-uniques'])
 test('T7669', normal, compile, [''])
 test('T8470', normal, compile, [''])
 test('T10251', normal, compile, [''])
 test('T10767', normal, compile, [''])
+test('DsStrictWarn', normal, compile, [''])
diff --git a/testsuite/tests/deSugar/should_fail/DsStrictFail.hs b/testsuite/tests/deSugar/should_fail/DsStrictFail.hs
new file mode 100644
index 0000000000..eadfd517e8
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/DsStrictFail.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE Strict #-}
+module Main where
+
+main = let False = True
+       in return ()
diff --git a/testsuite/tests/deSugar/should_fail/DsStrictFail.stderr b/testsuite/tests/deSugar/should_fail/DsStrictFail.stderr
new file mode 100644
index 0000000000..c7135b2a27
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/DsStrictFail.stderr
@@ -0,0 +1,2 @@
+DsStrictFail: DsStrictFail.hs:4:12-23: Irrefutable pattern failed for pattern False
+
diff --git a/testsuite/tests/deSugar/should_fail/Makefile b/testsuite/tests/deSugar/should_fail/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/deSugar/should_fail/all.T b/testsuite/tests/deSugar/should_fail/all.T
new file mode 100644
index 0000000000..1a501ba4c3
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/all.T
@@ -0,0 +1,6 @@
+# Args to compile_and_run are:
+#	extra compile flags
+#	extra run flags
+#	expected process return value, if not zero
+
+test('DsStrictFail', expect_fail, compile_and_run, [''])
diff --git a/testsuite/tests/deSugar/should_run/DsStrict.hs b/testsuite/tests/deSugar/should_run/DsStrict.hs
new file mode 100644
index 0000000000..ef3f06fd45
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrict.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE Strict #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+module Main where
+
+import Debug.Trace
+
+f0 a = "fun"
+f0' ~a = "fun2"
+
+f1 ~n =
+  case n of
+    a -> "case"
+f1' ~n =
+  case n of
+    ~a -> "case2"
+
+f2 = \a -> "lamda"
+f2' = \ ~a -> "lambda2"
+
+newtype Age = MkAge Int
+
+f4, f4' :: Age -> String
+f4 (MkAge a) = "newtype"
+f4' ~(MkAge a) = "newtype2"
+
+main :: IO ()
+main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs
+  where fs =
+          [("fun",f0 )
+          ,("fun lazy",f0')
+          ,("case",f1)
+          ,("case lazy",f1')
+          ,("lambda",f2)
+          ,("lambda lazy",f2')
+          ,("newtype",(\ ~i -> f4 (MkAge i)))
+          ,("newtype lazy",(\ ~i -> f4' (MkAge i)))]
+        v n = trace ("evaluated in " ++ n) 1
diff --git a/testsuite/tests/deSugar/should_run/DsStrict.stderr b/testsuite/tests/deSugar/should_run/DsStrict.stderr
new file mode 100644
index 0000000000..0097ca9a43
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrict.stderr
@@ -0,0 +1,4 @@
+evaluated in fun
+evaluated in case
+evaluated in lambda
+evaluated in newtype
diff --git a/testsuite/tests/deSugar/should_run/DsStrict.stdout b/testsuite/tests/deSugar/should_run/DsStrict.stdout
new file mode 100644
index 0000000000..7895f2a0cb
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrict.stdout
@@ -0,0 +1,8 @@
+fun
+fun2
+case
+case2
+lamda
+lambda2
+newtype
+newtype2
diff --git a/testsuite/tests/deSugar/should_run/DsStrictLet.hs b/testsuite/tests/deSugar/should_run/DsStrictLet.hs
new file mode 100644
index 0000000000..ee515da716
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrictLet.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE Strict #-}
+module Main where
+
+import Debug.Trace
+
+main = let False = trace "no binders" False -- evaluated
+
+           a :: a -> a
+           a = trace "polymorphic" id -- evaluated
+
+           f :: Eq a => a -> a -> Bool
+           f = trace "overloaded" (==) -- not evaluated
+
+           xs :: [Int]
+           xs = (trace "recursive" (:) 1 xs) -- evaluated
+       in return ()
diff --git a/testsuite/tests/deSugar/should_run/DsStrictLet.stderr b/testsuite/tests/deSugar/should_run/DsStrictLet.stderr
new file mode 100644
index 0000000000..f0fcb1bc32
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrictLet.stderr
@@ -0,0 +1,3 @@
+recursive
+polymorphic
+no binders
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index bc72b01568..cc21ed7248 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -50,3 +50,5 @@ test('T9238', normal, compile_and_run, [''])
 test('T9844', normal, compile_and_run, [''])
 test('T10215', normal, compile_and_run, [''])
 test('DsStrictData', normal, compile_and_run, [''])
+test('DsStrict', normal, compile_and_run, [''])
+test('DsStrictLet', normal, compile_and_run, ['-O'])
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index f345ce6b1f..0d9d146d95 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -32,7 +32,8 @@ check title expected got
 expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
-                             "AlternativeLayoutRuleTransitional"]
+                             "AlternativeLayoutRuleTransitional",
+                             "Strict"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/ghci/scripts/T9140.script b/testsuite/tests/ghci/scripts/T9140.script
index 833ea87413..53eb63afa9 100644
--- a/testsuite/tests/ghci/scripts/T9140.script
+++ b/testsuite/tests/ghci/scripts/T9140.script
@@ -1,5 +1,5 @@
-:set -XUnboxedTuples -XBangPatterns
+:set -XUnboxedTuples
 let a = (# 1 #)
 let a = (# 1, 3 #)
-:set -XBangPatterns
-let !a = (# 1, 3 #)
+
+let a = (# 1, 3 #) :: (# Integer, Integer #)
diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout
index d9520c0960..6456067f59 100644
--- a/testsuite/tests/ghci/scripts/T9140.stdout
+++ b/testsuite/tests/ghci/scripts/T9140.stdout
@@ -1,14 +1,14 @@
 
-<interactive>:2:5:
+<interactive>:2:5: error:
     You can't mix polymorphic and unlifted bindings
       a = (# 1 #)
-      Probable fix: use a bang pattern
+      Probable fix: add a type signature
 
-<interactive>:3:5:
+<interactive>:3:5: error:
     You can't mix polymorphic and unlifted bindings
       a = (# 1, 3 #)
-      Probable fix: use a bang pattern
+      Probable fix: add a type signature
 
-<interactive>:1:1:
+<interactive>:1:1: error:
     GHCi can't bind a variable of unlifted type:
       a :: (# Integer, Integer #)
diff --git a/testsuite/tests/typecheck/should_fail/T6078.stderr b/testsuite/tests/typecheck/should_fail/T6078.stderr
index 467dede23f..b45363bdc3 100644
--- a/testsuite/tests/typecheck/should_fail/T6078.stderr
+++ b/testsuite/tests/typecheck/should_fail/T6078.stderr
@@ -1,8 +1,8 @@
 
-T6078.hs:8:10:
+T6078.hs:8:10: error:
     You can't mix polymorphic and unlifted bindings
       ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len
-      Probable fix: use a bang pattern
+      Probable fix: add a type signature
     In the expression:
       let ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len in ip1p
     In the expression: