Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/6c499e632324ace0fb59734dfb7bb1df1eff5276 >--------------------------------------------------------------- commit 6c499e632324ace0fb59734dfb7bb1df1eff5276 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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. _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
