Fix StgLint bound id check, generalize StgLint

StgLint was incorrectly using isLocalId for bound id check to see
whether an id is imported (in which case we don't expect it to be bound)
or local.  The problem with isLocalId is that its semantics changes
after Core, as explained in the note: (last line)

    Note [GlobalId/LocalId]
    ~~~~~~~~~~~~~~~~~~~~~~~
    A GlobalId is
      * always a constant (top-level)
      * imported, or data constructor, or primop, or record selector
      * has a Unique that is globally unique across the whole
        GHC invocation (a single invocation may compile multiple
        modules)
      * never treated as a candidate by the free-variable finder;
            it's a constant!

    A LocalId is
      * bound within an expression (lambda, case, local let(rec))
      * or defined at top level in the module being compiled
      * always treated as a candidate by the free-variable finder

    After CoreTidy, top-level LocalIds are turned into GlobalIds

We now pass current module as a parameter to StgLint, which uses it to
see if an id should be bound (defined in the current module) or not
(imported).

Other changes:

- Generalized StgLint to make it work on both StgTopBinding and
  CgStgTopBinding.
- Bring all top-level binders into scope before linting top-level
  bindings to allow uses before definitions.

TODO: We should remove the binder from local vars when checking RHSs of
non-recursive bindings.

Test Plan: This validates.

Reviewers: simonpj, bgamari, sgraf

Reviewed By: simonpj, sgraf

Subscribers: rwbarton, carter

Differential Revision: https://phabricator.haskell.org/D5370

5 files changed, 109 insertions, 60 deletions

diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 38dc727983..5102fa09ba 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1488,7 +1488,7 @@ myCoreToStg dflags this_mod prepd_binds = do
 
     stg_binds2
         <- {-# SCC "Stg2Stg" #-}
-           stg2stg dflags stg_binds
+           stg2stg dflags this_mod stg_binds
 
     return (stg_binds2, cost_centre_info)
 
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 327f614b68..81665a8735 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -6,6 +6,8 @@
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module SimplStg ( stg2stg ) where
 
@@ -20,6 +22,7 @@ import StgStats         ( showStgStats )
 import UnariseStg       ( unarise )
 import StgCse           ( stgCse )
 import StgLiftLams      ( stgLiftLams )
+import Module           ( Module )
 
 import DynFlags
 import ErrUtils
@@ -40,10 +43,11 @@ runStgM :: UniqSupply -> StgM a -> IO a
 runStgM us (StgM m) = evalStateT m us
 
 stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
-        -> [StgTopBinding]           -- input...
+        -> Module                    -- module being compiled
+        -> [StgTopBinding]           -- input program
         -> IO [StgTopBinding]        -- output program
 
-stg2stg dflags binds
+stg2stg dflags this_mod binds
   = do  { showPass dflags "Stg2Stg"
         ; us <- mkSplitUniqSupply 'g'
 
@@ -58,8 +62,10 @@ stg2stg dflags binds
 
   where
     stg_linter what
-      | gopt Opt_DoStgLinting dflags = lintStgTopBindings dflags what
-      | otherwise                    = \ _whodunnit _binds -> return ()
+      | gopt Opt_DoStgLinting dflags
+      = lintStgTopBindings dflags this_mod what
+      | otherwise
+      = \ _whodunnit _binds -> return ()
 
     -------------------------------------------
     do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
@@ -81,7 +87,7 @@ stg2stg dflags binds
             end_pass "StgLiftLams" binds'
 
           StgUnarise -> do
-            dump_when Opt_D_dump_stg "Pre unarise:" binds
+            liftIO (dump_when Opt_D_dump_stg "Pre unarise:" binds)
             us <- getUniqueSupplyM
             liftIO (stg_linter False "Pre-unarise" binds)
             let binds' = unarise us binds
@@ -89,7 +95,7 @@ stg2stg dflags binds
             return binds'
 
     dump_when flag header binds
-      = liftIO (dumpIfSet_dyn dflags flag header (pprStgTopBindings binds))
+      = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds)
 
     end_pass what binds2
       = liftIO $ do -- report verbosely, if required
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index 383b016f08..c949f348f1 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -32,6 +32,8 @@ Since then there were some attempts at enabling it again, as summarised in
 basic properties listed above.
 -}
 
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-}
+
 module StgLint ( lintStgTopBindings ) where
 
 import GhcPrelude
