[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 4c17f20..94a478a 100644 (file)
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -1,20 +1,21 @@
 %
 %

-% (c) The AQUA Project, Glasgow University, 1994
+% (c) The AQUA Project, Glasgow University, 1994-1998

 %
 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
 
 %
 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
 

-

 \begin{code}
 \begin{code}

-#include "HsVersions.h"
-

 module LiberateCase ( liberateCase ) where
 
 module LiberateCase ( liberateCase ) where
 

-import CoreUnfold      ( UnfoldingGuidance(..) )
-import Id              ( localiseId, toplevelishId{-debugging-} )
-import Maybes
+#include "HsVersions.h"
+
+import CmdLineOpts     ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold )
+import CoreLint                ( showPass, endPass )
+import CoreSyn
+import CoreUnfold      ( couldBeSmallEnoughToInline )
+import Var             ( Id )
+import VarEnv
+import UniqFM          ( ufmToList )

 import Outputable
 import Outputable

-import Pretty
-import Util

 \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,16 +41,44 @@ 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.
 

+Other examples we'd like to catch with this kind of transformation
+
+       last []     = error 
+       last (x:[]) = x
+       last (x:xs) = last xs
+
+We'd like to avoid the redundant pattern match, transforming to
+
+       last [] = error
+       last (x:[]) = x
+       last (x:(y:ys)) = last' y ys
+               where
+                 last' y []     = y
+                 last' _ (y:ys) = last' y ys
+
+       (is this necessarily an improvement)
+
+
+Similarly drop:
+
+       drop n [] = []
+       drop 0 xs = xs
+       drop n (x:xs) = drop (n-1) xs
+
+Would like to pass n along unboxed.
+       

 
 To think about (Apr 94)
 ~~~~~~~~~~~~~~
 
 To think about (Apr 94)
 ~~~~~~~~~~~~~~

@@ -99,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 CoreBinding)-- 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
 

@@ -113,7 +142,7 @@ data LibCaseEnv
                                -- really
 
 initEnv :: Int -> LibCaseEnv
                                -- really
 
 initEnv :: Int -> LibCaseEnv

-initEnv bomb_size = LibCaseEnv bomb_size 0 nullIdEnv nullIdEnv []
+initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []

 
 bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 \end{code}
 
 bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 \end{code}

@@ -122,9 +151,14 @@ bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
 Programs
 ~~~~~~~~
 \begin{code}
 Programs
 ~~~~~~~~
 \begin{code}

-liberateCase :: Int -> [CoreBinding] -> [CoreBinding]
-liberateCase bomb_size prog
-  = do_prog (initEnv bomb_size) prog
+liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind]
+liberateCase dflags binds
+  = do {
+       showPass dflags "Liberate case" ;
+       let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
+       endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
+                               {- no specific flag for dumping -} 
+    }

   where
     do_prog env [] = []
     do_prog env (bind:binds) = bind' : do_prog env' binds
   where
     do_prog env [] = []
     do_prog env (bind:binds) = bind' : do_prog env' binds

@@ -136,7 +170,7 @@ Bindings
 ~~~~~~~~
 
 \begin{code}
 ~~~~~~~~
 
 \begin{code}

-libCaseBind :: LibCaseEnv -> CoreBinding -> (LibCaseEnv, CoreBinding)
+libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)

 
 libCaseBind env (NonRec binder rhs)
   = (addBinders env [binder], NonRec binder (libCase env rhs))
 
 libCaseBind env (NonRec binder rhs)
   = (addBinders env [binder], NonRec binder (libCase env rhs))

