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

1 files changed, 12 insertions, 6 deletions

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