Add pprDefiniteTrace and use it

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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 6fe24df..db84c90 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -38,7 +38,7 @@ import CostCentre       ( currentCCS, pushCCisNop )
 import TysPrim          ( realWorldStatePrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils      ( foldlM, mapAccumLM )
 import TysPrim          ( realWorldStatePrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils      ( foldlM, mapAccumLM )

-import Maybes           ( orElse )
+import Maybes           ( orElse, isNothing )

 import Data.List        ( mapAccumL )
 import Outputable
 import FastString
 import Data.List        ( mapAccumL )
 import Outputable
 import FastString

@@ -1237,10 +1237,10 @@ completeCall env var cont
       | not (dopt Opt_D_dump_inlinings dflags) = stuff
       | not (dopt Opt_D_verbose_core2core dflags) 
       = if isExternalName (idName var) then 
       | not (dopt Opt_D_dump_inlinings dflags) = stuff
       | not (dopt Opt_D_verbose_core2core dflags) 
       = if isExternalName (idName var) then 

-         pprTrace "Inlining done:" (ppr var) stuff
+         pprDefiniteTrace "Inlining done:" (ppr var) stuff

         else stuff
       | otherwise
         else stuff
       | otherwise

-      = pprTrace ("Inlining done: " ++ showSDoc (ppr var))
+      = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var))

            (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
                   text "Cont:  " <+> ppr cont])
            stuff
            (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
                   text "Cont:  " <+> ppr cont])
            stuff

@@ -1391,11 +1391,12 @@ tryRules env rules fn args call_cont
     trace_dump dflags rule rule_rhs stuff
       | not (dopt Opt_D_dump_rule_firings dflags)
       , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
     trace_dump dflags rule rule_rhs stuff
       | not (dopt Opt_D_dump_rule_firings dflags)
       , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff

+

       | not (dopt Opt_D_dump_rule_rewrites dflags)
       | not (dopt Opt_D_dump_rule_rewrites dflags)

+      = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff

 
 

-      = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff

       | otherwise
       | otherwise

