diff options
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: |