simplCore: detabify/dewhitespace LiberateCase
authorAustin Seipp <austin@well-typed.com>
Wed, 20 Aug 2014 08:36:39 +0000 (03:36 -0500)
committerAustin Seipp <austin@well-typed.com>
Wed, 20 Aug 2014 08:47:35 +0000 (03:47 -0500)
Signed-off-by: Austin Seipp <austin@well-typed.com>
compiler/simplCore/LiberateCase.lhs

index 2593ab1..21adf20 100644 (file)
@@ -5,20 +5,13 @@
 
 \begin{code}
 {-# LANGUAGE CPP #-}
 
 \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
 module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
 import DynFlags
 import CoreSyn
-import CoreUnfold      ( couldBeSmallEnoughToInline )
+import CoreUnfold       ( couldBeSmallEnoughToInline )
 import Id
 import VarEnv
 import Util             ( notNull )
 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:
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 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
 
 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
 
 => 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
 (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.
 
 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.
 
 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
 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.
 
 
 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}
 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).
 
 
 %************************************************************************
 \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}
 %************************************************************************
 
 \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
     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}
 
 
 %************************************************************************
 \end{code}
 
 
 %************************************************************************
-%*                                                                     *
-        Main payload
-%*                                                                     *
+%*                                                                      *
+         Main payload
+%*                                                                      *
 %************************************************************************
 
 Bindings
 %************************************************************************
 
 Bindings
@@ -158,18 +151,18 @@ libCaseBind env (Rec pairs)
 
     pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- 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)
     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}
 
                       (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
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 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
 
 (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
 
 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.
 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
 
 \begin{code}
 libCase :: LibCaseEnv
-       -> CoreExpr
-       -> CoreExpr
+        -> CoreExpr
+        -> CoreExpr
 
 libCase env (Var v)             = libCaseId env v
 libCase _   (Lit lit)           = Lit lit
 
 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
   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)
 
 libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
                          -> (AltCon, [CoreBndr], CoreExpr)
@@ -239,8 +232,8 @@ Ids
 \begin{code}
 libCaseId :: LibCaseEnv -> Id -> CoreExpr
 libCaseId env v
 \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
   = Let the_bind (Var v)
 
   | otherwise
@@ -251,34 +244,34 @@ libCaseId env v
     free_scruts  = freeScruts env rec_id_level
 
 freeScruts :: LibCaseEnv
     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]
 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
 \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
 
 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
 
 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.
 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}
 %************************************************************************
 
 \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
     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
   = 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
     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' }
   | 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
 
   | 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
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
 lookupRecId env id = lookupVarEnv (lc_rec_env env) id
@@ -352,9 +345,9 @@ lookupLevel env id
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
-%*                                                                     *
-        The environment
-%*                                                                     *
+%*                                                                      *
+         The environment
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
@@ -369,46 +362,46 @@ data LibCaseEnv
   = LibCaseEnv {
         lc_dflags :: DynFlags,
 
   = 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 :: DynFlags -> LibCaseEnv
-initEnv dflags 
+initEnv dflags
   = LibCaseEnv { lc_dflags = 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.
 
 -- 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}
 bombOutSize :: LibCaseEnv -> Maybe Int
 bombOutSize = liberateCaseThreshold . lc_dflags
 \end{code}
-