Improve the interaction of 'seq' and associated data types

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

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index 67d2e5c..0df9b37 100644 (file)
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -8,18 +8,22 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import DynFlags                ( DynFlags, DynFlag(..) )
-import StaticFlags     ( opt_LiberateCaseThreshold )
+import DynFlags
+import HscTypes

 import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )

-import Id              ( Id, setIdName, idName, setIdNotExported )
+import Rules           ( RuleBase )
+import UniqSupply      ( UniqSupply )
+import SimplMonad      ( SimplCount, zeroSimplCount )
+import Id

 import VarEnv
 import Name            ( localiseName )
 import VarEnv
 import Name            ( localiseName )

-import Outputable

 import Util             ( notNull )
 \end{code}
 
 import Util             ( notNull )
 \end{code}
 

+The liberate-case transformation
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 This module walks over @Core@, and looks for @case@ on free variables.
 The criterion is:
        if there is case on a free on the route to the recursive call,
 This module walks over @Core@, and looks for @case@ on free variables.
 The criterion is:
        if there is case on a free on the route to the recursive call,

@@ -27,30 +31,24 @@ The criterion is:
 
 Example
 
 
 Example
 

-\begin{verbatim}
-f = \ t -> case v of
-              V a b -> a : f t
-\end{verbatim}
+   f = \ t -> case v of
+                V a b -> a : f t

 
 => the inner f is replaced.
 
 
 => the inner f is replaced.
 

-\begin{verbatim}
-f = \ t -> case v of
-              V a b -> a : (letrec
+   f = \ t -> case v of
+                V a b -> a : (letrec

                                f =  \ t -> case v of
                                               V a b -> a : f t
                                f =  \ t -> case v of
                                               V a b -> a : f t

-                            in f) t
-\end{verbatim}
+                              in f) t

 (note the NEED for shadowing)
 
 => Simplify
 
 (note the NEED for shadowing)
 
 => Simplify
 

-\begin{verbatim}
-f = \ t -> case v of
-              V a b -> a : (letrec
+  f = \ t -> case v of
+                V a b -> a : (letrec

                                f = \ t -> a : f t
                                f = \ t -> a : f t

-                            in f t)
-\begin{verbatim}
+                              in f t)

 
 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.

@@ -72,7 +70,6 @@ We'd like to avoid the redundant pattern match, transforming to
 
        (is this necessarily an improvement)
 
 
        (is this necessarily an improvement)
 

-

 Similarly drop:
 
        drop n [] = []
 Similarly drop:
 
        drop n [] = []

@@ -87,7 +84,7 @@ Consider this:
     f = \ t -> case (v `cast` co) of
                 V a b -> a : f t
 
     f = \ t -> case (v `cast` co) of
                 V a b -> a : f t
 

-Exactly the same optimistaion (unrolling one call to f) will work here, 
+Exactly the same optimisation (unrolling one call to f) will work here, 

 despite the cast.  See mk_alt_env in the Case branch of libCase.
 
 
 despite the cast.  See mk_alt_env in the Case branch of libCase.
 
 

@@ -105,7 +102,6 @@ big.
 
 Data types
 ~~~~~~~~~~
 
 Data types
 ~~~~~~~~~~

-

 The ``level'' of a binder tells how many
 recursive defns lexically enclose the binding
 A recursive defn "encloses" its RHS, not its
 The ``level'' of a binder tells how many
 recursive defns lexically enclose the binding
 A recursive defn "encloses" its RHS, not its

@@ -119,66 +115,25 @@ scope.  For example:
 Here, the level of @f@ is zero, the level of @g@ is one,
 and the level of @h@ is zero (NB not one).
 
 Here, the level of @f@ is zero, the level of @g@ is one,
 and the level of @h@ is zero (NB not one).
 

-\begin{code}
-type LibCaseLevel = Int

 
 

-topLevel :: LibCaseLevel
-topLevel = 0
-\end{code}
+%************************************************************************
+%*                                                                     *
+        Top-level code
+%*                                                                     *
+%************************************************************************

 
 \begin{code}
 
 \begin{code}