@@ -156,28 +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 [ (localiseId 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 TopLevId, 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.
+    extended_env = addRecBinds env [ (binder, libCase env_body rhs)
+                                  | (binder, rhs) <- pairs ]

 
 

-       -- 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.
-
-    rhs_small_enough rhs
-      = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of
-         UnfoldNever -> False
-         _           -> True   -- we didn't BOMB, so it must be OK
-
-    lIBERATE_BOMB_SIZE = bombOutSize env
+    rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs
+    lIBERATE_BOMB_SIZE   = bombOutSize env

 \end{code}
 
 
 \end{code}
 
 

@@ -189,14 +206,11 @@ libCase :: LibCaseEnv
        -> CoreExpr
        -> CoreExpr
 
        -> CoreExpr
        -> CoreExpr
 

-libCase env (Lit lit)           = Lit lit
-libCase env (Var v)             = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
-libCase env (App fun arg)      = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
-libCase env (CoTyApp fun ty)     = CoTyApp (libCase env fun) ty
-libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
-libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
-libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body)
-libCase env (SCC cc body)      = SCC cc (libCase env body)
+libCase env (Var v)            = libCaseId env v
+libCase env (Lit lit)          = Lit lit
+libCase env (Type ty)          = Type ty
+libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
+libCase env (Note note body)    = Note note (libCase env body)

 
 libCase env (Lam binder body)
   = Lam binder (libCase (addBinders env [binder]) body)
 
 libCase env (Lam binder body)
   = Lam binder (libCase (addBinders env [binder]) body)

@@ -206,62 +220,32 @@ libCase env (Let bind body)
   where
     (env_body, bind') = libCaseBind env bind
 
   where
     (env_body, bind') = libCaseBind env bind
 

-libCase env (Case scrut alts)
-  = Case (libCase env scrut) (libCaseAlts env_alts alts)
-  where
-    env_alts = case scrut of
-                 Var scrut_var -> addScrutedVar env scrut_var
-                 other           -> env
-\end{code}
-
-
-Case alternatives
-~~~~~~~~~~~~~~~~~
-
-\begin{code}
-libCaseAlts env (AlgAlts alts deflt)
-  = AlgAlts (map do_alt alts) (libCaseDeflt env deflt)
-  where
-    do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
-
-libCaseAlts env (PrimAlts alts deflt)
-  = PrimAlts (map do_alt alts) (libCaseDeflt env deflt)
+libCase env (Case scrut bndr alts)
+  = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)

   where
   where

-    do_alt (lit,rhs) = (lit, libCase env rhs)
+    env_alts = addBinders env_with_scrut [bndr]
+    env_with_scrut = case scrut of
+                       Var scrut_var -> addScrutedVar env scrut_var
+                       other         -> env

 
 

-libCaseDeflt env NoDefault
-   = NoDefault
-libCaseDeflt env (BindDefault binder rhs)
-   = BindDefault binder (libCase (addBinders env [binder]) rhs)
+libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)

 \end{code}
 
 \end{code}
 

-Atoms and Ids
-~~~~~~~~~~~~~
+Ids
+~~~

 \begin{code}
 \begin{code}

-libCaseAtoms :: LibCaseEnv -> [CoreArg] -> [CoreBinding]
-libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
-
-libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding]
-libCaseAtom env (VarArg arg_id) = libCaseId env arg_id
-libCaseAtom env (LitArg lit)    = []
-
-libCaseId :: LibCaseEnv -> Id -> [CoreBinding]
+libCaseId :: LibCaseEnv -> Id -> CoreExpr

 libCaseId env v
 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
-  = [the_bind]
+  | 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
 
   | otherwise

-  = []
+  = Var v

 
   where
 
   where

-    maybe_rec_bind :: Maybe CoreBinding        -- 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}
 
 

@@ -269,19 +253,19 @@ libCaseId env v
 Utility functions
 ~~~~~~~~~~~~~~~~~
 \begin{code}
 Utility functions
 ~~~~~~~~~~~~~~~~~
 \begin{code}

-addBinders :: LibCaseEnv -> [Id] -> LibCaseEnv
+addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv

 addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
   = LibCaseEnv bomb lvl lvl_env' rec_env scruts
   where
 addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
   = LibCaseEnv bomb lvl lvl_env' rec_env scruts
   where

-    lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
+    lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)

 
 addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
 addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
   = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
   where
     lvl'     = lvl + 1
 
 addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
 addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
   = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
   where
     lvl'     = lvl + 1

-    lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
-    rec_env' = growIdEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
+    lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
+    rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]

 
 addScrutedVar :: LibCaseEnv
              -> Id             -- This Id is being scrutinised by a case expression
 
 addScrutedVar :: LibCaseEnv
              -> Id             -- This Id is being scrutinised by a case expression

@@ -296,35 +280,24 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
   | otherwise = env
   where
     scruts'  = (scrut_var, lvl) : scruts
   | otherwise = env
   where
     scruts'  = (scrut_var, lvl) : scruts

-    bind_lvl = case lookupIdEnv lvl_env scrut_var of
+    bind_lvl = case lookupVarEnv lvl_env scrut_var of

                 Just lvl -> lvl
                 Just lvl -> lvl

-                Nothing  -> --false: ASSERT(toplevelishId scrut_var)
-                            topLevel
+                Nothing  -> topLevel

 
 

-lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
+lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind

 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id

-#ifndef DEBUG
-  = lookupIdEnv rec_env id
-#else
-  = case (lookupIdEnv rec_env id) of
-      xxx@(Just _) -> xxx
-      xxx         -> --false: ASSERT(toplevelishId id)
-                     xxx
-#endif
+  = lookupVarEnv rec_env id

 
 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

-  = case lookupIdEnv lvl_env id of
+  = case lookupVarEnv lvl_env id of

       Just lvl -> lvl
       Just lvl -> lvl

-      Nothing  -> ASSERT(toplevelishId id)
-                 topLevel
+      Nothing  -> topLevel

 
 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}