Add (a) CoreM monad, (b) new Annotations feature

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

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index 8f63e9d..4b1055b 100644 (file)
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -9,16 +9,10 @@ module LiberateCase ( liberateCase ) where
 #include "HsVersions.h"
 
 import DynFlags
 #include "HsVersions.h"
 
 import DynFlags

-import HscTypes
-import CoreLint                ( showPass, endPass )

 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )

-import Rules           ( RuleBase )
-import UniqSupply      ( UniqSupply )
-import SimplMonad      ( SimplCount, zeroSimplCount )

 import Id
 import VarEnv
 import Id
 import VarEnv

-import Name            ( localiseName )

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

@@ -53,30 +47,13 @@ Example
 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
+Note that this deals with *free variables*.  SpecConstr deals with
+*arguments* that are of known form.  E.g.

 
        last []     = error 
        last (x:[]) = x
        last (x:xs) = last xs
 
 
        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.

        
 Note [Scrutinee with cast]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
        
 Note [Scrutinee with cast]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -140,19 +117,10 @@ and the level of @h@ is zero (NB not one).
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-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' }) }
+liberateCase :: DynFlags -> [CoreBind] -> [CoreBind]
+liberateCase dflags binds = do_prog (initEnv dflags) binds

   where
   where

-    do_prog env [] = []
+    do_prog _   [] = []

     do_prog env (bind:binds) = bind' : do_prog env' binds
                             where
                               (env', bind') = libCaseBind env bind
     do_prog env (bind:binds) = bind' : do_prog env' binds
                             where
                               (env', bind') = libCaseBind env bind

