Make LiberateCase warning-free

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

diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index 0e8edb5..0ac4295 100644 (file)
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -20,12 +20,13 @@ import DynFlags     ( DynFlags, DynFlag(..) )
 import CoreSyn
 import CoreUtils       ( exprIsHNF, exprIsDupable )
 import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUtils       ( exprIsHNF, exprIsDupable )
 import CoreLint                ( showPass, endPass )

-import CoreFVs         ( CoreExprWithFVs, freeVars, freeVarsOf )
+import CoreFVs         ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars )

 import Id              ( isOneShotBndr )
 import Id              ( isOneShotBndr )

-import Var             ( Id, 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}
 

@@ -124,7 +125,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 +140,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

@@ -204,23 +207,14 @@ 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 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,23 +241,52 @@ 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
+idRuleVars of x.
+
+

 \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 = idRuleVars 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
                  shared_binds                          -- the bindings used both in rhs and body
 
        -- Push rhs_binds into the right hand side of the binding

@@ -278,32 +301,20 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
     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)]
+    extra_fvs = foldr (unionVarSet . get_extras) emptyVarSet bindings
+    get_extras (id, (rhs_fvs, rhs)) 
+       | noFloatIntoRhs rhs = idRuleVars id `unionVarSet` rhs_fvs
+       | otherwise          = idRuleVars id
+
+    (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' = unionVarSet (unionVarSets rhss_fvs)
                           (unionVarSets (map floatedBindsFVs rhss_binds))

@@ -338,12 +349,13 @@ 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 :: AnnExpr' Var (UniqFM Var) -> Bool

 noFloatIntoRhs (AnnNote InlineMe _) = True
 noFloatIntoRhs (AnnLam b _)        = not (is_one_shot b)
        -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
 noFloatIntoRhs (AnnNote InlineMe _) = True
 noFloatIntoRhs (AnnLam b _)        = not (is_one_shot b)
        -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.

@@ -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}