@@ -42,29 +44,32 @@ import DynFlags
 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel )
 import CostCentre       ( isCurrentCCS )
-import Id               ( Id, idType, isLocalId, isJoinId )
+import Id               ( Id, idType, isJoinId, idName )
 import VarSet
 import DataCon
 import CoreSyn          ( AltCon(..) )
-import Name             ( getSrcLoc )
+import Name             ( getSrcLoc, nameIsLocalOrFrom )
 import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
 import Type
 import RepType
 import SrcLoc
 import Outputable
+import Module           ( Module )
 import qualified ErrUtils as Err
 import Control.Applicative ((<|>))
 import Control.Monad
 
-lintStgTopBindings :: DynFlags
+lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
+                   => DynFlags
+                   -> Module -- ^ module being compiled
                    -> Bool   -- ^ have we run Unarise yet?
                    -> String -- ^ who produced the STG?
-                   -> [StgTopBinding]
+                   -> [GenStgTopBinding a]
                    -> IO ()
 
-lintStgTopBindings dflags unarised whodunnit binds
+lintStgTopBindings dflags this_mod unarised whodunnit binds
   = {-# SCC "StgLint" #-}
-    case initL unarised (lint_binds binds) of
+    case initL this_mod unarised top_level_binds (lint_binds binds) of
       Nothing  ->
         return ()
       Just msg -> do
@@ -74,11 +79,15 @@ lintStgTopBindings dflags unarised whodunnit binds
                         text whodunnit <+> text "***",
                   msg,
                   text "*** Offending Program ***",
-                  pprStgTopBindings binds,
+                  pprGenStgTopBindings binds,
                   text "*** End of Offense ***"])
         Err.ghcExit dflags 1
   where
-    lint_binds :: [StgTopBinding] -> LintM ()
+    -- Bring all top-level binds into scope because CoreToStg does not generate
+    -- bindings in dependency order (so we may see a use before its definition).
+    top_level_binds = mkVarSet (bindersOfTopBinds binds)
+
+    lint_binds :: [GenStgTopBinding a] -> LintM ()
 
     lint_binds [] = return ()
     lint_binds (bind:binds) = do
@@ -96,7 +105,9 @@ lintStgArg (StgVarArg v) = lintStgVar v
 lintStgVar :: Id -> LintM ()
 lintStgVar id = checkInScope id
 
-lintStgBinds :: TopLevelFlag -> StgBinding -> LintM [Id] -- Returns the binders
+lintStgBinds
+    :: (OutputablePass a, BinderP a ~ Id)
+    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
 lintStgBinds top_lvl (StgNonRec binder rhs) = do
     lint_binds_help top_lvl (binder,rhs)
     return [binder]
@@ -108,7 +119,11 @@ lintStgBinds top_lvl (StgRec pairs)
   where
     binders = [b | (b,_) <- pairs]
 
-lint_binds_help :: TopLevelFlag -> (Id, StgRhs) -> LintM ()
+lint_binds_help
+    :: (OutputablePass a, BinderP a ~ Id)
+    => TopLevelFlag
+    -> (Id, GenStgRhs a)
+    -> LintM ()
 lint_binds_help top_lvl (binder, rhs)
   = addLoc (RhsOf binder) $ do
         when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
@@ -119,17 +134,20 @@ lint_binds_help top_lvl (binder, rhs)
 
 -- | Top-level bindings can't inherit the cost centre stack from their
 -- (static) allocation site.
-checkNoCurrentCCS :: StgRhs -> LintM ()
-checkNoCurrentCCS (StgRhsClosure _ ccs _ _ _)
+checkNoCurrentCCS
+    :: (OutputablePass a, BinderP a ~ Id)
+    => GenStgRhs a
+    -> LintM ()
+checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)
   | isCurrentCCS ccs
