Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/0702b1ff8db05c83256ff99875a62c2418a42b6c >--------------------------------------------------------------- commit 0702b1ff8db05c83256ff99875a62c2418a42b6c Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Thu Nov 24 09:45:14 2011 +0000 Trace depth, trace less >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/Match.hs | 6 +++- .../supercompile/Supercompile/Drive/Process3.hs | 25 ++++++++++--------- compiler/supercompile/Supercompile/Utilities.hs | 2 +- 3 files changed, 18 insertions(+), 15 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Match.hs b/compiler/supercompile/Supercompile/Drive/Match.hs index e63dc8d..60710f3 100644 --- a/compiler/supercompile/Supercompile/Drive/Match.hs +++ b/compiler/supercompile/Supercompile/Drive/Match.hs @@ -27,11 +27,13 @@ import qualified Data.Map as M pprTraceSC :: String -> SDoc -> a -> a -pprTraceSC = pprTrace +pprTraceSC _ _ = id +--pprTraceSC = pprTrace --pprTraceSC msg doc a = traceSC (msg ++ ": " ++ showSDoc doc) a traceSC :: String -> a -> a -traceSC = trace +traceSC _ = id +--traceSC = trace --newtype Match a = Match { unMatch :: Either String a } diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index 110b4b3..a5fef20 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -85,10 +85,11 @@ fulfill :: Promise -> (Deeds, FVedTerm) -> FulfilmentState -> ((Deeds, FVedTerm) fulfill p (deeds, e_body) fs = ((deeds, var (fun p) `applyAbsVars` abstracted p), FS { fulfilments = (fun p, tyVarIdLambdas (abstracted p) e_body) : fulfilments fs }) +type Depth = Int type StopCount = Int newtype ScpM a = ScpM { unScpM :: StateT (MemoState, ProcessHistory, FulfilmentState) - (ReaderT (StopCount, NodeKey, AlreadySpeculated) Identity) a } + (ReaderT (Depth, StopCount, NodeKey, AlreadySpeculated) Identity) a } deriving (Functor, Applicative, Monad) instance MonadStatics ScpM where @@ -103,23 +104,23 @@ runScpM me = letRec (fulfilments fs') e hist = pROCESS_HISTORY fs = FS { fulfilments = [] } parent = generatedKey hist - (e, (_ms', _hist', fs')) = unI $ unReaderT (unStateT (unScpM me) (ms, hist, fs)) (0, parent, nothingSpeculated) + (e, (_ms', _hist', fs')) = unI $ unReaderT (unStateT (unScpM me) (ms, hist, fs)) (0, 0, parent, nothingSpeculated) traceRenderM :: Outputable a => String -> a -> ScpM () -traceRenderM msg x = pprTraceSC msg (pPrint x) $ pure () -- TODO: include depth, refine to ScpM monad only +traceRenderM msg x = ScpM $ StateT $ \s -> ReaderT $ \(depth, _, _, _) -> pprTraceSC (replicate depth ' ' ++ msg) (pPrint x) $ pure ((), s) -- TODO: include depth, refine to ScpM monad only fulfillM :: Promise -> (Deeds, FVedTerm) -> ScpM (Deeds, FVedTerm) fulfillM p res = ScpM $ StateT $ \(ms, hist, fs) -> case fulfill p res fs of (res', fs') -> return (res', (ms, hist, fs')) terminateM :: State -> ScpM a -> (State -> ScpM a) -> ScpM a -terminateM state mcont mstop = ScpM $ StateT $ \(ms, hist, fs) -> ReaderT $ \(stops, parent, already) -> case terminate hist (parent, state) of +terminateM state mcont mstop = ScpM $ StateT $ \(ms, hist, fs) -> ReaderT $ \(depth, stops, parent, already) -> trace ("depth: " ++ show depth) case terminate hist (parent, state) of Stop (_, shallow_state) -> trace ("stops: " ++ show stops) $ - unReaderT (unStateT (unScpM (mstop shallow_state)) (ms, hist, fs)) (stops + 1, parent, already) -- FIXME: prevent rollback? - Continue hist' -> unReaderT (unStateT (unScpM mcont) (ms, hist', fs)) (stops, generatedKey hist', already) + unReaderT (unStateT (unScpM (mstop shallow_state)) (ms, hist, fs)) (depth + 1, stops + 1, parent, already) -- FIXME: prevent rollback? + Continue hist' -> unReaderT (unStateT (unScpM mcont) (ms, hist', fs)) (depth + 1, stops, generatedKey hist', already) speculateM :: State -> (State -> ScpM a) -> ScpM a -speculateM state mcont = ScpM $ StateT $ \s -> ReaderT $ \(stops, parent, already) -> case speculate already (mempty, state) of (already', (_stats, state')) -> unReaderT (unStateT (unScpM (mcont state')) s) (stops, parent, already') +speculateM state mcont = ScpM $ StateT $ \s -> ReaderT $ \(depth, stops, parent, already) -> case speculate already (mempty, state) of (already', (_stats, state')) -> unReaderT (unStateT (unScpM (mcont state')) s) (depth, stops, parent, already') sc, sc' :: State -> ScpM (Deeds, FVedTerm) @@ -130,8 +131,8 @@ sc' state = terminateM state (speculateM (reduce state) $ \state -> split state (generalise (mK_GENERALISER shallow_state state) state) sc) where - trce how shallow_state = pprTraceSC ("sc-stop(" ++ how ++ ")") (ppr (stateTags shallow_state) <+> text "<|" <+> ppr (stateTags state) $$ - ppr shallow_state $$ pPrintFullState True shallow_state $$ ppr state $$ pPrintFullState True state) + trce how shallow_state = pprTraceSC ("sc-stop(" ++ how ++ ")") ({- ppr (stateTags shallow_state) <+> text "<|" <+> ppr (stateTags state) $$ -} + {- ppr shallow_state $$ -} pPrintFullState {-True-}False shallow_state $$ {- ppr state $$ -} pPrintFullState {-True-}False state) -- Note [Prevent rollback loops by only rolling back when generalising] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -167,11 +168,11 @@ memo opt state = join $ ScpM $ StateT $ \(ms, hist, fs) -> -- I can't rename, so "rename" will cause an error. Not observed in practice yet. case [ (p, (releaseStateDeed state, var (fun p) `applyAbsVars` map (renameAbsVar rn_lr) (abstracted p))) | 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) $ + , 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) state] - ] of (p, res):_ -> pure (do { traceRenderM "=sc" (fun p, PrettyDoc (pPrintFullState True state), res) + ] of (p, res):_ -> pure (do { traceRenderM "=sc" (fun p, PrettyDoc (pPrintFullState {-True-}False state), res) ; return res }, (ms, hist, fs)) - _ -> pure (do { traceRenderM ">sc" (fun p, PrettyDoc (pPrintFullState True state)) + _ -> pure (do { traceRenderM ">sc" (fun p, PrettyDoc (pPrintFullState {-True-}False state)) ; res <- opt state ; traceRenderM "<sc" (fun p, PrettyDoc (pPrintFullState False state), res) ; fulfillM p res }, (ms', hist, fs)) diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs index acdb5f4..f057984 100644 --- a/compiler/supercompile/Supercompile/Utilities.hs +++ b/compiler/supercompile/Supercompile/Utilities.hs @@ -22,7 +22,7 @@ import UniqSupply import Unique (Unique, getKey) import UniqFM (UniqFM, eltsUFM) import Maybes (expectJust) -import Outputable +import Outputable hiding (Depth) import State hiding (mapAccumLM) import Control.Arrow (first, second, (***), (&&&)) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
