[commit: ghc] supercompiler: Make children summary info shorter (251b7ae)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/251b7ae4b02cdaada632009a3bcb7d1de229f714

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

commit 251b7ae4b02cdaada632009a3bcb7d1de229f714
Author: Max Bolingbroke <[email protected]>
Date:   Tue Mar 20 14:06:54 2012 +0000

    Make children summary info shorter

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

 .../supercompile/Supercompile/Drive/Process.hs     |    8 +++++++-
 compiler/supercompile/Supercompile/Utilities.hs    |    9 +++++++++
 2 files changed, 16 insertions(+), 1 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index 8fb9b70..a6dc8c2 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -105,11 +105,15 @@ emptyParentChildren = M.empty
 addChild :: Maybe Var -> Var -> State -> Bool -> ParentChildren -> ParentChildren
 addChild mb_parent child child_state gen = M.alter (\mb_children -> Just ((child, (child_state, gen)) : (mb_children `orElse` []))) mb_parent
 
+-- Shows nodes in the graph arranged by number of descendants:
 childrenSummary :: ParentChildren -> String
-childrenSummary parent_children = unlines [maybe "<root>" varString mb_parent ++ ": " ++ intercalate " " (map show child_counts)  | (mb_parent, child_counts :: [Int]) <- ordered_counts]
+childrenSummary parent_children = unlines [intercalate " " (map (maybe "<root>" varString) mb_parents) ++ ": " ++ intercalate " " (map show child_counts)
+                                          | (child_counts :: [Int], mb_parents) <- grouped_counts]
   where descendant_counts = flip M.map parent_children $ \children -> map ((+1) . sum . flip (M.findWithDefault [] . Just) descendant_counts . fst) children
         ordered_counts = sortBy (comparing (Down . sum . snd)) (M.toList descendant_counts)
+        grouped_counts = runs snd fst ordered_counts
 
+-- Shows the number of children at each depth:
 depthHistogram :: ParentChildren -> SDoc
 depthHistogram parent_children = maybe empty (\overall_depth_summary -> vcat [ppr depth <> char ',' <+> ppr count | (depth, count) <- IM.toList overall_depth_summary]) (M.lookup Nothing summary_map)
   where depth_map :: M.Map (Maybe Var) Int
@@ -122,6 +126,7 @@ depthHistogram parent_children = maybe empty (\overall_depth_summary -> vcat [pp
                                                                                   Just depth = M.lookup mb_fun depth_map
                                                                               in IM.unionsWith (+) (IM.singleton depth 1:summaries)
 
+-- Shows the deepest path encountered and the big values on the route there:
 -- NB: there may be many deepest paths
 deepestPath :: [(Var, FVedTerm)] -> ParentChildren -> SDoc
 deepestPath fulfils parent_children = maybe empty (\(_, deepest_from_root) -> show_meaning_chains deepest_from_root $$ summarise_leaves (map last deepest_from_root)) mb_deepest_from_root
@@ -200,6 +205,7 @@ showValueGroup (root, group) = go emptyVarSet noPrec root
 
 type TagAnnotations = IM.IntMap [String]
 
+-- Shows a guesstimate about what bits of original syntax residualised syntax was based on:
 tagSummary :: TagAnnotations -> Int -> Int -> ResidTags -> String
 tagSummary anns precision n resid_tags = unlines $ take n [intercalate "." ann ++ "\t" ++ show occs ++ "(" ++ show init_occs ++ ")" | (ann, (init_occs, occs)) <- sortBy (comparing (Down . snd . snd)) (M.toList ann_occs)]
   where ann_occs = M.unionsWith (\(x1, y1) (x2, y2) -> (x1 + x2, y1 + y2)) [M.singleton (take precision ann) (1 :: Int, occs) | (tag, occs) <- IM.toList resid_tags, let Just ann = IM.lookup tag anns]
diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs
index cbefcf0..ddd3a7f 100644
--- a/compiler/supercompile/Supercompile/Utilities.hs
+++ b/compiler/supercompile/Supercompile/Utilities.hs
@@ -486,6 +486,15 @@ sumMap f = Foldable.foldr (\x n -> f x + n) 0
 sumMapMonoid :: (Foldable f, Monoid b) => (a -> b) -> f a -> b
 sumMapMonoid f = Foldable.foldr (\x n -> f x `mappend` n) mempty
 
+runs :: Eq b => (a -> b) -> (a -> c) -> [a] -> [(b, [c])]
+runs _ _ []     = []
+runs f g (x:xs) = go (f x) [g x] xs
+  where go b pending []     = [(b, reverse pending)]
+        go b pending (x:xs)
+          | b == b'   = go b (g x:pending) xs
+          | otherwise = (b, reverse pending) : go b' [g x] xs
+          where b' = f x
+
 
 -- | Orders elements of a map into dependency order insofar as that is possible.
 --