[commit: ghc] : Collect tags from AltCons as well because of positive information propagation (6c499e6)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/6c499e632324ace0fb59734dfb7bb1df1eff5276

>---------------------------------------------------------------

commit 6c499e632324ace0fb59734dfb7bb1df1eff5276
Author: Max Bolingbroke <[email protected]>
Date:   Thu Mar 22 12:34:21 2012 +0000

    Collect tags from AltCons as well because of positive information propagation

>---------------------------------------------------------------

 .../supercompile/Supercompile/Drive/Process.hs     |    8 +++++++-
 1 files changed, 7 insertions(+), 1 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index 177b6f2..18f4b05 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -27,6 +27,7 @@ import Supercompile.Core.FreeVars
 import Supercompile.Core.Renaming
 --import Supercompile.Core.Size
 import Supercompile.Core.Syntax
+import Supercompile.Core.Tag
 
 import Supercompile.Drive.Split (ResidTags)
 
@@ -243,11 +244,16 @@ tagAnnotations (_, Heap h _, k, qa) = IM.unions [go_term (extAnn x []) e | (x, h
       CoApp e _ -> (Nothing, go_term ann e)
       App e _   -> (Nothing, go_term ann e)
       PrimOp _ _ es   -> (Nothing, IM.unions (map (go_term ann) es))
-      Case e x _ alts -> (Nothing, go_term (extAnn x ann) e `IM.union` IM.unions [go_term ann e | (_, e) <- alts])
+      Case e x _ alts -> (Nothing, go_term (extAnn x ann) e `IM.union` IM.unions [go_alt_con alt_con $ go_term ann e | (alt_con, e) <- alts])
       Let x e1 e2     -> (Nothing, go_term (extAnn x ann) e1 `IM.union` go_term ann e2)
       LetRec xes e    -> (Nothing, IM.unions [go_term (extAnn x ann) e | (x, e) <- xes] `IM.union` go_term ann e)
       Cast e _        -> (Nothing, go_term ann e)
     
+    go_alt_con alt_con = case alt_con of
+      DataAlt dc _ _ _ -> insert' [show dc] (dataConTag dc)
+      LiteralAlt l     -> insert' [show l]  (literalTag l)
+      DefaultAlt       -> id
+    
     -- NB: this is carefully set up so that we map all those tags that are likely to
     -- be literalTags/dataConTags that occur multiple times in *all* tagged terms to
     -- the same annotation.