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