@@ -176,7 +144,7 @@ libCaseBind env (NonRec binder rhs)
 libCaseBind env (Rec pairs)
   = (env_body, Rec pairs')
   where
 libCaseBind env (Rec pairs)
   = (env_body, Rec pairs')
   where

-    (binders, rhss) = unzip pairs
+    (binders, _rhss) = unzip pairs

 
     env_body = addBinders env binders
 
 
     env_body = addBinders env binders
 

@@ -188,10 +156,10 @@ 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 [ (adjust binder, libCase env_body rhs)
+    extended_env = addRecBinds env [ (localiseId binder, libCase env_body rhs)

                                   | (binder, rhs) <- pairs ]
 
                                   | (binder, rhs) <- pairs ]
 

-       -- Two subtle things: 
+       -- The call to localiseId is needed for two subtle reasons

        -- (a)  Reset the export flags on the binders so
        --      that we don't get name clashes on exported things if the 
        --      local binding floats out to top level.  This is most unlikely
        -- (a)  Reset the export flags on the binders so
        --      that we don't get name clashes on exported things if the 
        --      local binding floats out to top level.  This is most unlikely

@@ -201,11 +169,11 @@ libCaseBind env (Rec pairs)
        -- (b)  Make the name an Internal one.  External Names should never be
        --      nested; if it were floated to the top level, we'd get a name
        --      clash at code generation time.
        -- (b)  Make the name an Internal one.  External Names should never be
        --      nested; if it were floated to the top level, we'd get a name
        --      clash at code generation time.

-    adjust bndr = setIdNotExported (setIdName bndr (localiseName (idName bndr)))

 
     rhs_small_enough (id,rhs)
        =  idArity id > 0       -- Note [Only functions!]
 
     rhs_small_enough (id,rhs)
        =  idArity id > 0       -- Note [Only functions!]

-       && couldBeSmallEnoughToInline (bombOutSize env) rhs
+       && maybe True (\size -> couldBeSmallEnoughToInline size rhs)
+                      (bombOutSize env)

 \end{code}
 
 
 \end{code}
 
 

@@ -217,9 +185,9 @@ libCase :: LibCaseEnv
        -> CoreExpr
        -> CoreExpr
 
        -> CoreExpr
        -> CoreExpr
 

-libCase env (Var v)            = libCaseId env v
-libCase env (Lit lit)          = Lit lit
-libCase env (Type ty)          = Type ty
+libCase env (Var v)             = libCaseId env v
+libCase _   (Lit lit)           = Lit lit
+libCase _   (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 (Cast e co)         = Cast (libCase env e) co
 libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
 libCase env (Note note body)    = Note note (libCase env body)
 libCase env (Cast e co)         = Cast (libCase env e) co

@@ -238,8 +206,10 @@ libCase env (Case scrut bndr ty alts)
     env_alts = addBinders (mk_alt_env scrut) [bndr]
     mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
     mk_alt_env (Cast scrut _)  = mk_alt_env scrut      -- Note [Scrutinee with cast]
     env_alts = addBinders (mk_alt_env scrut) [bndr]
     mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
     mk_alt_env (Cast scrut _)  = mk_alt_env scrut      -- Note [Scrutinee with cast]

-    mk_alt_env otehr          = env
+    mk_alt_env _              = env

 
 

+libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
+                         -> (AltCon, [CoreBndr], CoreExpr)

 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}
 

@@ -259,8 +229,39 @@ libCaseId env v
   where
     rec_id_level = lookupLevel env v
     free_scruts  = freeScruts env rec_id_level
   where
     rec_id_level = lookupLevel env v
     free_scruts  = freeScruts env rec_id_level

+
+freeScruts :: LibCaseEnv
+          -> LibCaseLevel      -- Level of the recursive Id
+          -> [Id]              -- Ids that are scrutinised between the binding
+                               -- of the recursive Id and here
+freeScruts env rec_bind_lvl
+  = [v | (v,scrut_bind_lvl) <- lc_scruts env
+       , scrut_bind_lvl <= rec_bind_lvl]
+       -- Note [When to specialise]

 \end{code}
 
 \end{code}
 

+Note [When to specialise]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f = \x. letrec g = \y. case x of
+                          True  -> ... (f a) ...
+                          False -> ... (g b) ...
+
+We get the following levels
+         f  0
+         x  1
+         g  1
+         y  2  
+
+Then 'x' is being scrutinised at a deeper level than its binding, so
+it's added to lc_sruts:  [(x,1)]  
+
+We do *not* want to specialise the call to 'f', becuase 'x' is not free 
+in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).
+
+We *do* want to specialise the call to 'g', because 'x' is free in g.
+Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -297,7 +298,7 @@ addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
 
   | otherwise = env
   where
 
   | otherwise = env
   where

-    scruts'  = (scrut_var, lvl) : scruts
+    scruts'  = (scrut_var, bind_lvl) : scruts

     bind_lvl = case lookupVarEnv lvl_env scrut_var of
                 Just lvl -> lvl
                 Nothing  -> topLevel
     bind_lvl = case lookupVarEnv lvl_env scrut_var of
                 Just lvl -> lvl
                 Nothing  -> topLevel

@@ -310,13 +311,6 @@ lookupLevel env id
   = case lookupVarEnv (lc_lvl_env env) id of
       Just lvl -> lvl
       Nothing  -> topLevel
   = case lookupVarEnv (lc_lvl_env env) id of
       Just lvl -> lvl
       Nothing  -> topLevel

-
-freeScruts :: LibCaseEnv
-          -> LibCaseLevel      -- Level of the recursive Id
-          -> [Id]              -- Ids that are scrutinised between the binding
-                               -- of the recursive Id and here
-freeScruts env rec_bind_lvl
-  = [v | (v,scrut_lvl) <- lc_scruts env, scrut_lvl > rec_bind_lvl]

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -335,40 +329,41 @@ topLevel = 0
 \begin{code}
 data LibCaseEnv
   = LibCaseEnv {
 \begin{code}
 data LibCaseEnv
   = LibCaseEnv {

-       lc_size :: Int,         -- Bomb-out size for deciding if
+       lc_size :: Maybe Int,   -- Bomb-out size for deciding if

                                -- potential liberatees are too big.
                                -- (passed in from cmd-line args)
 
        lc_lvl :: LibCaseLevel, -- Current level
                                -- potential liberatees are too big.
                                -- (passed in from cmd-line args)
 
        lc_lvl :: LibCaseLevel, -- Current level

+               -- The level is incremented when (and only when) going
+               -- inside the RHS of a (sufficiently small) recursive
+               -- function.

 
        lc_lvl_env :: IdEnv LibCaseLevel,  
 
        lc_lvl_env :: IdEnv LibCaseLevel,  

-                       -- Binds all non-top-level in-scope Ids
-                       -- (top-level and imported things have
-                       -- a level of zero)
+               -- Binds all non-top-level in-scope Ids (top-level and
+               -- imported things have a level of zero)

 
        lc_rec_env :: IdEnv CoreBind, 
 
        lc_rec_env :: IdEnv CoreBind, 

-                       -- Binds *only* recursively defined ids, 
-                       -- to their own binding group,
-                       -- and *only* in their own RHSs
+               -- Binds *only* recursively defined ids, to their own
+               -- binding group, and *only* in their own RHSs

 
        lc_scruts :: [(Id,LibCaseLevel)]
 
        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
+               -- Each of these Ids was scrutinised by an enclosing
+               -- case expression, at a level deeper than its binding
+               -- level.  The LibCaseLevel recorded here is the *binding
+               -- level* of the scrutinised Id.
+               -- 
+               -- The order is insignificant; it's a bag really

        }
 
 initEnv :: DynFlags -> LibCaseEnv
 initEnv dflags 
        }
 
 initEnv :: DynFlags -> LibCaseEnv
 initEnv dflags 

-  = LibCaseEnv { lc_size = specThreshold dflags,
+  = LibCaseEnv { lc_size = liberateCaseThreshold dflags,

                 lc_lvl = 0,
                 lc_lvl_env = emptyVarEnv, 
                 lc_rec_env = emptyVarEnv,
                 lc_scruts = [] }
 
                 lc_lvl = 0,
                 lc_lvl_env = emptyVarEnv, 
                 lc_rec_env = emptyVarEnv,
                 lc_scruts = [] }
 

+bombOutSize :: LibCaseEnv -> Maybe Int

 bombOutSize = lc_size
 \end{code}
 
 bombOutSize = lc_size
 \end{code}