[commit: ghc] : Show all deepest paths, not just one of them (d6689d9)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/d6689d9f78d4329aee17470234ac8c0cccef631e

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

commit d6689d9f78d4329aee17470234ac8c0cccef631e
Author: Max Bolingbroke <[email protected]>
Date:   Tue Jan 17 15:06:36 2012 +0000

    Show all deepest paths, not just one of them

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

 .../supercompile/Supercompile/Drive/Process.hs     |   13 ++++++++++---
 compiler/supercompile/Supercompile/Utilities.hs    |   11 +++++++++++
 2 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index c53acf8..374c3ca 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -110,9 +110,9 @@ childrenSummary parent_children = unlines [maybe "<root>" varString mb_parent ++
 
 -- NB: there may be many deepest paths, but this function only returns one of them
 deepestPath :: [(Var, FVedTerm)] -> ParentChildren -> SDoc
-deepestPath fulfils parent_children = maybe empty (\(_, states) -> show_meaning_chain M.empty states $$ show_fulfils_chain (map fst states)) (M.lookup Nothing deepest)
-  where deepest :: M.Map (Maybe Var) (Int, [(Var, (State, Bool))])
-        deepest = flip M.map parent_children $ \children -> maximumBy (comparing fst) [(depth + 1, (fun, state):states) | (fun, state) <- children, let (depth, states) = M.findWithDefault (0, []) (Just fun) deepest]
+deepestPath fulfils parent_children = maybe empty (show_meaning_chains . snd) (M.lookup Nothing deepest)
+  where deepest :: M.Map (Maybe Var) (Int, [[(Var, (State, Bool))]])
+        deepest = flip M.map parent_children $ \children -> maximumByFst [(depth + 1, (fun, state):states) | (fun, state) <- children, let (depth, statess) = M.findWithDefault (0, [[]]) (Just fun) deepest, states <- statess]
 
         fulfils_map :: M.Map Var FVedTerm
         fulfils_map = M.fromList fulfils
@@ -120,6 +120,8 @@ deepestPath fulfils parent_children = maybe empty (\(_, states) -> show_meaning_
         show_fulfils_chain :: [Var] -> SDoc
         show_fulfils_chain = flip (pPrintPrecLetRec noPrec) (PrettyDoc (text "...")) . mapMaybe (\x -> fmap ((,) x) $ M.lookup x fulfils_map)
 
+        show_meaning_chains = vcat . zipWith (\i states -> hang (text "Deepest Chain" <+> ppr (i :: Int)) 2 (show_meaning_chain M.empty states $$ show_fulfils_chain (map fst states))) [1..]
+
         show_meaning_chain :: M.Map Var Bool -> [(Var, (State, Bool))] -> SDoc
         show_meaning_chain _         [] = empty
         show_meaning_chain known_bvs ((fun, (state@(_, Heap h _, _, _), gen)):states)
@@ -128,6 +130,11 @@ deepestPath fulfils parent_children = maybe empty (\(_, states) -> show_meaning_
           where known_bvs'  = M.map (maybe False (termIsValue . snd) . heapBindingTerm) h
                 unchanged_bvs = M.keysSet (M.filter id (M.intersectionWith (==) known_bvs known_bvs'))
 
+        maximumByFst :: Ord a => [(a, b)] -> (a, [b])
+        maximumByFst xys = case maximumsComparing fst xys of
+          ((x, y):xys) -> (x, y:map snd xys)
+          []           -> error "maximumByFst"
+
 
 type TagAnnotations = IM.IntMap [String]
 
diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs
index dfa1022..a5ff8c0 100644
--- a/compiler/supercompile/Supercompile/Utilities.hs
+++ b/compiler/supercompile/Supercompile/Utilities.hs
@@ -451,6 +451,17 @@ takeWhileJust f = go
         Nothing -> ([], x:xs)
         Just y  -> first (y:) $ go xs
 
+maximumsComparing :: Ord b => (a -> b) -> [a] -> [a]
+maximumsComparing _ []     = error "maximumsComparing: empty input"
+maximumsComparing f (x:xs) = go (f x) [x] xs
+  where
+    go _       maxs []     = reverse maxs
+    go the_max maxs (x:xs) = case this `compare` the_max of
+        LT -> go the_max maxs     xs
+        EQ -> go the_max (x:maxs) xs
+        GT -> go this    [x]      xs
+      where this = f x
+
 accumLN :: (acc -> (acc, a)) -> acc -> Int -> (acc, [a])
 accumLN f = go
   where