diff options
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 61 | ||||
| -rw-r--r-- | compiler/deSugar/DsUtils.hs | 11 | ||||
| -rw-r--r-- | compiler/deSugar/Match.hs | 44 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_compile/T13043.hs | 28 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_compile/all.T | 1 |
5 files changed, 94 insertions, 51 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index b4946a274b..79e577a61f 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -474,7 +474,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) = addLoc (RhsOf binder) $ -- Check the rhs do { ty <- lintRhs rhs - ; lintBinder binder -- Check match to RHS type + ; lint_bndr binder -- Check match to RHS type ; binder_ty <- applySubstTy (idType binder) ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty) @@ -489,14 +489,6 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) (mkStrictMsg binder) - -- Check that if the binder is local, it is not marked as exported - ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) - (mkNonTopExportedMsg binder) - - -- Check that if the binder is local, it does not have an external name - ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) - (mkNonTopExternalNameMsg binder) - ; flags <- getLintFlags ; when (lf_check_inline_loop_breakers flags && isStrongLoopBreaker (idOccInfo binder) @@ -540,8 +532,8 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) where -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] - lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) - | otherwise = return () + lint_bndr var | isId var = lintIdBndr top_lvl_flag var $ \_ -> return () + | otherwise = return () -- | Checks the RHS of top-level bindings. It only differs from 'lintCoreExpr' -- in that it doesn't reject applications of the data constructor @StaticPtr@ @@ -662,13 +654,13 @@ lintCoreExpr (Let (NonRec bndr rhs) body) | isId bndr = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) ; addLoc (BodyOfLetRec [bndr]) - (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) } + (lintIdBndr NotTopLevel bndr $ \_ -> lintCoreExpr body) } | otherwise = failWithL (mkLetErr bndr rhs) -- Not quite accurate lintCoreExpr (Let (Rec pairs) body) - = lintAndScopeIds bndrs $ \_ -> + = lintIdBndrs bndrs $ \_ -> do { checkL (null dups) (dupVars dups) ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } @@ -741,7 +733,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = ; subst <- getTCvSubst ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - ; lintAndScopeId var $ \_ -> + ; lintIdBndr NotTopLevel var $ \_ -> do { -- Check the alternatives mapM_ (lintCoreAlt scrut_ty alt_ty) alts ; checkCaseAlts e scrut_ty alts @@ -986,9 +978,9 @@ lintBinders (var:vars) linterF = lintBinder var $ \var' -> -- See Note [GHC Formalism] lintBinder :: Var -> (Var -> LintM a) -> LintM a lintBinder var linterF - | isTyVar var = lintTyBndr var linterF - | isCoVar var = lintCoBndr var linterF - | otherwise = lintIdBndr var linterF + | isTyVar var = lintTyBndr var linterF + | isCoVar var = lintCoBndr var linterF + | otherwise = lintIdBndr NotTopLevel var linterF lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a lintTyBndr tv thing_inside @@ -1006,33 +998,40 @@ lintCoBndr cv thing_inside (text "CoVar with non-coercion type:" <+> pprTyVar cv) ; updateTCvSubst subst' (thing_inside cv') } -lintIdBndr :: Id -> (Id -> LintM a) -> LintM a --- Do substitution on the type of a binder and add the var with this --- new type to the in-scope set of the second argument --- ToDo: lint its rules - -lintIdBndr id linterF - = do { lintAndScopeId id $ \id' -> linterF id' } - -lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a -lintAndScopeIds ids linterF +lintIdBndrs :: [Var] -> ([Var] -> LintM a) -> LintM a +lintIdBndrs ids linterF = go ids where go [] = linterF [] - go (id:ids) = lintAndScopeId id $ \id -> - lintAndScopeIds ids $ \ids -> + go (id:ids) = lintIdBndr NotTopLevel id $ \id -> + lintIdBndrs ids $ \ids -> linterF (id:ids) -lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a -lintAndScopeId id linterF +lintIdBndr :: TopLevelFlag -> InVar -> (OutVar -> LintM a) -> LintM a +-- Do substitution on the type of a binder and add the var with this +-- new type to the in-scope set of the second argument +-- ToDo: lint its rules +lintIdBndr top_lvl id linterF = do { flags <- getLintFlags ; checkL (not (lf_check_global_ids flags) || isLocalId id) (text "Non-local Id binder" <+> ppr id) -- See Note [Checking for global Ids] + + -- Check that if the binder is nested, it is not marked as exported + ; checkL (not (isExportedId id) || isTopLevel top_lvl) + (mkNonTopExportedMsg id) + + -- Check that if the binder is nested, it does not have an external name + ; checkL (not (isExternalName (Var.varName id)) || isTopLevel top_lvl) + (mkNonTopExternalNameMsg id) + ; (ty, k) <- lintInTy (idType id) + + -- Check for levity polymorphism ; lintL (not (isLevityPolymorphic k)) (text "RuntimeRep-polymorphic binder:" <+> (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k))) + ; let id' = setIdType id ty ; addInScopeVar id' $ (linterF id') } diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index cc621d5d4f..290c172a14 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -40,14 +40,14 @@ module DsUtils ( #include "HsVersions.h" -import {-# SOURCE #-} Match ( matchSimply ) +import {-# SOURCE #-} Match ( matchSimply ) +import {-# SOURCE #-} DsExpr ( dsLExpr ) import HsSyn import TcHsSyn import TcType( tcSplitTyConApp ) import CoreSyn import DsMonad -import {-# SOURCE #-} DsExpr ( dsLExpr ) import CoreUtils import MkCore @@ -55,7 +55,6 @@ import MkId import Id import Literal import TyCon --- import ConLike import DataCon import PatSyn import Type @@ -68,6 +67,7 @@ import UniqSet import UniqSupply import Module import PrelNames +import Name( isInternalName ) import Outputable import SrcLoc import Util @@ -546,8 +546,9 @@ mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] where case_bndr = case arg1 of - Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] - _ -> mkWildValBinder ty1 + Var v1 | isInternalName (idName v1) + -> v1 -- Note [Desugaring seq (2) and (3)] + _ -> mkWildValBinder ty1 mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index ef194756b0..672157e0d7 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -155,9 +155,20 @@ constructors, or all variables (or similar beasts), etc. @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. + +Note [Match Ids] +~~~~~~~~~~~~~~~~ +Most of the matching fuctions take an Id or [Id] as argument. This Id +is the scrutinee(s) of the match. The desugared expression may +sometimes use that Id in a local binding or as a case binder. So it +should not have an External name; Lint rejects non-top-level binders +with External names (Trac #13043). -} -match :: [Id] -- Variables rep\'ing the exprs we\'re matching with +type MatchId = Id -- See Note [Match Ids] + +match :: [MatchId] -- Variables rep\'ing the exprs we\'re matching with + -- See Note [Match Ids] -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! @@ -171,7 +182,8 @@ match [] ty eqns | eqn <- eqns ] match vars@(v:_) ty eqns -- Eqns *can* be empty - = do { dflags <- getDynFlags + = ASSERT2( all (isInternalName . idName) vars, ppr vars ) + do { dflags <- getDynFlags -- Tidy the first pattern, generating -- auxiliary bindings if necessary ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns @@ -224,7 +236,7 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) (filter (not . null) gs)) -matchEmpty :: Id -> Type -> DsM [MatchResult] +matchEmpty :: MatchId -> Type -> DsM [MatchResult] -- See Note [Empty case expressions] matchEmpty var res_ty = return [MatchResult CanFail mk_seq] @@ -232,20 +244,20 @@ matchEmpty var res_ty mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty [(DEFAULT, [], fail)] -matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -- Real true variables, just like in matchVar, SLPJ p 94 -- No binding to do: they'll all be wildcards by now (done in tidy) matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns) matchVariables [] _ _ = panic "matchVariables" -matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult matchBangs (var:vars) ty eqns = do { match_result <- match (var:vars) ty $ map (decomposeFirstPat getBangPat) eqns ; return (mkEvalMatchResult var ty match_result) } matchBangs [] _ _ = panic "matchBangs" -matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) = do { let CoPat co pat _ = firstPat eqn1 @@ -258,7 +270,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_)) ; return (mkCoLetMatchResult bind match_result) } matchCoercion _ _ _ = panic "matchCoercion" -matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the view function to the match variable and then match that matchView (var:vars) ty (eqns@(eqn1:_)) = do { -- we could pass in the expr from the PgView, @@ -277,7 +289,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) match_result) } matchView _ _ _ = panic "matchView" -matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView @@ -725,7 +737,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches matchEquations :: HsMatchContext Name - -> [Id] -> [EquationInfo] -> Type + -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr matchEquations ctxt vars eqns_info rhs_ty = do { let error_doc = matchContextErrString ctxt @@ -764,12 +776,15 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id -> Type -> MatchResult -> DsM MatchResult +-- matchSinglePat ensures that the scrutinee is a variable +-- and then calls match_single_pat_var +-- -- matchSinglePat does not warn about incomplete patterns -- Used for things like [ e | pat <- stuff ], where -- incomplete patterns are just fine matchSinglePat (Var var) ctx pat ty match_result - | isLocalId var + | not (isExternalName (idName var)) = match_single_pat_var var ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result @@ -777,12 +792,12 @@ matchSinglePat scrut hs_ctx pat ty match_result ; match_result' <- match_single_pat_var var hs_ctx pat ty match_result ; return (adjustMatchResult (bindNonRec var scrut) match_result') } -match_single_pat_var :: Id -> HsMatchContext Name -> LPat Id +match_single_pat_var :: Id -- See Note [Match Ids] + -> HsMatchContext Name -> LPat Id -> Type -> MatchResult -> DsM MatchResult --- matchSinglePat ensures that the scrutinee is a variable --- and then calls match_single_pat_var match_single_pat_var var ctx pat ty match_result - = do { dflags <- getDynFlags + = ASSERT2( isInternalName (idName var), ppr var ) + do { dflags <- getDynFlags ; locn <- getSrcSpanDs -- Pattern match check warnings @@ -793,7 +808,6 @@ match_single_pat_var var ctx pat ty match_result ; match [var] ty [eqn_info] } - {- ************************************************************************ * * diff --git a/testsuite/tests/deSugar/should_compile/T13043.hs b/testsuite/tests/deSugar/should_compile/T13043.hs new file mode 100644 index 0000000000..443bfdc9e8 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T13043.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BangPatterns #-} +module T13043 (foo, bar) where + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import System.IO.Unsafe (unsafePerformIO) + +{-# NOINLINE scServerState #-} +scServerState :: SCServerState +scServerState = unsafePerformIO (return undefined) + +data SCServerState = SCServerState + { scServer_socket :: IORef (Maybe Int) + } + +foo :: IO Int +foo = do + let !_ = scServerState + readIORef (scServer_socket scServerState) >>= \xs -> case xs of + Nothing -> do + s <- undefined + writeIORef (scServer_socket scServerState) (Just s) + return s + Just s -> return s + +bar :: IO () +bar = do + let !_ = scServerState + return () diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T index 6d026db3fb..aa8dd87d50 100644 --- a/testsuite/tests/deSugar/should_compile/all.T +++ b/testsuite/tests/deSugar/should_compile/all.T @@ -107,3 +107,4 @@ test('T10662', normal, compile, ['-Wall']) test('T11414', normal, compile, ['']) test('T12944', normal, compile, ['']) test('T12950', normal, compile, ['']) +test('T13043', normal, compile, ['']) |