[commit: ghc] wip/lazy-interface-unfoldings: Progress (c32dcb8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/lazy-interface-unfoldings
Link       : http://ghc.haskell.org/trac/ghc/changeset/c32dcb8fdaa45dc0f56dc1dda935a7ef15970327/ghc

>---------------------------------------------------------------

commit c32dcb8fdaa45dc0f56dc1dda935a7ef15970327
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Sun Nov 13 16:07:03 2016 -0500

    Progress


>---------------------------------------------------------------

c32dcb8fdaa45dc0f56dc1dda935a7ef15970327
 compiler/basicTypes/Id.hs   | 10 +++++++++-
 compiler/coreSyn/CoreFVs.hs |  5 ++++-
 compiler/deSugar/Desugar.hs |  7 ++++---
 3 files changed, 17 insertions(+), 5 deletions(-)

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 199842c..195330c 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -93,7 +93,7 @@ module Id (
         -- ** Reading 'IdInfo' fields
         idArity,
         idCallArity, idFunRepArity,
-        idUnfolding, realIdUnfolding,
+        idUnfolding, realIdUnfolding, idOptUnfolding,
         idSpecialisation, idCoreRules, idHasRules,
         idCafInfo,
         idOneShotInfo, idStateHackOneShotInfo,
@@ -702,6 +702,14 @@ idUnfolding id
   where
     info = idInfo id
 
+-- | Return the unfolding associated with an 'Id' only if optimization is
+-- enabled or the 'Id' is a local variable (and consequently retrieving the
+-- unfolding costs us nothing).
+idOptUnfolding :: DynFlags -> Id -> Unfolding
+idOptUnfolding dflags id
+  | optLevel dflags > 0 || isLocalId id = idUnfolding id
+  | otherwise                           = NoUnfolding
+
 realIdUnfolding :: Id -> Unfolding
 -- Expose the unfolding if there is one, including for loop breakers
 realIdUnfolding id = unfoldingInfo (idInfo id)
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index 18e109a..a70acb7 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -655,7 +655,10 @@ idUnfoldingVars :: Id -> VarSet
 idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id
 
 idUnfoldingFVs :: Id -> FV
-idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV
+idUnfoldingFVs id
+  | isLocalVar id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV
+  -- Global vars have no free variables
+  | otherwise     = emptyFV
 
 stableUnfoldingVars :: Unfolding -> Maybe VarSet
 stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index aa9748e..5bec60e 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -421,10 +421,11 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids
   = do { check False fn_id    -- We often have multiple rules for the same Id in a
                               -- module. Maybe we should check that they don't overlap
                               -- but currently we don't
-       ; mapM_ (check True) arg_ids }
+       ; dflags <- getDynFlags
+       ; mapM_ (check dflags True) arg_ids }
   where
-    check check_rules_too lhs_id
-      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
+    check dflags check_rules_too lhs_id
+      | isLocalId lhs_id || (canUnfold (idOptUnfolding dflags lhs_id)
                        -- If imported with no unfolding, no worries
       , idInlineActivation lhs_id `competesWith` rule_act
       = warnDs (Reason Opt_WarnInlineRuleShadowing)