[commit: ghc] supercompiler: Add option for history tree (9586966)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/958696621c9ba9223ba38dd8796a81795075cdfe

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

commit 958696621c9ba9223ba38dd8796a81795075cdfe
Author: Max Bolingbroke <[email protected]>
Date:   Wed Apr 4 15:58:01 2012 +0100

    Add option for history tree

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

 .../supercompile/Supercompile/Drive/Process3.hs    |   19 ++++++++++---------
 compiler/supercompile/Supercompile/StaticFlags.hs  |    3 +++
 2 files changed, 13 insertions(+), 9 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 4819e1c..d3d41bc 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -129,7 +129,7 @@ type StopCount = Int
 
 data ScpState = ScpState {
     scpMemoState :: MemoState,
-    scpProcessHistory :: ProcessHistory,
+    scpProcessHistoryState :: ProcessHistory,
     scpFulfilmentState :: FulfilmentState,
     -- Debugging aids below this line:
     scpResidTags :: ResidTags,
@@ -137,6 +137,7 @@ data ScpState = ScpState {
   }
 
 data ScpEnv = ScpEnv {
+    scpProcessHistoryEnv :: ProcessHistory,
     scpStopCount :: StopCount,
     scpNodeKey :: NodeKey,
     scpParents :: [Var],
@@ -167,7 +168,7 @@ runScpM tag_anns me = fvedTermSize e' `seq` trace ("Deepest path:\n" ++ showSDoc
         hist = pROCESS_HISTORY
         fs = FS { fulfilments = [] }
         parent = generatedKey hist
-        (e, s') = unI $ runContT $ unReaderT (unStateT (unScpM me) (ScpState ms hist fs emptyResidTags emptyParentChildren)) (ScpEnv 0 parent [] nothingSpeculated tag_anns)
+        (e, s') = unI $ runContT $ unReaderT (unStateT (unScpM me) (ScpState ms hist fs emptyResidTags emptyParentChildren)) (ScpEnv hist 0 parent [] nothingSpeculated tag_anns)
         fulfils = fulfilments (scpFulfilmentState s')
         e' = letRec fulfils e
 
@@ -203,10 +204,10 @@ rolledBackTo s' s = flip fmap (on leftExtension (promises . scpMemoState) s' s)
           promises = appendHead [if fun p `elemVarSet` rolled_back then p { dumped = True } else p | p <- safeTail spine_rolled_back ++ possibly_rolled_back] ok_promises,
           hNames   = hNames (scpMemoState s')
         },
-      scpProcessHistory = scpProcessHistory s,
-      scpFulfilmentState = rolled_fulfilments,
-      scpResidTags      = scpResidTags s', -- FIXME: not totally accurate
-      scpParentChildren = scpParentChildren s'
+      scpProcessHistoryState = scpProcessHistoryState s,
+      scpFulfilmentState     = rolled_fulfilments,
+      scpResidTags           = scpResidTags s', -- FIXME: not totally accurate
+      scpParentChildren      = scpParentChildren s'
     }
 
 scpDepth :: ScpEnv -> Int
@@ -233,12 +234,12 @@ fulfillM :: (Deeds, FVedTerm) -> ScpM (Deeds, FVedTerm)
 fulfillM res = ScpM $ StateT $ \s -> case fulfill res (scpFulfilmentState s) (scpMemoState s) of (res', fs', ms') -> return (res', s { scpFulfilmentState = fs', scpMemoState = ms' })
 
 terminateM :: String -> State -> (Generaliser -> ScpM ()) -> ScpM a -> (String -> State -> (Generaliser -> ScpM ()) -> ScpM a) -> ScpM a
-terminateM h state rb mcont mstop = ScpM $ StateT $ \s -> ReaderT $ \env -> case ({-# SCC "terminate" #-} terminate (scpProcessHistory s) (scpNodeKey env, (h, state, rb))) of
+terminateM h state rb mcont mstop = ScpM $ StateT $ \s -> ReaderT $ \env -> case ({-# SCC "terminate" #-} terminate (if hISTORY_TREE then scpProcessHistoryEnv env else scpProcessHistoryState s) (scpNodeKey env, (h, state, rb))) of
         Stop (_, (shallow_h, shallow_state, shallow_rb))
           -> trace ("stops: " ++ show (scpStopCount env)) $
-             unReaderT (unStateT (unScpM (mstop shallow_h shallow_state shallow_rb)) s)                                 (env { scpStopCount = scpStopCount env + 1}) -- FIXME: prevent rollback?
+             unReaderT (unStateT (unScpM (mstop shallow_h shallow_state shallow_rb)) s)                                      (env { scpStopCount = scpStopCount env + 1}) -- FIXME: prevent rollback?
         Continue hist'
-          -> unReaderT (unStateT (unScpM mcont)                                      (s { scpProcessHistory = hist' })) (env { scpNodeKey = generatedKey hist' })
+          -> unReaderT (unStateT (unScpM mcont)                                      (s { scpProcessHistoryState = hist' })) (env { scpNodeKey = generatedKey hist', scpProcessHistoryEnv = hist' })
   -- TODO: record the names of the h-functions on the way to the current one instead of a Int depth
 
 speculateM :: State -> (State -> ScpM a) -> ScpM a
diff --git a/compiler/supercompile/Supercompile/StaticFlags.hs b/compiler/supercompile/Supercompile/StaticFlags.hs
index 51387e7..f131407 100644
--- a/compiler/supercompile/Supercompile/StaticFlags.hs
+++ b/compiler/supercompile/Supercompile/StaticFlags.hs
@@ -215,6 +215,9 @@ rEFINE_FULFILMENT_FVS :: Bool
 rEFINE_FULFILMENT_FVS = not $ lookUp $ fsLit "-fsupercompiler-no-refine-fulfilment-fvs"
 
 
+hISTORY_TREE :: Bool
+hISTORY_TREE = not $ lookUp $ fsLit "-fsupercompiler-no-history-tree"
+
 rEDUCE_ROLLBACK :: Bool
 rEDUCE_ROLLBACK = not $ lookUp $ fsLit "-fsupercompiler-no-reduce-rollback"