author Austin Seipp Wed, 20 Aug 2014 08:36:39 +0000 (03:36 -0500) committer Austin Seipp Wed, 20 Aug 2014 08:47:35 +0000 (03:47 -0500)
Signed-off-by: Austin Seipp <austin@well-typed.com>

index 2593ab1..21adf20 100644 (file)
@@ -5,20 +5,13 @@

\begin{code}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module LiberateCase ( liberateCase ) where

#include "HsVersions.h"

import DynFlags
import CoreSyn
-import CoreUnfold      ( couldBeSmallEnoughToInline )
+import CoreUnfold       ( couldBeSmallEnoughToInline )
import Id
import VarEnv
import Util             ( notNull )
@@ -28,29 +21,29 @@ 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,
-       then the recursive call is replaced with an unfolding.
+        if there is case on a free on the route to the recursive call,
+        then the recursive call is replaced with an unfolding.

Example

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

=> the inner f is replaced.

f = \ t -> case v of
-                V a b -> a : (letrec
-                               f =  \ t -> case v of
-                                              V a b -> a : f t
-                              in f) t
+                 V a b -> a : (letrec
+                                f =  \ t -> case v of
+                                               V a b -> a : f t
+                               in f) t
(note the NEED for shadowing)

=> Simplify

f = \ t -> case v of
-                V a b -> a : (letrec
-                               f = \ t -> a : f t
-                              in f t)
+                 V a b -> a : (letrec
+                                f = \ t -> a : f t
+                               in f t)

Better code, because 'a' is  free inside the inner letrec, rather
than needing projection from v.
@@ -58,18 +51,18 @@ than needing projection from v.
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
+

-
Note [Scrutinee with cast]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:
f = \ t -> case (v cast co) of
-                V a b -> a : f t
+                 V a b -> a : f t

-Exactly the same optimisation (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.

@@ -109,19 +102,19 @@ recursive defns lexically enclose the binding
A recursive defn "encloses" its RHS, not its
scope.  For example:
\begin{verbatim}
-       letrec f = let g = ... in ...
-       in
-       let h = ...
-       in ...
+        letrec f = let g = ... in ...
+        in
+        let h = ...
+        in ...
\end{verbatim}
Here, the level of @f@ is zero, the level of @g@ is one,
and the level of @h@ is zero (NB not one).

%************************************************************************
-%*                                                                     *
-        Top-level code
-%*                                                                     *
+%*                                                                      *
+         Top-level code
+%*                                                                      *
%************************************************************************

\begin{code}
@@ -130,15 +123,15 @@ liberateCase dflags binds = do_prog (initEnv dflags) binds
where
do_prog _   [] = []
do_prog env (bind:binds) = bind' : do_prog env' binds
-                            where
-                              (env', bind') = libCaseBind env bind
+                             where
+                               (env', bind') = libCaseBind env bind
\end{code}

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

Bindings
@@ -158,18 +151,18 @@ libCaseBind env (Rec pairs)

pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]

-       -- We extend the rec-env by binding each Id to its rhs, first
-       -- processing the rhs with an *un-extended* environment, so
-       -- that the same process doesn't occur for ever!
+        -- We extend the rec-env by binding each Id to its rhs, first
+        -- processing the rhs with an *un-extended* environment, so
+        -- that the same process doesn't occur for ever!
env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs)
-                             | (binder, rhs) <- pairs
-                             , rhs_small_enough binder rhs ]
-       -- localiseID : see Note [Need to localiseId in libCaseBind]
-
-
-    rhs_small_enough id rhs    -- Note [Small enough]
-       =  idArity id > 0       -- Note [Only functions!]
-       && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs)
+                              | (binder, rhs) <- pairs
+                              , rhs_small_enough binder rhs ]
+        -- localiseID : see Note [Need to localiseId in libCaseBind]
+
+
+    rhs_small_enough id rhs     -- Note [Small enough]
+        =  idArity id > 0       -- Note [Only functions!]
+        && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs)
(bombOutSize env)
\end{code}

@@ -177,21 +170,21 @@ Note [Need to localiseId in libCaseBind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
-       to happen, since the whole point concerns free variables.
-       But resetting the export flag is right regardless.
+        that we don't get name clashes on exported things if the
+        local binding floats out to top level.  This is most unlikely
+        to happen, since the whole point concerns free variables.
+        But resetting the export flag is right regardless.

(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.
+        nested; if it were floated to the top level, we'd get a name
+        clash at code generation time.

Note [Small enough]
~~~~~~~~~~~~~~~~~~~
Consider
\fv. letrec
-        f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
-        g = \y. SMALL...f...
+         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
+         g = \y. SMALL...f...
Then we *can* do liberate-case on g (small RHS) but not for f (too big).
But we can choose on a item-by-item basis, and that's what the
rhs_small_enough call in the comprehension for env_rhs does.
@@ -201,8 +194,8 @@ Expressions

\begin{code}
libCase :: LibCaseEnv
-       -> CoreExpr
-       -> CoreExpr
+        -> CoreExpr
+        -> CoreExpr

libCase env (Var v)             = libCaseId env v
libCase _   (Lit lit)           = Lit lit
@@ -225,8 +218,8 @@ libCase env (Case scrut bndr ty alts)
where
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 _              = env
+    mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]
+    mk_alt_env _               = env

libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
-> (AltCon, [CoreBndr], CoreExpr)
@@ -239,8 +232,8 @@ Ids
\begin{code}
libCaseId :: LibCaseEnv -> Id -> CoreExpr
libCaseId env v
-  | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing
-  , notNull 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
@@ -251,34 +244,34 @@ libCaseId 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
+           -> 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, scrut_at_lvl) <- lc_scruts env
, scrut_bind_lvl <= rec_bind_lvl
, scrut_at_lvl > rec_bind_lvl]
-       -- Note [When to specialise]
-       -- Note [Avoiding fruitless liberate-case]
+        -- Note [When to specialise]
+        -- Note [Avoiding fruitless liberate-case]
\end{code}

