[commit: ghc] supercompiler: More debug traces (996d414)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/996d41448fccb19bb3f03766692d8775d3333a67

>---------------------------------------------------------------

commit 996d41448fccb19bb3f03766692d8775d3333a67
Author: Max Bolingbroke <[email protected]>
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