[project @ 2003-07-30 17:09:12 by simonmar]
[ghc-hetmet.git] / ghc / compiler / simplCore / LiberateCase.lhs
index bd9bac2..466dfad 100644 (file)
@@ -8,13 +8,14 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( opt_D_verbose_core2core, opt_LiberateCaseThreshold )
-import CoreLint                ( beginPass, endPass )
+import CmdLineOpts     ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold )
+import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 import Var             ( Id )
 import VarEnv
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 import Var             ( Id )
 import VarEnv
-import Maybes
+import Outputable
+import Util             ( notNull )
 \end{code}
 
 This module walks over @Core@, and looks for @case@ on free variables.
 \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)
 
 \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}
 \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.
 
 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)
 
                                -- (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
 
                                -- Ids, to their own binding group,
                                -- and *only* in their own RHSs
 
@@ -148,14 +151,13 @@ bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 Programs
 ~~~~~~~~
 \begin{code}
 Programs
 ~~~~~~~~
 \begin{code}
-liberateCase :: [CoreBind] -> IO [CoreBind]
-liberateCase binds
+liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind]
+liberateCase dflags binds
   = do {
   = do {
-       beginPass "Liberate case" ;
+       showPass dflags "Liberate case" ;
        let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
        let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
-       endPass "Liberate case" 
-               opt_D_verbose_core2core         {- no specific flag for dumping -} 
-               binds'
+       endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
+                               {- no specific flag for dumping -} 
     }
   where
     do_prog env [] = []
     }
   where
     do_prog env [] = []
@@ -188,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!
 
        -- 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
 
     rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
-
-    lIBERATE_BOMB_SIZE = bombOutSize env
+    lIBERATE_BOMB_SIZE   = bombOutSize env
 \end{code}
 
 
 \end{code}
 
 
@@ -237,10 +223,10 @@ libCase env (Let bind body)
 libCase env (Case scrut bndr alts)
   = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
   where
 libCase env (Case scrut bndr alts)
   = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
   where
-    env_alts = addBinders env [bndr]
+    env_alts = addBinders env_with_scrut [bndr]
     env_with_scrut = case scrut of
                        Var scrut_var -> addScrutedVar env scrut_var
     env_with_scrut = case scrut of
                        Var scrut_var -> addScrutedVar env scrut_var
-                       other             -> env
+                       other         -> env
 
 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 \end{code}
 
 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 \end{code}
@@ -250,21 +236,16 @@ Ids
 \begin{code}
 libCaseId :: LibCaseEnv -> Id -> CoreExpr
 libCaseId env v
 \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
+  , notNull free_scruts                -- with free vars scrutinised in RHS
   = Let the_bind (Var v)
 
   | otherwise
   = Var v
 
   where
   = 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
     rec_id_level = lookupLevel env v
-
-    there_are_free_scruts = freeScruts env rec_id_level
+    free_scruts  = freeScruts env rec_id_level
 \end{code}
 
 
 \end{code}
 
 
@@ -305,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
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
-#ifndef DEBUG
   = lookupVarEnv rec_env id
   = 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
 
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
@@ -321,10 +296,8 @@ lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 
 freeScruts :: LibCaseEnv
           -> LibCaseLevel      -- Level of the recursive 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
 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}
 \end{code}