Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/4549ab0892ccb63519072de489b99e66691d8039 >--------------------------------------------------------------- commit 4549ab0892ccb63519072de489b99e66691d8039 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Jan 4 14:22:49 2012 +0000 Debugging aid: summary of node descendant count >--------------------------------------------------------------- .../supercompile/Supercompile/Drive/Process.hs | 16 +++++++++ .../supercompile/Supercompile/Drive/Process3.hs | 36 ++++++++++++++------ 2 files changed, 41 insertions(+), 11 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index 64658a9..97e5d4e 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -4,6 +4,8 @@ module Supercompile.Drive.Process ( rEDUCE_WQO, wQO, mK_GENERALISER, + ParentChildren, emptyParentChildren, addChild, childrenSummary, + TagAnnotations, tagAnnotations, tagSummary, prepareTerm, @@ -93,6 +95,20 @@ mK_GENERALISER :: State -> State -> Generaliser -- | otherwise = wqo1 +type ParentChildren = M.Map (Maybe Var) [Var] + +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 + +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 + ordered_counts = sortBy (comparing (Down . sum . snd)) (M.toList descendant_counts) + + type TagAnnotations = IM.IntMap [String] tagSummary :: TagAnnotations -> Int -> Int -> ResidTags -> String diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index 7758e77..197ad41 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -101,7 +101,9 @@ data ScpState = ScpState { scpMemoState :: MemoState, scpProcessHistory :: ProcessHistory, scpFulfilmentState :: FulfilmentState, - scpResidTags :: ResidTags + -- Debugging aids below this line: + scpResidTags :: ResidTags, + scpParentChildren :: ParentChildren } data ScpEnv = ScpEnv { @@ -109,6 +111,7 @@ data ScpEnv = ScpEnv { scpNodeKey :: NodeKey, scpParents :: [Var], scpAlreadySpeculated :: AlreadySpeculated, + -- Debugging aids below this line: scpTagAnnotations :: TagAnnotations } @@ -121,23 +124,34 @@ instance MonadStatics ScpM where monitorFVs = liftM ((,) emptyVarSet) runScpM :: TagAnnotations -> ScpM FVedTerm -> FVedTerm -runScpM tag_anns me = letRec (fulfilments fs') e +runScpM tag_anns me = letRec (fulfilments (scpFulfilmentState 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 } hist = pROCESS_HISTORY fs = FS { fulfilments = [] } parent = generatedKey hist - (e, ScpState _ms' _hist' fs' _resid_tags) = unI $ unReaderT (unStateT (unScpM me) (ScpState ms hist fs emptyResidTags)) (ScpEnv 0 parent [] nothingSpeculated tag_anns) + (e, s') = unI $ unReaderT (unStateT (unScpM me) (ScpState ms hist fs emptyResidTags emptyParentChildren)) (ScpEnv 0 parent [] nothingSpeculated tag_anns) +scpDepth :: ScpEnv -> Int scpDepth = length . scpParents traceRenderM :: Outputable a => String -> a -> ScpM () traceRenderM msg x = ScpM $ StateT $ \s -> ReaderT $ \env -> pprTraceSC (replicate (scpDepth env) ' ' ++ msg) (pPrint x) $ pure ((), s) -- TODO: include depth, refine to ScpM monad only -addParentM :: Promise -> ScpM a -> ScpM a -addParentM p mx = ScpM $ StateT $ \s -> ReaderT $ \env -> trace ("depth: " ++ show (scpDepth env) ++ ' ' : showSDoc (parens (hsep (map ppr (scpParents env))))) $ unReaderT (unStateT (unScpM mx) s) (env { scpParents = fun p : scpParents env }) +addParentM :: Promise -> (State -> ScpM (Deeds, FVedTerm)) -> State -> ScpM (Deeds, FVedTerm) +addParentM p opt state = ScpM $ StateT $ \s -> ReaderT $ add_parent s + where + add_parent s env + | maybe False (scpDepth env >=) dEPTH_LIIMT + , let (deeds, _, e) = residualiseState state + = return ((deeds, e), 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) })) + (env { scpParents = fun p : scpParents env }) fulfillM :: Promise -> (Deeds, FVedTerm) -> ScpM (Deeds, FVedTerm) fulfillM p res = ScpM $ StateT $ \s -> case fulfill p res (scpFulfilmentState s) of (res', fs') -> return (res', s { scpFulfilmentState = fs' }) @@ -180,7 +194,7 @@ sc' mb_h state = case mb_h of insert_tags mx = do (resid_tags, deeds, e') <- mx ScpM $ StateT $ \s -> ReaderT $ \env -> let resid_tags' = scpResidTags s `plusResidTags` resid_tags - in trace (tagSummary (scpTagAnnotations env) 1 30 resid_tags') $ + in trace (tagSummary (scpTagAnnotations env) 1 30 resid_tags' ++ "\n" ++ childrenSummary (scpParentChildren s)) $ return ((), s { scpResidTags = resid_tags' }) return (deeds, e') @@ -215,7 +229,7 @@ memo :: (Maybe String -> State -> ScpM (Deeds, FVedTerm)) -> State -> ScpM (Deeds, FVedTerm) memo opt state | skip_tieback = opt Nothing state - | otherwise = join $ ScpM $ StateT $ \(ScpState ms hist fs resid_tags) -> + | otherwise = join $ ScpM $ StateT $ \(ScpState ms hist fs resid_tags parent_children) -> -- NB: If tb contains a dead PureHeap binding (hopefully impossible) then it may have a free variable that -- I can't rename, so "rename" will cause an error. Not observed in practice yet. @@ -247,12 +261,12 @@ memo opt state | p <- promises ms , Just rn_lr <- [-- (\res -> if isNothing res then pprTraceSC "no match:" (ppr (fun p)) res else pprTraceSC "match!" (ppr (fun p)) res) $ match (meaning p) reduced_state] - ] of (p, res):_ -> pure (do { traceRenderM "=sc" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), res) - ; return res }, ScpState ms hist fs resid_tags) + ] of (p, res):_ -> pure (do { traceRenderM "=sc" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), PrettyDoc (pPrintFullState quietStatePrettiness reduced_state), PrettyDoc (pPrintFullState quietStatePrettiness (meaning p)) {-, res-}) + ; return res }, ScpState ms hist fs resid_tags parent_children) _ -> pure (do { traceRenderM ">sc {" (fun p, stateTags state, PrettyDoc (pPrintFullState quietStatePrettiness state)) - ; res <- addParentM p $ opt (Just (getOccString (varName (fun p)))) state + ; res <- addParentM p (opt (Just (getOccString (varName (fun p))))) state ; traceRenderM "<sc }" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), res) - ; fulfillM p res }, ScpState ms' hist fs resid_tags) + ; fulfillM p res }, ScpState ms' hist fs resid_tags parent_children) where (p, ms') = promise (state, reduced_state) ms where reduced_state = reduceForMatch state _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