-  = addErrL (text "Top-level StgRhsClosure with CurrentCCS")
-checkNoCurrentCCS (StgRhsCon ccs _ _)
+  = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)
+checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)
   | isCurrentCCS ccs
-  = addErrL (text "Top-level StgRhsCon with CurrentCCS")
+  = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)
 checkNoCurrentCCS _
   = return ()
 
-lintStgRhs :: StgRhs -> LintM ()
+lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
 
 lintStgRhs (StgRhsClosure _ _ _ [] expr)
   = lintStgExpr expr
@@ -146,7 +164,7 @@ lintStgRhs rhs@(StgRhsCon _ con args) = do
     mapM_ lintStgArg args
     mapM_ checkPostUnariseConArg args
 
-lintStgExpr :: StgExpr -> LintM ()
+lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
 
 lintStgExpr (StgLit _) = return ()
 
@@ -191,7 +209,9 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = do
 
     addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
 
-lintAlt :: (AltCon, [Id], StgExpr) -> LintM ()
+lintAlt
+    :: (OutputablePass a, BinderP a ~ Id)
+    => (AltCon, [Id], GenStgExpr a) -> LintM ()
 
 lintAlt (DEFAULT, _, rhs) =
     lintStgExpr rhs
@@ -206,15 +226,35 @@ lintAlt (DataAlt _, bndrs, rhs) = do
 {-
 ************************************************************************
 *                                                                      *
-\subsection[lint-monad]{The Lint monad}
+Utilities
+*                                                                      *
+************************************************************************
+-}
+
+bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
+bindersOf (StgNonRec binder _) = [binder]
+bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]
+
+bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
+bindersOfTop (StgTopLifted bind) = bindersOf bind
+bindersOfTop (StgTopStringLit binder _) = [binder]
+
+bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
+bindersOfTopBinds = foldr ((++) . bindersOfTop) []
+
+{-
+************************************************************************
+*                                                                      *
+The Lint monad
 *                                                                      *
 ************************************************************************
 -}
 
 newtype LintM a = LintM
