[commit: ghc] wip/oneShot: Hack to prevent oneShot from being inlined when simplifying unfoldings (8dfc9b0)

[git at git.haskell.org]

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

On branch  : wip/oneShot
Link       : http://ghc.haskell.org/trac/ghc/changeset/8dfc9b0809359011c4d25761ad5278eab1372388/ghc

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

commit 8dfc9b0809359011c4d25761ad5278eab1372388
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sat Oct 25 16:45:27 2014 +0200

    Hack to prevent oneShot from being inlined when simplifying unfoldings


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

8dfc9b0809359011c4d25761ad5278eab1372388
 compiler/basicTypes/MkId.lhs      |  2 +-
 compiler/simplCore/CoreMonad.lhs  |  7 +++++--
 compiler/simplCore/SimplCore.lhs  |  3 ++-
 compiler/simplCore/SimplUtils.lhs | 17 ++++++++++++++---
 4 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 05dcdd5..360c06d 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -30,7 +30,7 @@ module MkId (
         wiredInIds, ghcPrimIds,
         unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
         voidPrimId, voidArgId,
-        nullAddrId, seqId, lazyId, lazyIdKey,
+        nullAddrId, seqId, lazyId, lazyIdKey, oneShotId,
         coercionTokenId, magicDictId, coerceId,
 
         -- Re-export error Ids
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 8d2d3bf..8c1e322 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -382,19 +382,22 @@ data SimplifierMode             -- See comments in SimplMonad
         , sm_inline     :: Bool     -- Whether inlining is enabled
         , sm_case_case  :: Bool     -- Whether case-of-case is enabled
         , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
+        , sm_in_rule    :: Bool     -- Whether we are simplified the RHS of a rule (do not inline stuff that would not survive the interface)
         }
 
 instance Outputable SimplifierMode where
     ppr (SimplMode { sm_phase = p, sm_names = ss
                    , sm_rules = r, sm_inline = i
-                   , sm_eta_expand = eta, sm_case_case = cc })
+                   , sm_eta_expand = eta, sm_case_case = cc
+                   , sm_in_rule = ir })
        = ptext (sLit "SimplMode") <+> braces (
          sep [ ptext (sLit "Phase =") <+> ppr p <+>
                brackets (text (concat $ intersperse "," ss)) <> comma
              , pp_flag i   (sLit "inline") <> comma
              , pp_flag r   (sLit "rules") <> comma
              , pp_flag eta (sLit "eta-expand") <> comma
-             , pp_flag cc  (sLit "case-of-case") ])
+             , pp_flag cc  (sLit "case-of-case") <> comma
+             , pp_flag ir  (sLit "in-rule") ])
          where
            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
 \end{code}
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 2a70dcf..c2fba8b 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -140,7 +140,8 @@ getCoreToDo dflags
                           , sm_rules      = rules_on
                           , sm_eta_expand = eta_expand_on
                           , sm_inline     = True
-                          , sm_case_case  = True }
+                          , sm_case_case  = True
+                          , sm_in_rule    = False}
 
     simpl_phase phase names iter
       = CoreDoPasses
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 1cfba43..c450ad9 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -47,6 +47,7 @@ import CoreArity
 import CoreUnfold
 import Name
 import Id
+import MkId (oneShotId)
 import Var
 import Demand
 import SimplMonad
@@ -535,7 +536,8 @@ simplEnvForGHCi dflags
                            , sm_rules = rules_on
                            , sm_inline = False
                            , sm_eta_expand = eta_expand_on
-                           , sm_case_case = True }
+                           , sm_case_case = True
+                           , sm_in_rule = False }
   where
     rules_on      = gopt Opt_EnableRewriteRules   dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
@@ -547,7 +549,8 @@ updModeForStableUnfoldings :: Activation -> SimplifierMode -> SimplifierMode
 updModeForStableUnfoldings inline_rule_act current_mode
   = current_mode { sm_phase = phaseFromActivation inline_rule_act
                  , sm_inline = True
-                 , sm_eta_expand = False }
+                 , sm_eta_expand = False
+                 , sm_in_rule = True}
                  -- For sm_rules, just inherit; sm_rules might be "off"
                  -- because of -fno-enable-rewrite-rules
   where
@@ -672,8 +675,16 @@ mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
 continuation.
 
 \begin{code}
+-- Debugging HACK
 activeUnfolding :: SimplEnv -> Id -> Bool
-activeUnfolding env
+activeUnfolding env id
+  | sm_in_rule (getMode env)
+  , id == oneShotId
+  = False
+  | otherwise = activeUnfolding' env id
+
+activeUnfolding' :: SimplEnv -> Id -> Bool
+activeUnfolding' env
   | not (sm_inline mode) = active_unfolding_minimal
   | otherwise            = case sm_phase mode of
                              InitialPhase -> active_unfolding_gentle