Note [When to specialise]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f = \x. letrec g = \y. case x of
-                          True  -> ... (f a) ...
-                          False -> ... (g b) ...
+                           True  -> ... (f a) ...
+                           False -> ... (g b) ...

We get the following levels
-         f  0
-         x  1
-         g  1
-         y  2
+          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)]
+it's added to lc_sruts:  [(x,1)]

-We do *not* want to specialise the call to 'f', because 'x' is not free
+We do *not* want to specialise the call to 'f', because '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.
@@ -302,9 +295,9 @@ an occurrence of 'g', we want to check that there's a scruted-var v st

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

\begin{code}
@@ -315,8 +308,8 @@ addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
lvl_env' = extendVarEnvList lvl_env (binders zip repeat lvl)

addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
-addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,
-                            lc_rec_env = rec_env}) pairs
+addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,
+                             lc_rec_env = rec_env}) pairs
= env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }
where
lvl'     = lvl + 1
@@ -324,22 +317,22 @@ addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,
rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]

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

-addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
-                               lc_scruts = scruts }) scrut_var
+addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
+                                lc_scruts = scruts }) scrut_var
| bind_lvl < lvl
= env { lc_scruts = scruts' }
-       -- Add to scruts iff the scrut_var is being scrutinised at
-       -- a deeper level than its defn
+        -- Add to scruts iff the scrut_var is being scrutinised at
+        -- a deeper level than its defn

| otherwise = env
where
scruts'  = (scrut_var, bind_lvl, lvl) : scruts
bind_lvl = case lookupVarEnv lvl_env scrut_var of
-                Just lvl -> lvl
-                Nothing  -> topLevel
+                 Just lvl -> lvl
+                 Nothing  -> topLevel

lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
lookupRecId env id = lookupVarEnv (lc_rec_env env) id
@@ -352,9 +345,9 @@ lookupLevel env id
\end{code}

%************************************************************************
-%*                                                                     *
-        The environment
-%*                                                                     *
+%*                                                                      *
+         The environment
+%*                                                                      *
%************************************************************************

\begin{code}
@@ -369,46 +362,46 @@ data LibCaseEnv
= LibCaseEnv {
lc_dflags :: DynFlags,

-       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,
-               -- 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, LibCaseLevel)]
-               -- Each of these Ids was scrutinised by an enclosing
-               -- case expression, at a level deeper than its binding
-               -- level.
-               --
-               -- The first LibCaseLevel is the *binding level* of
-               --   the scrutinised Id,
-               -- The second is the level *at which it was scrutinised*.
-               --   (see Note [Avoiding fruitless liberate-case])
-               -- The former is a bit redundant, since you could always
-               -- look it up in lc_lvl_env, but it's just cached here
-               --
-               -- The order is insignificant; it's a bag really
-               --
-               -- There's one element per scrutinisation;
-               --    in principle the same Id may appear multiple times,
-               --    although that'd be unusual:
-               --       case x of { (a,b) -> ....(case x of ...) .. }
-       }
+        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,
+                -- 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, LibCaseLevel)]
+                -- Each of these Ids was scrutinised by an enclosing
+                -- case expression, at a level deeper than its binding
+                -- level.
+                --
+                -- The first LibCaseLevel is the *binding level* of
+                --   the scrutinised Id,
+                -- The second is the level *at which it was scrutinised*.
+                --   (see Note [Avoiding fruitless liberate-case])
+                -- The former is a bit redundant, since you could always
+                -- look it up in lc_lvl_env, but it's just cached here
+                --
+                -- The order is insignificant; it's a bag really
+                --
+                -- There's one element per scrutinisation;
+                --    in principle the same Id may appear multiple times,
+                --    although that'd be unusual:
+                --       case x of { (a,b) -> ....(case x of ...) .. }
+        }

initEnv :: DynFlags -> LibCaseEnv
-initEnv dflags
+initEnv dflags
= LibCaseEnv { lc_dflags = 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 = [] }

-- Bomb-out size for deciding if
-- potential liberatees are too big.
@@ -416,4 +409,3 @@ initEnv dflags
bombOutSize :: LibCaseEnv -> Maybe Int
bombOutSize = liberateCaseThreshold . lc_dflags
\end{code}
-