-    { unLintM :: LintFlags
-              -> [LintLocInfo]      -- Locations
-              -> IdSet              -- Local vars in scope
+    { unLintM :: Module
+              -> LintFlags
+              -> [LintLocInfo]     -- Locations
+              -> IdSet             -- Local vars in scope
               -> Bag MsgDoc        -- Error messages so far
               -> (a, Bag MsgDoc)   -- Result and error messages (if any)
     }
@@ -245,22 +285,19 @@ pp_binders bs
     pp_binder b
       = hsep [ppr b, dcolon, ppr (idType b)]
 
-initL :: Bool -> LintM a -> Maybe MsgDoc
-initL unarised (LintM m)
-  = case (m lf [] emptyVarSet emptyBag) of { (_, errs) ->
-    if isEmptyBag errs then
-        Nothing
-    else
-        Just (vcat (punctuate blankLine (bagToList errs)))
-    }
-  where
-    lf = LintFlags unarised
+initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
+initL this_mod unarised locals (LintM m) = do
+  let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag
+  if isEmptyBag errs then
+      Nothing
+  else
+      Just (vcat (punctuate blankLine (bagToList errs)))
 
 instance Functor LintM where
       fmap = liftM
 
 instance Applicative LintM where
-      pure a = LintM $ \_lf _loc _scope errs -> (a, errs)
+      pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
       (<*>) = ap
       (*>)  = thenL_
 
@@ -269,14 +306,14 @@ instance Monad LintM where
     (>>)  = (*>)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \lf loc scope errs
-  -> case unLintM m lf loc scope errs of
-      (r, errs') -> unLintM (k r) lf loc scope errs'
+thenL m k = LintM $ \mod lf loc scope errs
+  -> case unLintM m mod lf loc scope errs of
+      (r, errs') -> unLintM (k r) mod lf loc scope errs'
 
 thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \lf loc scope errs
-  -> case unLintM m lf loc scope errs of
-      (_, errs') -> unLintM k lf loc scope errs'
+thenL_ m k = LintM $ \mod lf loc scope errs
+  -> case unLintM m mod lf loc scope errs of
+      (_, errs') -> unLintM k mod lf loc scope errs'
 
 checkL :: Bool -> MsgDoc -> LintM ()
 checkL True  _   = return ()
@@ -321,7 +358,7 @@ checkPostUnariseId id =
       is_sum <|> is_tuple <|> is_void
 
 addErrL :: MsgDoc -> LintM ()
-addErrL msg = LintM $ \_lf loc _scope errs -> ((), addErr errs msg loc)
+addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)
 
 addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
 addErr errs_so_far msg locs
@@ -332,27 +369,27 @@ addErr errs_so_far msg locs
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \lf loc scope errs
-   -> unLintM m lf (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \mod lf loc scope errs
+   -> unLintM m mod lf (extra_loc:loc) scope errs
 
 addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \lf loc scope errs
+addInScopeVars ids m = LintM $ \mod lf loc scope errs
  -> let
         new_set = mkVarSet ids
-    in unLintM m lf loc (scope `unionVarSet` new_set) errs
+    in unLintM m mod lf loc (scope `unionVarSet` new_set) errs
 
 getLintFlags :: LintM LintFlags
-getLintFlags = LintM $ \lf _loc _scope errs -> (lf, errs)
+getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)
 
 checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \_lf loc scope errs
- -> if isLocalId id && not (id `elemVarSet` scope) then
+checkInScope id = LintM $ \mod _lf loc scope errs
+ -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
         ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
                                 text "is out of scope"]) loc)
     else
         ((), errs)
 
-mkUnliftedTyMsg :: Id -> StgRhs -> SDoc
+mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
 mkUnliftedTyMsg binder rhs
   = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
      text "has unlifted type" <+> quotes (ppr (idType binder)))
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 5ba63e458c..e55cba68ae 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -26,6 +26,7 @@ module StgSyn (
 
         StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
         NoExtSilent, noExtSilent,
+        OutputablePass,
 
         UpdateFlag(..), isUpdatable,
 
@@ -52,7 +53,7 @@ module StgSyn (
         stripStgTicksTop,
         stgCaseBndrInScope,
 
-        pprStgBinding, pprStgTopBindings
+        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
     ) where
 
 #include "HsVersions.h"
@@ -731,12 +732,16 @@ pprGenStgBinding (StgRec pairs)
       = hang (hsep [pprBndr LetBind bndr, equals])
              4 (ppr expr <> semi)
 
+pprGenStgTopBindings
+  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc
+pprGenStgTopBindings binds
+  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
+
 pprStgBinding :: StgBinding -> SDoc
-pprStgBinding  bind  = pprGenStgBinding bind
+pprStgBinding = pprGenStgBinding
 
 pprStgTopBindings :: [StgTopBinding] -> SDoc
-pprStgTopBindings binds
-  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
+pprStgTopBindings = pprGenStgTopBindings
 
 instance Outputable StgArg where
     ppr = pprStgArg
diff --git a/testsuite/mk/test.mk b/testsuite/mk/test.mk
index 6c995a4b88..4b1b4d7978 100644
--- a/testsuite/mk/test.mk
+++ b/testsuite/mk/test.mk
@@ -36,7 +36,8 @@ endif
 
 # TEST_HC_OPTS is passed to every invocation of TEST_HC
 # in nested Makefiles
-TEST_HC_OPTS = -dcore-lint -dcmm-lint -no-user-$(GhcPackageDbFlag) -rtsopts $(EXTRA_HC_OPTS)
+TEST_HC_OPTS = -dcore-lint -dstg-lint -dcmm-lint \
+			   -no-user-$(GhcPackageDbFlag) -rtsopts $(EXTRA_HC_OPTS)
 
 ifeq "$(MinGhcVersion711)" "YES"
 # Don't warn about missing specialisations. They can only occur with `-O`, but