[project @ 2001-11-19 16:34:12 by simonpj]

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

diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 4744b33..2957520 100644 (file)
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -16,16 +16,16 @@ module FloatIn ( floatInwards ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt )
+import CmdLineOpts     ( DynFlags, DynFlag(..) )
 import CoreSyn
 import CoreUtils       ( exprIsValue, exprIsDupable )
-import CoreLint                ( beginPass, endPass )
+import CoreLint                ( showPass, endPass )
 import CoreFVs         ( CoreExprWithFVs, freeVars, freeVarsOf )
 import Id              ( isOneShotLambda )
-import Var             ( Id, idType, isTyVar )
+import Var             ( Id, idType )
 import Type            ( isUnLiftedType )
 import VarSet
-import Util            ( zipEqual, zipWithEqual )
+import Util            ( zipEqual, zipWithEqual, count )
 import Outputable
 \end{code}
 
@@ -37,12 +37,10 @@ floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
 
 floatInwards dflags binds
   = do {
-       beginPass dflags "Float inwards";
+       showPass dflags "Float inwards";
        let { binds' = map fi_top_bind binds };
-       endPass dflags "Float inwards" 
-               (dopt Opt_D_verbose_core2core dflags)
+       endPass dflags "Float inwards" Opt_D_verbose_core2core binds'   
                                {- no specific flag for dumping float-in -} 
-               binds'  
     }
                          
   where
@@ -184,13 +182,17 @@ So we treat lambda in groups, using the following rule:
 fiExpr to_drop (_, AnnLam b body)
   = case collect [b] body of
       (bndrs, real_body)
-       | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+--     | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+-- [July 01: I'm experiment with getting the full laziness
+-- pass to floats bindings out past big lambdas (instead of the simplifier)
+-- so I don't want the float-in pass to just push them right back in.
+-- I'm going to try just dumping all bindings outside lambdas.]
        | otherwise       -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
   where
     collect bs (_, AnnLam b body) = collect (b:bs) body
     collect bs body              = (reverse bs, body)
 
-    is_ok bndr = isTyVar bndr || isOneShotLambda bndr
+--    is_ok bndr = isTyVar bndr || isOneShotLambda bndr
 \end{code}
 
 We don't float lets inwards past an SCC.
@@ -215,11 +217,6 @@ fiExpr to_drop (_, AnnNote InlineMe expr)
 fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
   =    -- Just float in past coercion
     Note note (fiExpr to_drop expr)
-
-fiExpr to_drop (_, AnnNote note@(TermUsg _) expr)
-  =     -- Float in past term usage annotation
-        -- (for now; not sure if this is correct: KSW 1999-05)
-    Note note (fiExpr to_drop expr)
 \end{code}
 
 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
@@ -270,7 +267,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
   = fiExpr new_to_drop body
   where
-    (binders, rhss) = unzip bindings
+    rhss = map snd bindings
 
     rhss_fvs = map freeVarsOf rhss
     body_fvs = freeVarsOf body
@@ -427,7 +424,7 @@ sepBindsByDropPoint is_case drop_pts floaters
                --        E -> ...not mentioning x...
 
          n_alts      = length used_in_flags
-         n_used_alts = length [() | True <- used_in_flags]
+         n_used_alts = count id used_in_flags -- returns number of Trues in list.
 
          can_push = n_used_alts == 1           -- Used in just one branch
                   || (is_case &&               -- We are looking at case alternatives