Super-monster patch implementing the new typechecker -- at last

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

diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index 0e8edb5..b9f44c9 100644 (file)
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -16,16 +16,15 @@ module FloatIn ( floatInwards ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import DynFlags        ( DynFlags, DynFlag(..) )

 import CoreSyn
 import CoreUtils       ( exprIsHNF, exprIsDupable )
 import CoreSyn
 import CoreUtils       ( exprIsHNF, exprIsDupable )

-import CoreLint                ( showPass, endPass )
-import CoreFVs         ( CoreExprWithFVs, freeVars, freeVarsOf )
-import Id              ( isOneShotBndr )
-import Var             ( Id, idType )
+import CoreFVs         ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
+import Id              ( isOneShotBndr, idType )
+import Var

 import Type            ( isUnLiftedType )
 import VarSet
 import Util            ( zipEqual, zipWithEqual, count )
 import Type            ( isUnLiftedType )
 import VarSet
 import Util            ( zipEqual, zipWithEqual, count )

+import UniqFM

 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 

@@ -33,16 +32,8 @@ Top-level interface function, @floatInwards@.  Note that we do not
 actually float any bindings downwards from the top-level.
 
 \begin{code}
 actually float any bindings downwards from the top-level.
 
 \begin{code}

-floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
-floatInwards dflags binds
-  = do {
-       showPass dflags "Float inwards";
-       let { binds' = map fi_top_bind binds };
-       endPass dflags "Float inwards" Opt_D_verbose_core2core binds'   
-                               {- no specific flag for dumping float-in -} 
-    }
-                         
+floatInwards :: [CoreBind] -> [CoreBind]
+floatInwards = map fi_top_bind

   where
     fi_top_bind (NonRec binder rhs)
       = NonRec binder (fiExpr [] (freeVars rhs))
   where
     fi_top_bind (NonRec binder rhs)
       = NonRec binder (fiExpr [] (freeVars rhs))

@@ -124,7 +115,7 @@ the closure for a is not built.
 type FreeVarsSet   = IdSet
 
 type FloatingBinds = [(CoreBind, FreeVarsSet)]
 type FreeVarsSet   = IdSet
 
 type FloatingBinds = [(CoreBind, FreeVarsSet)]

-       -- In reverse dependency order (innermost bindiner first)
+       -- In reverse dependency order (innermost binder first)

 
        -- The FreeVarsSet is the free variables of the binding.  In the case
        -- of recursive bindings, the set doesn't include the bound
 
        -- The FreeVarsSet is the free variables of the binding.  In the case
        -- of recursive bindings, the set doesn't include the bound

@@ -139,8 +130,10 @@ fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
 
 fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
                                 Type ty
 
 fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
                                 Type ty

+fiExpr to_drop (_, AnnCast expr co)
+  = Cast (fiExpr to_drop expr) co      -- Just float in past coercion

 
 

-fiExpr to_drop (_, AnnLit lit) = Lit lit
+fiExpr _ (_, AnnLit lit) = Lit lit

 \end{code}
 
 Applications: we do float inside applications, mainly because we
 \end{code}
 
 Applications: we do float inside applications, mainly because we

@@ -154,8 +147,8 @@ fiExpr to_drop (_,AnnApp fun arg)
     [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
 \end{code}
 
     [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
 \end{code}
 

-We are careful about lambdas: 
-
+Note [Floating in past a lambda group]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 * We must be careful about floating inside inside a value lambda.  
   That risks losing laziness.
   The float-out pass might rescue us, but then again it might not.
 * We must be careful about floating inside inside a value lambda.  
   That risks losing laziness.
   The float-out pass might rescue us, but then again it might not.

@@ -171,24 +164,30 @@ We are careful about lambdas:
   This is bad as now f is an updatable closure (update PAP)
   and has arity 0.
 
   This is bad as now f is an updatable closure (update PAP)
   and has arity 0.
 

+* Hack alert!  We only float in through one-shot lambdas, 
+  not (as you might guess) through lone big lambdas.  
+  Reason: we float *out* past big lambdas (see the test in the Lam
+  case of FloatOut.floatExpr) and we don't want to float straight
+  back in again.
+  
+  It *is* important to float into one-shot lambdas, however;
+  see the remarks with noFloatIntoRhs.
+

 So we treat lambda in groups, using the following rule:
 
 So we treat lambda in groups, using the following rule:
 

-       Float inside a group of lambdas only if
-       they are all either type lambdas or one-shot lambdas.
+ Float in if (a) there is at least one Id, 
+         and (b) there are no non-one-shot Ids
+
+ Otherwise drop all the bindings outside the group.
+
+This is what the 'go' function in the AnnLam case is doing.

 
 

-       Otherwise drop all the bindings outside the group.
+Urk! if all are tyvars, and we don't float in, we may miss an 
+      opportunity to float inside a nested case branch

 
 \begin{code}
 
 \begin{code}

-       -- Hack alert!  We only float in through one-shot lambdas, 
-       -- not (as you might guess) through big lambdas.  
-       -- Reason: we float *out* past big lambdas (see the test in the Lam
-       -- case of FloatOut.floatExpr) and we don't want to float straight
-       -- back in again.
-       --
-       -- It *is* important to float into one-shot lambdas, however;
-       -- see the remarks with noFloatIntoRhs.

 fiExpr to_drop lam@(_, AnnLam _ _)
 fiExpr to_drop lam@(_, AnnLam _ _)

-  | all is_one_shot bndrs      -- Float in
+  | go False bndrs     -- Float in

   = mkLams bndrs (fiExpr to_drop body)
 
   | otherwise          -- Dump it all here
   = mkLams bndrs (fiExpr to_drop body)
 
   | otherwise          -- Dump it all here

@@ -196,6 +195,12 @@ fiExpr to_drop lam@(_, AnnLam _ _)
 
   where
     (bndrs, body) = collectAnnBndrs lam
 
   where
     (bndrs, body) = collectAnnBndrs lam

+
+    go seen_one_shot_id [] = seen_one_shot_id
+    go seen_one_shot_id (b:bs)
+      | isTyCoVar       b = go seen_one_shot_id bs
+      | isOneShotBndr b = go True bs
+      | otherwise       = False         -- Give up at a non-one-shot Id

 \end{code}
 
 We don't float lets inwards past an SCC.
 \end{code}
 
 We don't float lets inwards past an SCC.

@@ -204,23 +209,10 @@ We don't float lets inwards past an SCC.
        cc, change current cc to the new one and float binds into expr.
 
 \begin{code}
        cc, change current cc to the new one and float binds into expr.
 
 \begin{code}

-fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
+fiExpr to_drop (_, AnnNote note@(SCC _) expr)

   =    -- Wimp out for now
     mkCoLets' to_drop (Note note (fiExpr [] expr))
 
   =    -- Wimp out for now
     mkCoLets' to_drop (Note note (fiExpr [] expr))
 

-fiExpr to_drop (_, AnnNote InlineCall expr)
-  =    -- Wimp out for InlineCall; keep it close
-       -- the the call it annotates
-    mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
-
-fiExpr to_drop (_, AnnNote InlineMe expr)
-  =    -- Ditto... don't float anything into an INLINE expression
-    mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
-
-fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
-  =    -- Just float in past coercion
-    Note note (fiExpr to_drop expr)
-

 fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
   = Note note (fiExpr to_drop expr)
 \end{code}
 fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
   = Note note (fiExpr to_drop expr)
 \end{code}

@@ -247,66 +239,86 @@ So: rather than drop \tr{w}'s binding here, we add it onto the list of
 things to drop in the outer let's body, and let nature take its
 course.
 
 things to drop in the outer let's body, and let nature take its
 course.
 

+Note [extra_fvs (1): avoid floating into RHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consdider let x=\y....t... in body.  We do not necessarily want to float 
+a binding for t into the RHS, because it'll immediately be floated out
+again.  (It won't go inside the lambda else we risk losing work.)
+In letrec, we need to be more careful still. We don't want to transform
+       let x# = y# +# 1#
+       in
+       letrec f = \z. ...x#...f...
+       in ...
+into
+       letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
+because now we can't float the let out again, because a letrec
+can't have unboxed bindings.
+
+So we make "extra_fvs" which is the rhs_fvs of such bindings, and
+arrange to dump bindings that bind extra_fvs before the entire let.
+
+Note [extra_fvs (s): free variables of rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider 
+  let x{rule mentioning y} = rhs in body 
+Here y is not free in rhs or body; but we still want to dump bindings
+that bind y outside the let.  So we augment extra_fvs with the
+idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
+idFreeVars.
+
+

 \begin{code}
 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
   = fiExpr new_to_drop body
   where
     body_fvs = freeVarsOf body
 
 \begin{code}
 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
   = fiExpr new_to_drop body
   where
     body_fvs = freeVarsOf body
 

-    final_body_fvs | noFloatIntoRhs ann_rhs
-                  || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs
-                  | otherwise                   = body_fvs
-       -- See commments with letrec below
+    rule_fvs = idRuleAndUnfoldingVars id       -- See Note [extra_fvs (2): free variables of rules]
+    extra_fvs | noFloatIntoRhs ann_rhs
+             || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
+             | otherwise                   = rule_fvs
+       -- See Note [extra_fvs (2): avoid floating into RHS]

        -- No point in floating in only to float straight out again
        -- Ditto ok-for-speculation unlifted RHSs
 
        -- No point in floating in only to float straight out again
        -- Ditto ok-for-speculation unlifted RHSs
 

-    [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint False [rhs_fvs, final_body_fvs] to_drop
+    [shared_binds, extra_binds, rhs_binds, body_binds] 
+       = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop

 
     new_to_drop = body_binds ++                                -- the bindings used only in the body
                  [(NonRec id rhs', rhs_fvs')] ++       -- the new binding itself
 
     new_to_drop = body_binds ++                                -- the bindings used only in the body
                  [(NonRec id rhs', rhs_fvs')] ++       -- the new binding itself

+                 extra_binds ++                        -- bindings from extra_fvs

                  shared_binds                          -- the bindings used both in rhs and body
 
        -- Push rhs_binds into the right hand side of the binding
     rhs'     = fiExpr rhs_binds rhs
                  shared_binds                          -- the bindings used both in rhs and body
 
        -- Push rhs_binds into the right hand side of the binding
     rhs'     = fiExpr rhs_binds rhs

-    rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
+    rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs
+                       -- Don't forget the rule_fvs; the binding mentions them!

 
 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
   = fiExpr new_to_drop body
   where
 
 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
   = fiExpr new_to_drop body
   where

-    rhss = map snd bindings
-
+    (ids, rhss) = unzip bindings

     rhss_fvs = map freeVarsOf rhss
     body_fvs = freeVarsOf body
 
     rhss_fvs = map freeVarsOf rhss
     body_fvs = freeVarsOf body
 

-       -- Add to body_fvs the free vars of any RHS that has
-       -- a lambda at the top.  This has the effect of making it seem
-       -- that such things are used in the body as well, and hence prevents
-       -- them getting floated in.  The big idea is to avoid turning:
-       --      let x# = y# +# 1#
-       --      in
-       --      letrec f = \z. ...x#...f...
-       --      in ...
-       -- into
-       --      letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
-       -- 
-       -- Because now we can't float the let out again, because a letrec
-       -- can't have unboxed bindings.
-
-    final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss
-    get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs
-                             | otherwise          = emptyVarSet
-
-    (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (final_body_fvs:rhss_fvs) to_drop
-
-    new_to_drop = -- the bindings used only in the body
-                 body_binds ++
-                 -- the new binding itself
+       -- See Note [extra_fvs (1,2)]
+    rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids
+    extra_fvs = rule_fvs `unionVarSet` 
+               unionVarSets [ fvs | (fvs, rhs) <- rhss
+                            , noFloatIntoRhs rhs ]
+
+    (shared_binds:extra_binds:body_binds:rhss_binds) 
+       = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop
+
+    new_to_drop = body_binds ++                -- the bindings used only in the body

                  [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
                  [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++

-                 -- the bindings used both in rhs and body or in more than one rhs
-                 shared_binds
+                                       -- The new binding itself
+                 extra_binds ++        -- Note [extra_fvs (1,2)]
+                 shared_binds          -- Used in more than one place

 
 

-    rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
-                          (unionVarSets (map floatedBindsFVs rhss_binds))
+    rhs_fvs' = unionVarSets rhss_fvs `unionVarSet`
+              unionVarSets (map floatedBindsFVs rhss_binds) `unionVarSet`
+              rule_fvs         -- Don't forget the rule variables!

 
     -- Push rhs_binds into the right hand side of the binding
     fi_bind :: [FloatingBinds]     -- one per "drop pt" conjured w/ fvs_of_rhss
 
     -- Push rhs_binds into the right hand side of the binding
     fi_bind :: [FloatingBinds]     -- one per "drop pt" conjured w/ fvs_of_rhss

@@ -338,14 +350,14 @@ fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
     scrut_fvs    = freeVarsOf scrut
     alts_fvs     = map alt_fvs alts
     all_alts_fvs = unionVarSets alts_fvs
     scrut_fvs    = freeVarsOf scrut
     alts_fvs     = map alt_fvs alts
     all_alts_fvs = unionVarSets alts_fvs

-    alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
+    alt_fvs (_con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)

                                -- Delete case_bndr and args from free vars of rhs 
                                -- to get free vars of alt
 
     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 
                                -- Delete case_bndr and args from free vars of rhs 
                                -- to get free vars of alt
 
     fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
 

-noFloatIntoRhs (AnnNote InlineMe _) = True
-noFloatIntoRhs (AnnLam b _)        = not (is_one_shot b)
+noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool
+noFloatIntoRhs (AnnLam b _) = not (is_one_shot b)

        -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
        -- This makes a big difference for things like
        --      f x# = let x = I# x#
        -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
        -- This makes a big difference for things like
        --      f x# = let x = I# x#

@@ -357,6 +369,7 @@ noFloatIntoRhs (AnnLam b _)             = not (is_one_shot b)
 
 noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs)       -- We'd just float right back out again...
 
 
 noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs)       -- We'd just float right back out again...
 

+is_one_shot :: Var -> Bool

 is_one_shot b = isId b && isOneShotBndr b
 \end{code}
 
 is_one_shot b = isId b && isOneShotBndr b
 \end{code}
 

@@ -399,8 +412,8 @@ sepBindsByDropPoint
 
 type DropBox = (FreeVarsSet, FloatingBinds)
 
 
 type DropBox = (FreeVarsSet, FloatingBinds)
 

-sepBindsByDropPoint is_case drop_pts []
-  = [] : [[] | p <- drop_pts]  -- cut to the chase scene; it happens
+sepBindsByDropPoint _is_case drop_pts []
+  = [] : [[] | _ <- drop_pts]  -- cut to the chase scene; it happens

 
 sepBindsByDropPoint is_case drop_pts floaters
   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
 
 sepBindsByDropPoint is_case drop_pts floaters
   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))

@@ -418,7 +431,7 @@ sepBindsByDropPoint is_case drop_pts floaters
          -- "here" means the group of bindings dropped at the top of the fork
 
          (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
          -- "here" means the group of bindings dropped at the top of the fork
 
          (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)

-                                       | (fvs, drops) <- drop_boxes]
+                                       | (fvs, _) <- drop_boxes]

 
          drop_here = used_here || not can_push
 
 
          drop_here = used_here || not can_push
 

@@ -451,6 +464,8 @@ sepBindsByDropPoint is_case drop_pts floaters
          insert_maybe box True  = insert box
          insert_maybe box False = box
 
          insert_maybe box True  = insert box
          insert_maybe box False = box
 

+    go _ _ = panic "sepBindsByDropPoint/go"
+

 
 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 floatedBindsFVs binds = unionVarSets (map snd binds)
 
 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 floatedBindsFVs binds = unionVarSets (map snd binds)

@@ -459,6 +474,7 @@ mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
        -- Remember to_drop is in *reverse* dependency order
 
 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
        -- Remember to_drop is in *reverse* dependency order
 

+bindIsDupable :: Bind CoreBndr -> Bool

 bindIsDupable (Rec prs)    = all (exprIsDupable . snd) prs
 bindIsDupable (Rec prs)    = all (exprIsDupable . snd) prs

-bindIsDupable (NonRec b r) = exprIsDupable r
+bindIsDupable (NonRec _ r) = exprIsDupable r

 \end{code}
 \end{code}