[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 5d4d921..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"
 
 
 #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 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.
 \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
 

@@ -153,10 +156,8 @@ liberateCase dflags binds
   = do {
        showPass dflags "Liberate case" ;
        let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
   = do {
        showPass dflags "Liberate case" ;
        let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;

-       endPass dflags "Liberate case" 
-               (dopt Opt_D_verbose_core2core dflags)
+       endPass dflags "Liberate case" Opt_D_verbose_core2core binds'

                                {- no specific flag for dumping -} 
                                {- no specific flag for dumping -} 

-               binds'

     }
   where
     do_prog env [] = []
     }
   where
     do_prog env [] = []

@@ -189,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}
 
 

@@ -251,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
+  , not (null 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}
 
 

@@ -306,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

@@ -322,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}