[commit: ghc] : Show deepest path in SC at end of supercompilation (dac1dfb)

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

On branch  : 

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

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

commit dac1dfbd65020ea85ffecdd0ff42d7f28327eae1
Author: Max Bolingbroke <[email protected]>
Date:   Fri Jan 6 12:35:46 2012 +0000

    Show deepest path in SC at end of supercompilation

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

 .../supercompile/Supercompile/Drive/Process.hs     |   23 +++++++++++++++----
 .../supercompile/Supercompile/Drive/Process3.hs    |    6 +++-
 .../Supercompile/Evaluator/Residualise.hs          |   14 +++++++-----
 3 files changed, 30 insertions(+), 13 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index 97e5d4e..78d3e39 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -4,7 +4,7 @@ module Supercompile.Drive.Process (
 
     rEDUCE_WQO, wQO, mK_GENERALISER,
 
-    ParentChildren, emptyParentChildren, addChild, childrenSummary,
+    ParentChildren, emptyParentChildren, addChild, childrenSummary, deepestPath,
 
     TagAnnotations, tagAnnotations, tagSummary,
 
@@ -95,19 +95,32 @@ mK_GENERALISER :: State -> State -> Generaliser
 --          | otherwise  = wqo1
 
 
-type ParentChildren = M.Map (Maybe Var) [Var]
+type ParentChildren = M.Map (Maybe Var) [(Var, State)]
 
 emptyParentChildren :: ParentChildren
 emptyParentChildren = M.empty
 
-addChild :: Maybe Var -> Var -> ParentChildren -> ParentChildren
-addChild mb_parent child = M.alter (\mb_children -> Just (child : (mb_children `orElse` []))) mb_parent
+addChild :: Maybe Var -> Var -> State -> ParentChildren -> ParentChildren
+addChild mb_parent child child_state = M.alter (\mb_children -> Just ((child, child_state) : (mb_children `orElse` []))) mb_parent
 
 childrenSummary :: ParentChildren -> String
 childrenSummary parent_children = unlines [maybe "<root>" varString mb_parent ++ ": " ++ intercalate " " (map show child_counts)  | (mb_parent, child_counts :: [Int]) <- ordered_counts]
-  where descendant_counts = flip M.map parent_children $ \children -> map ((+1) . sum . flip (M.findWithDefault [] . Just) descendant_counts) children
+  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)
+  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)
+          = hang (ppr fun) 2 (pPrintFullState (quietStatePrettiness { excludeBindings = unchanged_bvs }) state) $$
+            show_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'))
+
 
 type TagAnnotations = IM.IntMap [String]
 
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 197ad41..f712df2 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -6,6 +6,7 @@ import Supercompile.Drive.Split
 import Supercompile.Drive.Process
 
 import Supercompile.Core.FreeVars
+import Supercompile.Core.Size (fvedTermSize)
 import Supercompile.Core.Syntax
 import Supercompile.Core.Tag
 
@@ -124,7 +125,7 @@ instance MonadStatics ScpM where
     monitorFVs = liftM ((,) emptyVarSet)
 
 runScpM :: TagAnnotations -> ScpM FVedTerm -> FVedTerm
-runScpM tag_anns me = letRec (fulfilments (scpFulfilmentState s')) e
+runScpM tag_anns me = fvedTermSize e' `seq` trace (showSDoc (deepestPath (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 }
@@ -132,6 +133,7 @@ runScpM tag_anns me = letRec (fulfilments (scpFulfilmentState s')) e
         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
 
 
 scpDepth :: ScpEnv -> Int
@@ -150,7 +152,7 @@ addParentM p opt state = ScpM $ StateT $ \s -> ReaderT $ add_parent s
       | otherwise
       = trace ("depth: " ++ show (scpDepth env) ++ ' ' : showSDoc (parens (hsep (map ppr (scpParents env))))) $
         unReaderT (unStateT (unScpM (opt state))
-                            (s { scpParentChildren = addChild (safeHead (scpParents env)) (fun p) (scpParentChildren s) }))
+                            (s { scpParentChildren = addChild (safeHead (scpParents env)) (fun p) (meaning p) (scpParentChildren s) }))
                   (env { scpParents = fun p : scpParents env })
 
 fulfillM :: Promise -> (Deeds, FVedTerm) -> ScpM (Deeds, FVedTerm)
diff --git a/compiler/supercompile/Supercompile/Evaluator/Residualise.hs b/compiler/supercompile/Supercompile/Evaluator/Residualise.hs
index 19934c8..074103d 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Residualise.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Residualise.hs
@@ -3,7 +3,7 @@ module Supercompile.Evaluator.Residualise (
     
     pPrintHeap,
 
-    StatePrettiness, fullStatePrettiness, quietStatePrettiness,
+    StatePrettiness(..), fullStatePrettiness, quietStatePrettiness,
     pPrintFullState, pPrintFullUnnormalisedState
   ) where
 
@@ -20,6 +20,7 @@ import Var (isLocalId)
 
 import Data.Either
 import qualified Data.Map as M
+import qualified Data.Set as S
 import Data.Ord
 
 
@@ -69,18 +70,19 @@ pPrintHeap :: Heap -> SDoc
 pPrintHeap (Heap h ids) = pPrint $ map (first (PrettyDoc . pPrintBndr LetBind)) $ floats_static_h ++ [(x, asPrettyFunction1 e) | (x, e) <- floats_nonstatic_h]
   where (floats_static_h, floats_nonstatic_h) = residualisePureHeap ids h
 
-data StatePrettiness = SP { includeLams :: Bool, includeStatics :: Bool }
+data StatePrettiness = SP { includeLams :: Bool, includeStatics :: Bool, excludeBindings :: S.Set Var }
 
 fullStatePrettiness, quietStatePrettiness :: StatePrettiness
-fullStatePrettiness = SP True True
-quietStatePrettiness = SP False False
+fullStatePrettiness = SP True True S.empty
+quietStatePrettiness = SP False False S.empty
 
 pPrintFullState :: StatePrettiness -> State -> SDoc
 pPrintFullState sp = pPrintFullUnnormalisedState sp . denormalise
 
 pPrintFullUnnormalisedState :: StatePrettiness -> UnnormalisedState -> SDoc
-pPrintFullUnnormalisedState sp state = text "Deeds:" <+> pPrint deeds $$ (if includeStatics sp then pPrint (map (first (PrettyDoc . pPrintBndr LetBind)) floats_static) else empty) $$ body
-  where (deeds, floats_static, floats_nonstatic, e) = residualiseUnnormalisedState state
+pPrintFullUnnormalisedState sp state = text "Deeds:" <+> pPrint deeds $$ (if includeStatics sp then pPrint (map (first (PrettyDoc . pPrintBndr LetBind)) floats_static) else empty) $$ body $$ (if null floats_nonstatic_excluded then empty else ppr (S.fromList (map fst floats_nonstatic_excluded)))
+  where (deeds, floats_static, floats_nonstatic_unfiltered, e) = residualiseUnnormalisedState state
+        (floats_nonstatic_excluded, floats_nonstatic) = partition (flip S.member (excludeBindings sp) . fst) floats_nonstatic_unfiltered
         floats_nonstatic_pretty
           | includeLams sp = map (second asPrettyFunction) floats_nonstatic
           | otherwise      = map snd $ sortBy (comparing (Down . fst)) $