-      = pprTrace "Rule fired"
+      = pprDefiniteTrace "Rule fired"

            (vcat [text "Rule:" <+> ftext (ru_name rule),
                  text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
                  text "After: " <+> pprCoreExpr rule_rhs,
            (vcat [text "Rule:" <+> ftext (ru_name rule),
                  text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
                  text "After: " <+> pprCoreExpr rule_rhs,

@@ -1682,16 +1683,6 @@ the case binder is guaranteed dead.
 In practice, the scrutinee is almost always a variable, so we pretty
 much always zap the OccInfo of the binders.  It doesn't matter much though.
 
 In practice, the scrutinee is almost always a variable, so we pretty
 much always zap the OccInfo of the binders.  It doesn't matter much though.
 

-
-Note [Case of cast]
-~~~~~~~~~~~~~~~~~~~
-Consider        case (v `cast` co) of x { I# y ->
-                ... (case (v `cast` co) of {...}) ...
-We'd like to eliminate the inner case.  We can get this neatly by
-arranging that inside the outer case we add the unfolding
-        v |-> x `cast` (sym co)
-to v.  Then we should inline v at the inner case, cancel the casts, and away we go
-

 Note [Improving seq]
 ~~~~~~~~~~~~~~~~~~~
 Consider
 Note [Improving seq]
 ~~~~~~~~~~~~~~~~~~~
 Consider

@@ -1708,7 +1699,7 @@ where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
 
 so that 'rhs' can take advantage of the form of x'.  
 
 
 so that 'rhs' can take advantage of the form of x'.  
 

-Notice that Note [Case of cast] may then apply to the result. 
+Notice that Note [Case of cast] (in OccurAnal) may then apply to the result. 

 
 Nota Bene: We only do the [Improving seq] transformation if the 
 case binder 'x' is actually used in the rhs; that is, if the case 
 
 Nota Bene: We only do the [Improving seq] transformation if the 
 case binder 'x' is actually used in the rhs; that is, if the case 

@@ -1765,7 +1756,9 @@ simplAlts env scrut case_bndr alts cont'
 
         ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
 
 
         ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
 

-        ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
+       ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing }
+        ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
+                             imposs_deflt_cons case_bndr' cont') in_alts

         ; return (scrut', case_bndr', alts') }
 
 
         ; return (scrut', case_bndr', alts') }
 
 

@@ -1788,27 +1781,30 @@ improveSeq _ env scrut _ case_bndr1 _
 
 ------------------------------------
 simplAlt :: SimplEnv
 
 ------------------------------------
 simplAlt :: SimplEnv

-         -> [AltCon]    -- These constructors can't be present when
-                        -- matching the DEFAULT alternative
-         -> OutId       -- The case binder
+        -> Maybe OutId    -- Scrutinee
+         -> [AltCon]       -- These constructors can't be present when
+                           -- matching the DEFAULT alternative
+         -> OutId          -- The case binder

          -> SimplCont
          -> InAlt
          -> SimplM OutAlt
 
          -> SimplCont
          -> InAlt
          -> SimplM OutAlt
 

-simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
+simplAlt env scrut imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)

   = ASSERT( null bndrs )
   = ASSERT( null bndrs )

-    do  { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
+    do  { let env' = addBinderUnfolding env scrut case_bndr' 
+                                        (mkOtherCon imposs_deflt_cons)

                 -- Record the constructors that the case-binder *can't* be.
         ; rhs' <- simplExprC env' rhs cont'
         ; return (DEFAULT, [], rhs') }
 
                 -- Record the constructors that the case-binder *can't* be.
         ; rhs' <- simplExprC env' rhs cont'
         ; return (DEFAULT, [], rhs') }
 

-simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
+simplAlt env scrut _ case_bndr' cont' (LitAlt lit, bndrs, rhs)

   = ASSERT( null bndrs )
   = ASSERT( null bndrs )

-    do  { let env' = addBinderUnfolding env case_bndr' (Lit lit)
+    do  { let env' = addBinderUnfolding env scrut case_bndr' 
+                                        (mkSimpleUnfolding (Lit lit))

         ; rhs' <- simplExprC env' rhs cont'
         ; return (LitAlt lit, [], rhs') }
 
         ; rhs' <- simplExprC env' rhs cont'
         ; return (LitAlt lit, [], rhs') }
 

-simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
+simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs)

   = do  {       -- Deal with the pattern-bound variables
                 -- Mark the ones that are in ! positions in the
                 -- data constructor as certainly-evaluated.
   = do  {       -- Deal with the pattern-bound variables
                 -- Mark the ones that are in ! positions in the
                 -- data constructor as certainly-evaluated.

@@ -1819,8 +1815,8 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
                 -- Bind the case-binder to (con args)
         ; let inst_tys' = tyConAppArgs (idType case_bndr')
               con_args  = map Type inst_tys' ++ varsToCoreExprs vs'
                 -- Bind the case-binder to (con args)
         ; let inst_tys' = tyConAppArgs (idType case_bndr')
               con_args  = map Type inst_tys' ++ varsToCoreExprs vs'

-              env''     = addBinderUnfolding env' case_bndr'
-                                             (mkConApp con con_args)
+              unf       = mkSimpleUnfolding (mkConApp con con_args)
+              env''     = addBinderUnfolding env' scrut case_bndr' unf

 
         ; rhs' <- simplExprC env'' rhs cont'
         ; return (DataAlt con, vs', rhs') }
 
         ; rhs' <- simplExprC env'' rhs cont'
         ; return (DataAlt con, vs', rhs') }

@@ -1843,7 +1839,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
             | isMarkedStrict str = evald_v  : go vs' strs
             | otherwise          = zapped_v : go vs' strs
             where
             | isMarkedStrict str = evald_v  : go vs' strs
             | otherwise          = zapped_v : go vs' strs
             where

-              zapped_v = zap_occ_info v
+              zapped_v = zapBndrOccInfo keep_occ_info v

               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
 
               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
 

@@ -1855,25 +1851,49 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
         --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
         --   ==>  case e of t { (a,b) -> ...(a)... }
         -- Look, Ma, a is alive now.
         --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
         --   ==>  case e of t { (a,b) -> ...(a)... }
         -- Look, Ma, a is alive now.

-    zap_occ_info = zapCasePatIdOcc case_bndr'
-
-addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
-addBinderUnfolding env bndr rhs
-  = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs)
+    keep_occ_info = isDeadBinder case_bndr' && isNothing scrut

 
 

-addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
-addBinderOtherCon env bndr cons
-  = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
+addBinderUnfolding :: SimplEnv -> Maybe OutId -> Id -> Unfolding -> SimplEnv
+addBinderUnfolding env scrut bndr unf
+  = case scrut of
+       Just v -> modifyInScope env1 (v `setIdUnfolding` unf)
+       _      -> env1
+  where
+    env1 = modifyInScope env bndr_w_unf
+    bndr_w_unf = bndr `setIdUnfolding` unf

 
 

-zapCasePatIdOcc :: Id -> Id -> Id
+zapBndrOccInfo :: Bool -> Id -> Id

 -- Consider  case e of b { (a,b) -> ... }
 -- Then if we bind b to (a,b) in "...", and b is not dead,
 -- then we must zap the deadness info on a,b
 -- Consider  case e of b { (a,b) -> ... }
 -- Then if we bind b to (a,b) in "...", and b is not dead,
 -- then we must zap the deadness info on a,b

-zapCasePatIdOcc case_bndr
-  | isDeadBinder case_bndr = \ pat_id -> pat_id
-  | otherwise             = \ pat_id -> zapIdOccInfo pat_id
+zapBndrOccInfo keep_occ_info pat_id
+  | keep_occ_info = pat_id
+  | otherwise     = zapIdOccInfo pat_id

 \end{code}
 
 \end{code}
 

+Note [Add unfolding for scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general it's unlikely that a variable scrutinee will appear 
+in the case alternatives   case x of { ...x unlikely to appear... }
+because the binder-swap in OccAnal has got rid of all such occcurrences
+See Note [Binder swap] in OccAnal.
+
+BUT it is still VERY IMPORTANT to add a suitable unfolding for a
+variable scrutinee, in simplAlt.  Here's why
+   case x of y
+     (a,b) -> case b of c
+                I# v -> ...(f y)...
+There is no occurrence of 'b' in the (...(f y)...).  But y gets
+the unfolding (a,b), and *that* mentions b.  If f has a RULE
+    RULE f (p, I# q) = ...
+we want that rule to match, so we must extend the in-scope env with a
+suitable unfolding for 'y'.  It's *essential* for rule matching; but
+it's also good for case-elimintation -- suppose that 'f' was inlined
+and did multi-level case analysis, then we'd solve it in one
+simplifier sweep instead of two.
+
+Exactly the same issue arises in SpecConstr; 
+see Note [Add scrutinee to ValueEnv too] in SpecConstr

 
 %************************************************************************
 %*                                                                      *
 
 %************************************************************************
 %*                                                                      *

@@ -1907,7 +1927,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
         ; env'' <- bind_case_bndr env'
         ; simplExprF env'' rhs cont }
   where
         ; env'' <- bind_case_bndr env'
         ; simplExprF env'' rhs cont }
   where

-    zap_occ = zapCasePatIdOcc bndr    -- bndr is an InId
+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId

 
                   -- Ugh!
     bind_args env' [] _  = return env'
 
                   -- Ugh!
     bind_args env' [] _  = return env'

@@ -1973,16 +1993,44 @@ missingAlt env case_bndr alts cont
 \begin{code}
 prepareCaseCont :: SimplEnv
                 -> [InAlt] -> SimplCont
 \begin{code}
 prepareCaseCont :: SimplEnv
                 -> [InAlt] -> SimplCont

-                -> SimplM (SimplEnv, SimplCont,SimplCont)
-                        -- Return a duplicatable continuation, a non-duplicable part
-                        -- plus some extra bindings (that scope over the entire
-                        -- continunation)
-
-        -- No need to make it duplicatable if there's only one alternative
-prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
-prepareCaseCont env _   cont = mkDupableCont env cont
+                -> SimplM (SimplEnv, SimplCont, SimplCont)
+-- We are considering
+--     K[case _ of { p1 -> r1; ...; pn -> rn }] 
+-- where K is some enclosing continuation for the case
+-- Goal: split K into two pieces Kdup,Knodup so that
+--      a) Kdup can be duplicated
+--      b) Knodup[Kdup[e]] = K[e]
+-- The idea is that we'll transform thus:
+--          Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
+--
+-- We also return some extra bindings in SimplEnv (that scope over 
+-- the entire continuation)
+
+prepareCaseCont env alts cont 
+  | many_alts alts = mkDupableCont env cont 
+  | otherwise      = return (env, cont, mkBoringStop)
+  where
+    many_alts :: [InAlt] -> Bool  -- True iff strictly > 1 non-bottom alternative
+    many_alts []  = False        -- See Note [Bottom alternatives]
+    many_alts [_] = False
+    many_alts (alt:alts) 
+      | is_bot_alt alt = many_alts alts   
+      | otherwise      = not (all is_bot_alt alts)
+  
+    is_bot_alt (_,_,rhs) = exprIsBottom rhs

 \end{code}
 
 \end{code}
 

+Note [Bottom alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+     case (case x of { A -> error .. ; B -> e; C -> error ..) 
+       of alts
+then we can just duplicate those alts because the A and C cases
+will disappear immediately.  This is more direct than creating
+join points and inlining them away; and in some cases we would
+not even create the join points (see Note [Single-alternative case])
+and we would keep the case-of-case which is silly.  See Trac #4930.
+

 \begin{code}
 mkDupableCont :: SimplEnv -> SimplCont
               -> SimplM (SimplEnv, SimplCont, SimplCont)
 \begin{code}
 mkDupableCont :: SimplEnv -> SimplCont
               -> SimplM (SimplEnv, SimplCont, SimplCont)

@@ -2033,14 +2081,17 @@ mkDupableCont env (Select _ case_bndr alts se cont)
         --              let ji = \xij -> ei
         --              in case [...hole...] of { pi -> ji xij }
     do  { tick (CaseOfCase case_bndr)
         --              let ji = \xij -> ei
         --              in case [...hole...] of { pi -> ji xij }
     do  { tick (CaseOfCase case_bndr)

-        ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
-                -- NB: call mkDupableCont here, *not* prepareCaseCont
-                -- We must make a duplicable continuation, whereas prepareCaseCont
-                -- doesn't when there is a single case branch
+        ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
+                -- NB: We call prepareCaseCont here.  If there is only one
+               -- alternative, then dup_cont may be big, but that's ok
+               -- becuase we push it into the single alternative, and then
+               -- use mkDupableAlt to turn that simplified alternative into
+               -- a join point if it's too big to duplicate.
+               -- And this is important: see Note [Fusing case continuations]

 
         ; let alt_env = se `setInScope` env'
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
 
         ; let alt_env = se `setInScope` env'
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr

-        ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts

         -- Safe to say that there are no handled-cons for the DEFAULT case
                 -- NB: simplBinder does not zap deadness occ-info, so
                 -- a dead case_bndr' will still advertise its deadness
         -- Safe to say that there are no handled-cons for the DEFAULT case
                 -- NB: simplBinder does not zap deadness occ-info, so
                 -- a dead case_bndr' will still advertise its deadness

@@ -2128,6 +2179,37 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
                 -- See Note [Duplicated env]
 \end{code}
 
                 -- See Note [Duplicated env]
 \end{code}
 

+Note [Fusing case continuations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important to fuse two successive case continuations when the
+first has one alternative.  That's why we call prepareCaseCont here.
+Consider this, which arises from thunk splitting (see Note [Thunk
+splitting] in WorkWrap):
+
+      let
+       x* = case (case v of {pn -> rn}) of 
+               I# a -> I# a
+      in body
+
+The simplifier will find
+    (Var v) with continuation  
+            Select (pn -> rn) (
+            Select [I# a -> I# a] (
+            StrictBind body Stop
+
+So we'll call mkDupableCont on 
+   Select [I# a -> I# a] (StrictBind body Stop)
+There is just one alternative in the first Select, so we want to
+simplify the rhs (I# a) with continuation (StricgtBind body Stop)
+Supposing that body is big, we end up with
+         let $j a = <let x = I# a in body> 
+          in case v of { pn -> case rn of 
+                                 I# a -> $j a }
+This is just what we want because the rn produces a box that
+the case rn cancels with.  
+
+See Trac #4957 a fuller example.
+

 Note [Case binders and join points]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this 
 Note [Case binders and join points]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this 

@@ -2309,9 +2391,6 @@ Note [Duplicating StrictBind]
 Unlike StrictArg, there doesn't seem anything to gain from
 duplicating a StrictBind continuation, so we don't.
 
 Unlike StrictArg, there doesn't seem anything to gain from
 duplicating a StrictBind continuation, so we don't.
 

-The desire not to duplicate is the entire reason that
-mkDupableCont returns a pair of continuations.
-

 
 Note [Single-alternative cases]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Single-alternative cases]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -2381,8 +2460,7 @@ Note [Single-alternative-unlifted]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Here's another single-alternative where we really want to do case-of-case:
 
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Here's another single-alternative where we really want to do case-of-case:
 

-data Mk1 = Mk1 Int#
-data Mk1 = Mk2 Int#
+data Mk1 = Mk1 Int# | Mk2 Int#

 
 M1.f =
     \r [x_s74 y_s6X]
 
 M1.f =
     \r [x_s74 y_s6X]

@@ -2407,7 +2485,15 @@ M1.f =
 
 So the outer case is doing *nothing at all*, other than serving as a
 join-point.  In this case we really want to do case-of-case and decide
 
 So the outer case is doing *nothing at all*, other than serving as a
 join-point.  In this case we really want to do case-of-case and decide

-whether to use a real join point or just duplicate the continuation.
+whether to use a real join point or just duplicate the continuation:
+
+    let $j s7c = case x of
+                   Mk1 ipv77 -> (==) s7c ipv77
+                   Mk1 ipv79 -> (==) s7c ipv79
+    in
+    case y of 
+      Mk1 ipv70 -> $j ipv70
+      Mk2 ipv72 -> $j ipv72

 
 Hence: check whether the case binder's type is unlifted, because then
 the outer case is *not* a seq.
 
 Hence: check whether the case binder's type is unlifted, because then
 the outer case is *not* a seq.