Commit 46a03fbe authored by Adam Sandberg Eriksson's avatar Adam Sandberg Eriksson 🐈 Committed by Ben Gamari

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
parent 54884220
This diff is collapsed.
......@@ -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
{-
************************************************************************
......
......@@ -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)
......@@ -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
......
......@@ -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*
......
......@@ -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,
......
......@@ -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
......
This diff is collapsed.
{-# 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"
DsStrictWarn.hs:7:11: warning:
Pattern match(es) are non-exhaustive
In a pattern binding: Patterns not matched: []
{-# 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
......
......@@ -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, [''])
{-# LANGUAGE Strict #-}
module Main where
main = let False = True
in return ()
DsStrictFail: DsStrictFail.hs:4:12-23: Irrefutable pattern failed for pattern False
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
# 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, [''])
{-# 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
evaluated in fun
evaluated in case
evaluated in lambda
evaluated in newtype
fun
fun2
case
case2
lamda
lambda2
newtype
newtype2
{-# 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 ()
......@@ -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'])
......@@ -32,7 +32,8 @@ check title expected got
expectedGhcOnlyExtensions :: [String]
expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRule",
"AlternativeLayoutRuleTransitional"]
"AlternativeLayoutRuleTransitional",
"Strict"]
expectedCabalOnlyExtensions :: [String]
expectedCabalOnlyExtensions = ["Generics",
......
:set -XUnboxedTuples -XBangPatterns
:set -XUnboxedTuples
let a = (# 1 #)
let a = (# 1, 3 #)
:set -XBangPatterns
let !a = (# 1, 3 #)
let a = (# 1, 3 #) :: (# Integer, Integer #)
<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 #)
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:
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment