Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/996d41448fccb19bb3f03766692d8775d3333a67 >--------------------------------------------------------------- commit 996d41448fccb19bb3f03766692d8775d3333a67 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Apr 4 15:57:42 2012 +0100 More debug traces >--------------------------------------------------------------- .../supercompile/Supercompile/Drive/Process.hs | 3 ++- .../supercompile/Supercompile/Drive/Process3.hs | 2 +- .../Supercompile/Evaluator/Evaluate.hs | 20 ++++++++++++-------- 3 files changed, 15 insertions(+), 10 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index 076479f..0d7cbaa 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -684,7 +684,8 @@ reduce' orig_state = go False (mkLinearHistory rEDUCE_WQO) orig_state -- let smmrse s@(_, _, _, qa) = pPrintFullState s $$ case annee qa of Question _ -> text "Question"; Answer _ -> text "Answer" in -- pprPreview2 "reduce-stop" (smmrse old_state) (smmrse state) $ (can_step, mempty { stat_reduce_stops = 1 }, if rEDUCE_ROLLBACK then old_state else state') -- TODO: generalise? - | otherwise -> (True, mempty, state) + | otherwise -> pprTrace "reduce-stop(deeds)" empty $ + (True, mempty, state) _ -> (can_step, mempty, state) diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index c4adaf3..4819e1c 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -173,7 +173,7 @@ runScpM tag_anns me = fvedTermSize e' `seq` trace ("Deepest path:\n" ++ showSDoc callCCM :: ((a -> ScpM ()) -> ScpM a) -> ScpM a -callCCM act = ScpM $ StateT $ \s -> ReaderT $ \env -> callCC (\jump_back -> unReaderT (unStateT (unScpM (act (\a -> ScpM $ StateT $ \s' -> ReaderT $ \_ -> case s' `rolledBackTo` s of Just s'' -> jump_back (a, s''); Nothing -> return ((), s')))) s) env) +callCCM act = ScpM $ StateT $ \s -> ReaderT $ \env -> callCC (\jump_back -> unReaderT (unStateT (unScpM (act (\a -> ScpM $ StateT $ \s' -> ReaderT $ \_ -> case s' `rolledBackTo` s of Just s'' -> jump_back (a, s''); Nothing -> trace "rollback failed" $ return ((), s')))) s) env) catchM :: ((c -> ScpM ()) -> ScpM a) -- ^ Action to try: supplies a function than can be called to "raise an exception". Raising an exception restores the original ScpEnv and ScpState -> (c -> ScpM a) -- ^ Handler deferred to if an exception is raised diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index a4dd135..2710d72 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -108,16 +108,16 @@ ghcHeuristics x e (lone_variable, arg_infos, cont_info) where try unf = case unf of CoreSyn.CoreUnfolding { CoreSyn.uf_is_top = is_top, CoreSyn.uf_is_work_free = is_work_free, CoreSyn.uf_expandable = expandable - , CoreSyn.uf_arity = arity, CoreSyn.uf_guidance = guidance } - -> trce_fail (ppr (CoreSyn.uf_tmpl unf)) $ - Just $ tryUnfolding dflags1 x lone_variable - arg_infos cont_info is_top - is_cheap uf_arity guidance - is_work_free expandable - arity guidance + , CoreSyn.uf_arity = arity, CoreSyn.uf_guidance = guidance } + -> trce_fail (ppr (CoreSyn.uf_tmpl unf)) $ + Just $ tryUnfolding dflags1 x lone_variable + arg_infos cont_info is_top + is_work_free expandable + arity guidance -- GHC actually only looks through DFunUnfoldings in exprIsConApp_maybe, -- so I'll do this rough heuristic instead: - CoreSyn.DFunUnfolding {} -> trce (text "Dictionary unfolding") $ Just $ length arg_infos >= idArity x + CoreSyn.DFunUnfolding {} -> trce_fail (text "Unsaturated dictionary unfolding") $ + Just $ length arg_infos >= idArity x CoreSyn.NoUnfolding -> Nothing CoreSyn.OtherCon {} -> Nothing @@ -126,6 +126,10 @@ ghcHeuristics x e (lone_variable, arg_infos, cont_info) dflags1 | tRACE = dopt_set (dopt_set dflags0 Opt_D_verbose_core2core) Opt_D_dump_inlinings | otherwise = dflags0 + trce_fail :: SDoc -> Maybe Bool -> Maybe Bool + --trce_fail doc (Just False) = trce doc (Just False) + trce_fail _ mb_x = mb_x + trce :: SDoc -> a -> a trce | tRACE = pprTrace ("Considering inlining: " ++ showSDoc (ppr x)) | otherwise = flip const _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
