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

7 files changed, 318 insertions, 107 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