Commit baf9ebe5 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Ensure nested binders have Internal Names

This is a long-standing bug.  A nested (non-top-level) binder
in Core should not have an External Name, like M.x. But

- Lint was not checking this invariant

- The desugarer could generate programs that failed the
  invariant.  An example is in
  tests/deSugar/should_compile/T13043, which had
     let !_ = M.scState in ...
  This desugared to
     let ds = case M.scSate of M.scState { DEFAULT -> () }
     in case ds of () -> ...

  We were wrongly re-using that scrutinee as a case binder.
  And Trac #13043 showed that could ultimately lead to two
  top-level bindings with the same closure name.  Alas!

- The desugarer had one other place (in DsUtils.mkCoreAppDs)
  that could generate bogus code

This patch fixes all three bugs, and adds a regression test.
parent c909e6ec
......@@ -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') }
......
......@@ -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
......
......@@ -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] }
{-
************************************************************************
* *
......
{-# 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 ()
......@@ -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, [''])
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