Ensure nested binders have Internal Names
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 4 Jan 2017 17:47:13 +0000 (17:47 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 5 Jan 2017 08:51:46 +0000 (08:51 +0000)
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.

compiler/coreSyn/CoreLint.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs
testsuite/tests/deSugar/should_compile/T13043.hs [new file with mode: 0644]
testsuite/tests/deSugar/should_compile/all.T

index b4946a2..79e577a 100644 (file)
@@ -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') }
 
index cc621d5..290c172 100644 (file)
@@ -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
 
index ef19475..672157e 100644 (file)
@@ -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 (file)
index 0000000..443bfdc
--- /dev/null
@@ -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 ()
index 6d026db..aa8dd87 100644 (file)
@@ -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, [''])