[project @ 2001-09-26 16:19:28 by simonpj]

[ghc-hetmet.git] / ghc / compiler / simplCore / LiberateCase.lhs

diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index 57b94be..94a478a 100644 (file)
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -8,13 +8,14 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt, opt_LiberateCaseThreshold )
+import CmdLineOpts     ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold )
 import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 import Var             ( Id )
 import VarEnv
-import Maybes
+import UniqFM          ( ufmToList )
+import Outputable
 \end{code}
 
 This module walks over @Core@, and looks for @case@ on free variables.
@@ -40,13 +41,15 @@ f = \ t -> case v of
 \end{verbatim}
 (note the NEED for shadowing)
 
-=> Run Andr\'e's wonder pass ...
+=> Simplify
+
 \begin{verbatim}
 f = \ t -> case v of
               V a b -> a : (letrec
                                f = \ t -> a : f t
                             in f t)
 \begin{verbatim}
+
 Better code, because 'a' is  free inside the inner letrec, rather
 than needing projection from v.
 
@@ -125,7 +128,7 @@ data LibCaseEnv
                                -- (top-level and imported things have
                                -- a level of zero)
 
-       (IdEnv CoreBind)-- Binds *only* recursively defined
+       (IdEnv CoreBind)        -- Binds *only* recursively defined
                                -- Ids, to their own binding group,
                                -- and *only* in their own RHSs
 
@@ -187,27 +190,11 @@ libCaseBind env (Rec pairs)
        -- processing the rhs with an *un-extended* environment, so
        -- that the same process doesn't occur for ever!
 
-    extended_env
-      = addRecBinds env [ (binder, libCase env_body rhs)
-                       | (binder, rhs) <- pairs ]
-
-       -- Why "localiseId" above?  Because we're creating a new local
-       -- copy of the original binding.  In particular, the original
-       -- binding might have been for a top-level, and this copy clearly
-       -- will not be top-level!
-
-       -- It is enough to change just the binder, because subsequent
-       -- simplification will propagate the right info from the binder.
-
-       -- Why does it matter?  Because the codeGen keeps a separate
-       -- environment for top-level Ids, and it is disastrous for it
-       -- to think that something is top-level when it isn't.
-       --
-       -- [May 98: all this is now handled by SimplCore.tidyCore]
+    extended_env = addRecBinds env [ (binder, libCase env_body rhs)
+                                  | (binder, rhs) <- pairs ]
 
     rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
-
-    lIBERATE_BOMB_SIZE = bombOutSize env
+    lIBERATE_BOMB_SIZE   = bombOutSize env
 \end{code}
 
 
@@ -249,21 +236,16 @@ Ids
 \begin{code}
 libCaseId :: LibCaseEnv -> Id -> CoreExpr
 libCaseId env v
-  | maybeToBool maybe_rec_bind &&      -- It's a use of a recursive thing
-    there_are_free_scruts              -- with free vars scrutinised in RHS
+  | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing
+  , not (null free_scruts)             -- with free vars scrutinised in RHS
   = Let the_bind (Var v)
 
   | otherwise
   = Var v
 
   where
-    maybe_rec_bind :: Maybe CoreBind   -- The binding of the recursive thingy
-    maybe_rec_bind = lookupRecId env v
-    Just the_bind  = maybe_rec_bind
-
     rec_id_level = lookupLevel env v
-
-    there_are_free_scruts = freeScruts env rec_id_level
+    free_scruts  = freeScruts env rec_id_level
 \end{code}
 
 
@@ -304,13 +286,7 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
-#ifndef DEBUG
   = lookupVarEnv rec_env id
-#else
-  = case (lookupVarEnv rec_env id) of
-      xxx@(Just _) -> xxx
-      xxx         -> xxx
-#endif
 
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
@@ -320,10 +296,8 @@ lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 
 freeScruts :: LibCaseEnv
           -> LibCaseLevel      -- Level of the recursive Id
-          -> Bool              -- True <=> there is an enclosing case of a variable
-                               -- bound outside (ie level <=) the recursive Id.
+          -> [Id]              -- Ids that are scrutinised between the binding
+                               -- of the recursive Id and here
 freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
-  = not (null free_scruts)
-  where
-    free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
+  = [v | (v,scrut_lvl) <- scruts, scrut_lvl > rec_bind_lvl]
 \end{code}