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