-data LibCaseEnv
-  = LibCaseEnv {
-       lc_size :: Int,         -- Bomb-out size for deciding if
-                               -- potential liberatees are too big.
-                               -- (passed in from cmd-line args)
-
-       lc_lvl :: LibCaseLevel, -- Current level
-
-       lc_lvl_env :: IdEnv LibCaseLevel,  
-                       -- Binds all non-top-level in-scope Ids
-                       -- (top-level and imported things have
-                       -- a level of zero)
-
-       lc_rec_env :: IdEnv CoreBind, 
-                       -- Binds *only* recursively defined ids, 
-                       -- to their own binding group,
-                       -- and *only* in their own RHSs
-
-       lc_scruts :: [(Id,LibCaseLevel)]
-                       -- Each of these Ids was scrutinised by an
-                       -- enclosing case expression, with the
-                       -- specified number of enclosing
-                       -- recursive bindings; furthermore,
-                       -- the Id is bound at a lower level
-                       -- than the case expression.  The order is
-                       -- insignificant; it's a bag really
-
---     lc_fams :: FamInstEnvs
-                       -- Instance env for indexed data types 
-       }
-
-initEnv :: Int -> LibCaseEnv
-initEnv bomb_size
-  = LibCaseEnv { lc_size = bomb_size, lc_lvl = 0,
-                lc_lvl_env = emptyVarEnv, lc_rec_env = emptyVarEnv,
-                lc_scruts = [] }
-
-bombOutSize = lc_size
-\end{code}
-
-
-Programs
-~~~~~~~~
-\begin{code}
-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 -} 
-    }
+liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
+            -> IO (SimplCount, ModGuts)
+liberateCase hsc_env _ _ guts
+  = do { let dflags = hsc_dflags hsc_env
+
+       ; showPass dflags "Liberate case"
+       ; let { env = initEnv dflags
+             ; binds' = do_prog env (mg_binds guts) }
+       ; endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
+                       {- no specific flag for dumping -} 
+       ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }

   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

@@ -186,9 +141,15 @@ liberateCase dflags binds
                               (env', bind') = libCaseBind env bind
 \end{code}
 
                               (env', bind') = libCaseBind env bind
 \end{code}
 

+
+%************************************************************************
+%*                                                                     *
+        Main payload
+%*                                                                     *
+%************************************************************************
+

 Bindings
 ~~~~~~~~
 Bindings
 ~~~~~~~~

-

 \begin{code}
 libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
 
 \begin{code}
 libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
 

@@ -264,6 +225,7 @@ libCase env (Case scrut bndr ty alts)
 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}
 

+

 Ids
 ~~~
 \begin{code}
 Ids
 ~~~
 \begin{code}

@@ -282,9 +244,12 @@ libCaseId env v
 \end{code}
 
 
 \end{code}
 
 

+%************************************************************************
+%*                                                                     *
+       Utility functions
+%*                                                                     *
+%************************************************************************

 
 

-Utility functions
-~~~~~~~~~~~~~~~~~

 \begin{code}
 addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
 addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
 \begin{code}
 addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
 addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders

@@ -325,7 +290,7 @@ lookupRecId env id = lookupVarEnv (lc_rec_env env) id
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel env id
   = case lookupVarEnv (lc_lvl_env env) id of
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel env id
   = case lookupVarEnv (lc_lvl_env env) id of

-      Just lvl -> lc_lvl env
+      Just lvl -> lvl

       Nothing  -> topLevel
 
 freeScruts :: LibCaseEnv
       Nothing  -> topLevel
 
 freeScruts :: LibCaseEnv

@@ -335,3 +300,58 @@ freeScruts :: LibCaseEnv
 freeScruts env rec_bind_lvl
   = [v | (v,scrut_lvl) <- lc_scruts env, scrut_lvl > rec_bind_lvl]
 \end{code}
 freeScruts env rec_bind_lvl
   = [v | (v,scrut_lvl) <- lc_scruts env, scrut_lvl > rec_bind_lvl]
 \end{code}

+
+%************************************************************************
+%*                                                                     *
+        The environment
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+type LibCaseLevel = Int
+
+topLevel :: LibCaseLevel
+topLevel = 0
+\end{code}
+
+\begin{code}
+data LibCaseEnv
+  = LibCaseEnv {
+       lc_size :: Int,         -- Bomb-out size for deciding if
+                               -- potential liberatees are too big.
+                               -- (passed in from cmd-line args)
+
+       lc_lvl :: LibCaseLevel, -- Current level
+
+       lc_lvl_env :: IdEnv LibCaseLevel,  
+                       -- Binds all non-top-level in-scope Ids
+                       -- (top-level and imported things have
+                       -- a level of zero)
+
+       lc_rec_env :: IdEnv CoreBind, 
+                       -- Binds *only* recursively defined ids, 
+                       -- to their own binding group,
+                       -- and *only* in their own RHSs
+
+       lc_scruts :: [(Id,LibCaseLevel)]
+                       -- Each of these Ids was scrutinised by an
+                       -- enclosing case expression, with the
+                       -- specified number of enclosing
+                       -- recursive bindings; furthermore,
+                       -- the Id is bound at a lower level
+                       -- than the case expression.  The order is
+                       -- insignificant; it's a bag really
+       }
+
+initEnv :: DynFlags -> LibCaseEnv
+initEnv dflags 
+  = LibCaseEnv { lc_size = specThreshold dflags,
+                lc_lvl = 0,
+                lc_lvl_env = emptyVarEnv, 
+                lc_rec_env = emptyVarEnv,
+                lc_scruts = [] }
+
+bombOutSize = lc_size
+\end{code}
+
+