[project @ 2003-07-24 10:47:05 by simonmar]
[ghc-hetmet.git] / ghc / compiler / simplCore / SimplMonad.lhs
index adaa6c4..afe7289 100644 (file)
@@ -52,9 +52,7 @@ module SimplMonad (
 
 #include "HsVersions.h"
 
-import Id              ( Id, idType, isDataConWrapId, 
-                         idOccInfo, idInlinePragma
-                       )
+import Id              ( Id, idType, idOccInfo, idInlinePragma )
 import CoreSyn
 import CoreUtils       ( needsCaseBinding, exprIsTrivial )
 import PprCore         ()      -- Instances
@@ -73,27 +71,30 @@ import UniqSupply   ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
                          UniqSupply
                        )
 import FiniteMap
-import BasicTypes      ( TopLevelFlag, isTopLevel, 
+import BasicTypes      ( TopLevelFlag, isTopLevel, isLoopBreaker,
                          Activation, isActive, isAlwaysActive,
-                         OccInfo(..)
+                         OccInfo(..), isOneOcc
                        )
 import CmdLineOpts     ( SimplifierSwitch(..), SimplifierMode(..),
                          DynFlags, DynFlag(..), dopt, 
-                         opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining,
+                         opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
                        )
 import Unique          ( Unique )
-import Maybes          ( expectJust )
 import Outputable
-import Array           ( array, (//) )
 import FastTypes
-import GlaExts         ( indexArray# )
+import FastString
+import Maybes          ( expectJust )
 
-#if __GLASGOW_HASKELL__ < 301
-import ArrBase ( Array(..) )
-#else
+import GLAEXTS         ( indexArray# )
+
+#if __GLASGOW_HASKELL__ < 503
 import PrelArr  ( Array(..) )
+#else
+import GHC.Arr  ( Array(..) )
 #endif
 
+import Array           ( array, (//) )
+
 infixr 0  `thenSmpl`, `thenSmpl_`
 \end{code}
 
@@ -448,7 +449,7 @@ data Tick
   | PostInlineUnconditionally  Id
 
   | UnfoldingDone              Id
-  | RuleFired                  FAST_STRING     -- Rule name
+  | RuleFired                  FastString      -- Rule name
 
   | LetFloatFromLet
   | EtaExpansion               Id      -- LHS binder
@@ -681,6 +682,8 @@ settings:
        SimplGently     (a) Simplifying before specialiser/full laziness
                        (b) Simplifiying inside INLINE pragma
                        (c) Simplifying the LHS of a rule
+                       (d) Simplifying a GHCi expression or Template 
+                               Haskell splice
 
        SimplPhase n    Used at all other times
 
@@ -692,6 +695,12 @@ because doing so inhibits floating
     ==> ...(case x of I# x# -> case fw x# of ...)...
 and now the redex (f x) isn't floatable any more.
 
+The no-inling thing is also important for Template Haskell.  You might be 
+compiling in one-shot mode with -O2; but when TH compiles a splice before
+running it, we don't want to use -O2.  Indeed, we don't want to inline
+anything, because the byte-code interpreter might get confused about 
+unboxed tuples and suchlike.
+
 INLINE pragmas
 ~~~~~~~~~~~~~~
 SimplGently is also used as the mode to simplify inside an InlineMe note.
@@ -758,7 +767,16 @@ big the RHS might be.  If this is the case we don't simplify the RHS
 first, but just inline it un-simplified.
 
 This is much better than first simplifying a perhaps-huge RHS and then
-inlining and re-simplifying it.
+inlining and re-simplifying it.  Indeed, it can be at least quadratically
+better.  Consider
+
+       x1 = e1
+       x2 = e2[x1]
+       x3 = e3[x2]
+       ...etc...
+       xN = eN[xN-1]
+
+We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
 
 NB: we don't even look at the RHS to see if it's trivial
 We might have
@@ -787,21 +805,27 @@ seems to be to do a callSiteInline based on the fact that there is
 something interesting about the call site (it's strict).  Hmm.  That
 seems a bit fragile.
 
+Conclusion: inline top level things gaily until Phase 0 (the last
+phase), at which point don't.
+
 \begin{code}
 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
 preInlineUnconditionally env top_lvl bndr
-  | isTopLevel top_lvl     = False
+  | isTopLevel top_lvl, SimplPhase 0 <- phase = False
 -- If we don't have this test, consider
 --     x = length [1,2,3]
 -- The full laziness pass carefully floats all the cons cells to
 -- top level, and preInlineUnconditionally floats them all back in.
 -- Result is (a) static allocation replaced by dynamic allocation
 --          (b) many simplifier iterations because this tickles
---              a related problem
+--              a related problem; only one inlining per pass
 -- 
 -- On the other hand, I have seen cases where top-level fusion is
 -- lost if we don't inline top level thing (e.g. string constants)
--- We'll have to see
+-- Hence the test for phase zero (which is the phase for all the final
+-- simplifications).  Until phase zero we take no special notice of
+-- top level things, but then we become more leery about inlining
+-- them.  
 
   | not active                    = False
   | opt_SimplNoPreInlining = False
@@ -811,7 +835,8 @@ preInlineUnconditionally env top_lvl bndr
                        -- Not inside a lambda, one occurrence ==> safe!
                  other              -> False
   where
-    active = case getMode env of
+    phase = getMode env
+    active = case phase of
                   SimplGently  -> isAlwaysActive prag
                   SimplPhase n -> isActive n prag
     prag = idInlinePragma bndr
@@ -846,33 +871,41 @@ our new view that inlining is like a RULE, so I'm sticking to the 'active'
 story for now.
 
 \begin{code}
-postInlineUnconditionally :: SimplEnv -> OutId -> Bool -> OutExpr -> Bool
-postInlineUnconditionally env bndr loop_breaker rhs 
+postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
+postInlineUnconditionally env bndr occ_info rhs 
   =  exprIsTrivial rhs
   && active
-  && not loop_breaker
+  && not (isLoopBreaker occ_info)
   && not (isExportedId bndr)
+       -- We used to have (isOneOcc occ_info) instead of
+       -- not (isLoopBreaker occ_info) && not (isExportedId bndr)
+       -- That was because a rather fragile use of rules got confused
+       -- if you inlined even a binding f=g  e.g. We used to have
+       --      map = mapList
+       -- But now a more precise use of phases has eliminated this problem,
+       -- so the is_active test will do the job.  I think.
+       --
+       -- OLD COMMENT: (delete soon)
+       -- Indeed, you might suppose that
+       -- there is nothing wrong with substituting for a trivial RHS, even
+       -- if it occurs many times.  But consider
+       --      x = y
+       --      h = _inline_me_ (...x...)
+       -- Here we do *not* want to have x inlined, even though the RHS is
+       -- trivial, becuase the contract for an INLINE pragma is "no inlining".
+       -- This is important in the rules for the Prelude 
   where
     active = case getMode env of
                   SimplGently  -> isAlwaysActive prag
                   SimplPhase n -> isActive n prag
     prag = idInlinePragma bndr
-\end{code}
-
-blackListInline tells if we must not inline at a call site because the
-Id's inline pragma says not to do so.
 
-However, blackListInline is ignored for things with with Compulsory inlinings,
-because they don't have bindings, so we must inline them no matter how
-gentle we are being.
-
-\begin{code}
 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
 activeInline env id occ
   = case getMode env of
-      SimplGently -> isOneOcc occ
+      SimplGently -> isOneOcc occ && isAlwaysActive prag
        -- No inlining at all when doing gentle stuff,
-       -- except for things that occur once
+       -- except for local things that occur once
        -- The reason is that too little clean-up happens if you 
        -- don't inline use-once things.   Also a bit of inlining is *good* for
        -- full laziness; it can expose constant sub-expressions.
@@ -886,17 +919,22 @@ activeInline env id occ
        -- and they are now constructed as Compulsory unfoldings (in MkId)
        -- so they'll happen anyway.
 
-      SimplPhase n -> isActive n (idInlinePragma id)
-
--- Belongs in BasicTypes; this frag occurs in OccurAnal too
-isOneOcc (OneOcc _ _) = True
-isOneOcc other       = False
+      SimplPhase n -> isActive n prag
+  where
+    prag = idInlinePragma id
 
 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all
 activeRule env
+  | opt_RulesOff = Nothing
+  | otherwise
   = case getMode env of
-       SimplGently  -> Nothing         -- No rules in gentle mode
+       SimplGently  -> Just isAlwaysActive
+                       -- Used to be Nothing (no rules in gentle mode)
+                       -- Main motivation for changing is that I wanted
+                       --      lift String ===> ...
+                       -- to work in Template Haskell when simplifying
+                       -- splices, so we get simpler code for literal strings
        SimplPhase n -> Just (isActive n)
 \end{code}     
 
@@ -935,7 +973,7 @@ type SwitchChecker = SimplifierSwitch -> SwitchResult
 
 data SwitchResult
   = SwBool     Bool            -- on/off
-  | SwString   FAST_STRING     -- nothing or a String
+  | SwString   FastString      -- nothing or a String
   | SwInt      Int             -- nothing or an Int
 
 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
@@ -956,20 +994,10 @@ isAmongSimpl on_switches          -- Switches mentioned later occur *earlier*
        defined_elems = map mk_assoc_elem tidied_on_switches
     in
     -- (avoid some unboxing, bounds checking, and other horrible things:)
-#if __GLASGOW_HASKELL__ < 405
-    case sw_tbl of { Array bounds_who_needs_'em stuff ->
-#else
     case sw_tbl of { Array _ _ stuff ->
-#endif
     \ switch ->
        case (indexArray# stuff (tagOf_SimplSwitch switch)) of
-#if __GLASGOW_HASKELL__ < 400
-         Lift v -> v
-#elif __GLASGOW_HASKELL__ < 403
-         (# _, v #) -> v
-#else
          (# v #) -> v
-#endif
     }
   where
     mk_assoc_elem k@(MaxSimplifierIterations lvl)