[project @ 1999-11-01 17:09:54 by simonpj]

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

diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index e4e47f7..83e5d5a 100644 (file)
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -15,7 +15,7 @@ import CoreSyn
 import CmdLineOpts     ( opt_D_verbose_core2core, opt_D_dump_simpl_stats )
 import ErrUtils                ( dumpIfSet )
 import CostCentre      ( dupifyCC, CostCentre )
-import Id              ( Id )
+import Id              ( Id, idType )
 import Const           ( isWHNFCon )
 import VarEnv
 import CoreLint                ( beginPass, endPass )
@@ -24,6 +24,7 @@ import SetLevels      ( setLevels,
                          Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl
                        )
 import BasicTypes      ( Unused )
+import Type            ( isUnLiftedType )
 import Var             ( TyVar )
 import UniqSupply       ( UniqSupply )
 import List            ( partition )
@@ -128,15 +129,11 @@ floatBind :: IdEnv Level
          -> (FloatStats, FloatBinds, CoreBind, IdEnv Level)
 
 floatBind env lvl (NonRec (name,level) rhs)
-  = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
-
-       -- A good dumping point
-    case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
-
-    (fs, rhs_floats',
-     NonRec name (install heres rhs'),
+  = case (floatRhs env level rhs) of { (fs, rhs_floats, rhs') ->
+    (fs, rhs_floats,
+     NonRec name rhs',
      extendVarEnv env name level)
-    }}
+    }
 
 floatBind env lvl bind@(Rec pairs)
   = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
@@ -172,13 +169,9 @@ floatBind env lvl bind@(Rec pairs)
     bind_level = getBindLevel bind
 
     do_pair ((name, level), rhs)
-      = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
-
-               -- A good dumping point
-       case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
-
-       (fs, rhs_floats', (name, install heres rhs'))
-       }}
+      = case (floatRhs new_env level rhs) of { (fs, rhs_floats, rhs') ->
+       (fs, rhs_floats, (name, rhs'))
+       }
 \end{code}
 
 %************************************************************************
@@ -188,20 +181,32 @@ floatBind env lvl bind@(Rec pairs)
 %************************************************************************
 
 \begin{code}
-floatExpr :: IdEnv Level
-         -> Level
-         -> LevelledExpr
-         -> (FloatStats, FloatBinds, CoreExpr)
+floatExpr, floatRhs
+        :: IdEnv Level
+        -> Level
+        -> LevelledExpr
+        -> (FloatStats, FloatBinds, CoreExpr)
+
+floatRhs env lvl arg
+  = case (floatExpr env lvl arg) of { (fsa, floats, arg') ->
+    case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
+       -- Dump bindings that aren't going to escape from a lambda
+       -- This is to avoid floating the x binding out of
+       --      f (let x = e in b)
+       -- unnecessarily.  It even causes a bug to do so if we have
+       --      y = writeArr# a n (let x = e in b)
+       -- because the y binding is an expr-ok-for-speculation one.
+    (fsa, floats', install heres arg') }}
 
 floatExpr env _ (Var v)             = (zeroStats, [], Var v)
 floatExpr env _ (Type ty)    = (zeroStats, [], Type ty)
 floatExpr env lvl (Con con as) 
-  = case floatList (floatExpr env lvl) as of { (stats, floats, as') ->
+  = case floatList (floatRhs env lvl) as of { (stats, floats, as') ->
     (stats, floats, Con con as') }
          
 floatExpr env lvl (App e a)
   = case (floatExpr env lvl e) of { (fse, floats_e, e') ->
-    case (floatExpr env lvl a) of { (fsa, floats_a, a') ->
+    case (floatRhs env lvl a) of { (fsa, floats_a, a') ->
     (fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }}
 
 floatExpr env lvl (Lam (tv,incd_lvl) e)
@@ -257,6 +262,16 @@ floatExpr env lvl (Note note@(SCC cc) expr)
        -- Note: Nested SCC's are preserved for the benefit of
        --       cost centre stack profiling (Durham)
 
+-- At one time I tried the effect of not float anything out of an InlineMe,
+-- but it sometimes works badly.  For example, consider PrelArr.done.  It
+-- has the form        __inline (\d. e)
+-- where e doesn't mention d.  If we float this to 
+--     __inline (let x = e in \d. x)
+-- things are bad.  The inliner doesn't even inline it because it doesn't look
+-- like a head-normal form.  So it seems a lesser evil to let things float.
+-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
+-- which discourages floating out.
+
 floatExpr env lvl (Note note expr)     -- Other than SCCs
   = case (floatExpr env lvl expr)    of { (fs, floating_defns, expr') ->
     (fs, floating_defns, Note note expr') }
@@ -355,8 +370,16 @@ partitionByMajorLevel, partitionByLevel
 partitionByMajorLevel ctxt_lvl defns
   = partition float_further defns
   where
-    float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
-                               isTopLvl my_lvl
+       -- Float it if we escape a value lambda, 
+       -- or if we get to the top level
+    float_further (my_lvl, bind) = my_lvl `ltMajLvl` ctxt_lvl || isTopLvl my_lvl
+       -- The isTopLvl part says that if we can get to the top level, say "yes" anyway
+       -- This means that 
+       --      x = f e
+       -- transforms to 
+       --    lvl = e
+       --    x = f lvl
+       -- which is as it should be
 
 partitionByLevel ctxt_lvl defns
   = partition float_further defns