Commit 01449eb5 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix desugaring of bang-pattern let-bindings

When implementing Strict Haskell, the patch 46a03fbe didn't faithfully
implement the semantics given in the manual. In particular there was
an ad-hoc case in mkSelectorBinds for "strict and no binders" that
didn't work.

This patch fixes it, curing Trac #11572.

Howver it forced me to think about banged let-bindings, and I rather
think we do not have quite the right semantics yet, so I've opened
Trac #11601.
parent 27842ec1
...@@ -601,13 +601,13 @@ OR (B) t = case e of p -> (x,y) ...@@ -601,13 +601,13 @@ OR (B) t = case e of p -> (x,y)
x = case t of (x,_) -> x x = case t of (x,_) -> x
y = case t of (_,y) -> y y = case t of (_,y) -> y
We do (A) when We do (A) when (test: isSingleton binders)
* Matching the pattern is cheap so we don't mind * The pattern binds only one variable (so we'll only match once)
doing it twice.
* Or if the pattern binds only one variable (so we'll only OR when (test: is_simple_lpat)
match once) * Matching the pattern is cheap so we don't mind doing it twice.
* AND the pattern can't fail (else we tiresomely get two inexhaustive * AND the pattern can't fail (else we tiresomely get one
pattern warning messages) inexhaustive pattern warning message for each binder
Otherwise we do (B). Really (A) is just an optimisation for very common Otherwise we do (B). Really (A) is just an optimisation for very common
cases like cases like
...@@ -633,7 +633,8 @@ mkSelectorBinds _ ticks (L _ (VarPat (L _ v))) val_expr ...@@ -633,7 +633,8 @@ mkSelectorBinds _ ticks (L _ (VarPat (L _ v))) val_expr
mkSelectorBinds is_strict ticks pat val_expr mkSelectorBinds is_strict ticks pat val_expr
| null binders, not is_strict | null binders, not is_strict
= return (Nothing, []) = return (Nothing, [])
| isSingleton binders || is_simple_lpat pat
| isSingleton binders || is_simple_lpat pat -- Case (A)
-- See Note [mkSelectorBinds] -- See Note [mkSelectorBinds]
= do { let pat_ty = hsLPatType pat = do { let pat_ty = hsLPatType pat
; val_var <- newSysLocalDs pat_ty ; val_var <- newSysLocalDs pat_ty
...@@ -661,26 +662,22 @@ mkSelectorBinds is_strict ticks pat val_expr ...@@ -661,26 +662,22 @@ mkSelectorBinds is_strict ticks pat val_expr
(err_var, Lam alphaTyVar err_app) : (err_var, Lam alphaTyVar err_app) :
binds) } binds) }
| otherwise | otherwise -- Case (B)
= do { val_var <- newSysLocalDs (hsLPatType pat) = do { val_var <- newSysLocalDs (hsLPatType pat)
; tuple_var <- newSysLocalDs tuple_ty
; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat) ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
; tuple_expr ; tuple_expr <- matchSimply (Var val_var) PatBindRhs pat
<- matchSimply (Var val_var) PatBindRhs pat local_tuple error_expr local_tuple error_expr
; tuple_var <- newSysLocalDs tuple_ty
; let mk_tup_bind tick binder ; let mk_tup_bind tick binder
= (binder, mkOptTickBox tick $ = (binder, mkOptTickBox tick $
mkTupleSelector local_binders binder mkTupleSelector local_binders binder
tuple_var (Var tuple_var)) tuple_var (Var tuple_var))
-- if strict and no binders we want to force the case tup_binds
-- expression to force an error if the pattern match | null binders = []
-- failed. See Note [Desugar Strict binds] in DsBinds. | otherwise = (tuple_var, tuple_expr)
; let force_var = if null binders && is_strict : zipWith mk_tup_bind ticks' binders
then tuple_var ; return ( Just val_var
else val_var , (val_var,val_expr) : tup_binds ) }
; return (Just force_var
,(val_var,val_expr) :
(tuple_var, tuple_expr) :
zipWith mk_tup_bind ticks' binders) }
where where
binders = collectPatBinders pat binders = collectPatBinders pat
ticks' = ticks ++ repeat [] ticks' = ticks ++ repeat []
......
This diff is collapsed.
{-# LANGUAGE BangPatterns #-}
module Main where
main :: IO ()
main = let !_ = (undefined :: ()) in print 2
T11572: Prelude.undefined
CallStack (from HasCallStack):
error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err
undefined, called at T11572.hs:6:18 in main:Main
...@@ -50,3 +50,4 @@ test('DsStrictData', normal, compile_and_run, ['']) ...@@ -50,3 +50,4 @@ test('DsStrictData', normal, compile_and_run, [''])
test('DsStrict', normal, compile_and_run, ['']) test('DsStrict', normal, compile_and_run, [''])
test('DsStrictLet', normal, compile_and_run, ['-O']) test('DsStrictLet', normal, compile_and_run, ['-O'])
test('T11193', exit_code(1), compile_and_run, ['']) test('T11193', exit_code(1), compile_and_run, [''])
test('T11572', exit_code(1), compile_and_run, [''])
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