[commit: ghc] supercompiler: Improve deepest-path printing (ed02c26)

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

On branch  : supercompiler

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

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

commit ed02c26b3940b56a1de57bcd645d04300015ff79
Author: Max Bolingbroke <[email protected]>
Date:   Mon Jan 16 16:15:59 2012 +0000

    Improve deepest-path printing

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

 .../supercompile/Supercompile/Drive/Process.hs     |   19 +++++++++++++------
 .../supercompile/Supercompile/Drive/Process3.hs    |    5 +++--
 2 files changed, 16 insertions(+), 8 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index 78d3e39..b72875f 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -108,16 +108,23 @@ childrenSummary parent_children = unlines [maybe "<root>" varString mb_parent ++
   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)
 
-deepestPath :: ParentChildren -> SDoc
-deepestPath parent_children = maybe empty (show_chain M.empty . snd) (M.lookup Nothing deepest)
+-- 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)])
         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]
 
-        show_chain :: M.Map Var Bool -> [(Var, State)] -> SDoc
-        show_chain _         [] = empty
-        show_chain known_bvs ((fun, state@(_, Heap h _, _, _)):states)
+        fulfils_map :: M.Map Var FVedTerm
+        fulfils_map = M.fromList fulfils
+
+        show_fulfils_chain :: [Var] -> SDoc
+        show_fulfils_chain = flip (pPrintPrecLetRec noPrec) (PrettyDoc (text "...")) . mapMaybe (\x -> fmap ((,) x) $ M.lookup x fulfils_map)
+
+        show_meaning_chain :: M.Map Var Bool -> [(Var, State)] -> SDoc
+        show_meaning_chain _         [] = empty
+        show_meaning_chain known_bvs ((fun, state@(_, Heap h _, _, _)):states)
           = hang (ppr fun) 2 (pPrintFullState (quietStatePrettiness { excludeBindings = unchanged_bvs }) state) $$
-            show_chain known_bvs' states
+            show_meaning_chain known_bvs' states
           where known_bvs'  = M.map (maybe False (termIsValue . snd) . heapBindingTerm) h
                 unchanged_bvs = M.keysSet (M.filter id (M.intersectionWith (==) known_bvs known_bvs'))
 
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index f712df2..b96eb30 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -125,7 +125,7 @@ instance MonadStatics ScpM where
     monitorFVs = liftM ((,) emptyVarSet)
 
 runScpM :: TagAnnotations -> ScpM FVedTerm -> FVedTerm
-runScpM tag_anns me = fvedTermSize e' `seq` trace (showSDoc (deepestPath (scpParentChildren s'))) e'
+runScpM tag_anns me = fvedTermSize e' `seq` trace ("Deepest path:\n" ++ showSDoc (deepestPath fulfils (scpParentChildren s'))) e'
   where h_names = listToStream $ zipWith (\i uniq -> mkSystemVarName uniq (mkFastString ('h' : show (i :: Int))))
                                          [1..] (uniqsFromSupply hFunctionsUniqSupply)
         ms = MS { promises = [], hNames = h_names }
@@ -133,7 +133,8 @@ runScpM tag_anns me = fvedTermSize e' `seq` trace (showSDoc (deepestPath (scpPar
         fs = FS { fulfilments = [] }
         parent = generatedKey hist
         (e, s') = unI $ unReaderT (unStateT (unScpM me) (ScpState ms hist fs emptyResidTags emptyParentChildren)) (ScpEnv 0 parent [] nothingSpeculated tag_anns)
-        e' = letRec (fulfilments (scpFulfilmentState s')) e
+        fulfils = fulfilments (scpFulfilmentState s')
+        e' = letRec fulfils e
 
 
 scpDepth :: ScpEnv -> Int