[commit: ghc] supercompiler: Just rearrange stuff a bit, change the meaning of generated_key (b4103f8)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/b4103f8985aa02761aa5e262ede8d7a3ef887699

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

commit b4103f8985aa02761aa5e262ede8d7a3ef887699
Author: Max Bolingbroke <[email protected]>
Date:   Fri Nov 4 15:44:45 2011 +0000

    Just rearrange stuff a bit, change the meaning of generated_key

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

 .../supercompile/Supercompile/Drive/Process2.hs    |   97 ++++++++++----------
 .../Supercompile/Termination/Combinators.hs        |    6 +-
 2 files changed, 51 insertions(+), 52 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process2.hs b/compiler/supercompile/Supercompile/Drive/Process2.hs
index a9a2fba..8a1513e 100644
--- a/compiler/supercompile/Supercompile/Drive/Process2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process2.hs
@@ -114,53 +114,6 @@ breadthFirst :: DelayM m r -> DelayM m r
 breadthFirst = id
 
 
-type LevelM = FulfilmentT (SpecT ScpM)
-
-
--- NB: monads *within* the ContT are persistent over a rollback. Ones outside get reset.
-type ProcessM = ContT (Out FVedTerm) HistoryThreadM
-type ScpM = DelayM (MemoT ProcessM)
-
-traceRenderScpM :: (Outputable a, Monad m) => String -> a -> m ()
-traceRenderScpM msg x = pprTraceSC msg (pPrint x) $ return () -- TODO: include depth, refine to ScpM monad only
-
-runScpM :: (Applicative m, Monad m) => m (DelayM m a) -> m a
-runScpM mx = mx >>= runDelayM eval_strat
-  where
-    -- Doing things this way prevents GHC bleating about depthFirst being unused
-    eval_strat | False     = depthFirst
-               | otherwise = breadthFirst
-
-
-type ProcessHistory = LinearHistory (State, RollbackScpM) -- TODO: GraphicalHistory
-
-pROCESS_HISTORY :: ProcessHistory
-pROCESS_HISTORY = mkLinearHistory (cofmap fst wQO)
-
-type HistoryEnvM = (->) ProcessHistory
-
-runHistoryEnvM :: HistoryEnvM a -> a
-runHistoryEnvM = flip ($) pROCESS_HISTORY
-
-type HistoryThreadM = State.State ProcessHistory
-
-withHistory :: (ProcessHistory -> (ProcessHistory, a)) -> HistoryThreadM a
-withHistory f = State.state (swap . f)
-  where swap = uncurry (flip (,))
-
-runHistoryThreadM :: HistoryThreadM a -> a
-runHistoryThreadM = flip State.evalState pROCESS_HISTORY
-
-
-terminateM :: State -> RollbackScpM -> a -> (State -> RollbackScpM -> ProcessM (ProcessHistory, a)) -> ProcessM a
-terminateM state rb k_continue k_stop = withHistory' $ \hist -> case terminate hist (state, rb) of
-    Continue hist'                   -> return (hist', k_continue)
-    Stop (shallow_state, shallow_rb) -> k_stop shallow_state shallow_rb
-  where
-    withHistory' :: (ProcessHistory -> ProcessM (ProcessHistory, a)) -> ProcessM a
-    withHistory' act = lift State.get >>= \hist -> act hist >>= \(hist', x) -> lift (State.put hist') >> return x
-
-
 class MonadTrans t where
     lift :: Monad m => m a -> t m a
 
@@ -263,6 +216,38 @@ liftCallCCReaderT :: (((forall b. a -> m b)           -> m a)           -> m a)
 liftCallCCReaderT call_cc f = ReaderT $ \r -> call_cc $ \c -> runReaderT r (f (ReaderT . const . c))
 
 
+newtype RollbackScpM = RB { doRB :: forall c. LevelM (Deeds, Out FVedTerm) -> ProcessM c }
+
+
+type ProcessHistory = LinearHistory (State, RollbackScpM) -- TODO: GraphicalHistory
+
+pROCESS_HISTORY :: ProcessHistory
+pROCESS_HISTORY = mkLinearHistory (cofmap fst wQO)
+
+type HistoryEnvM = (->) ProcessHistory
+
+runHistoryEnvM :: HistoryEnvM a -> a
+runHistoryEnvM = flip ($) pROCESS_HISTORY
+
+type HistoryThreadM = State.State ProcessHistory
+
+withHistory :: (ProcessHistory -> (ProcessHistory, a)) -> HistoryThreadM a
+withHistory f = State.state (swap . f)
+  where swap = uncurry (flip (,))
+
+runHistoryThreadM :: HistoryThreadM a -> a
+runHistoryThreadM = flip State.evalState pROCESS_HISTORY
+
+
+terminateM :: State -> RollbackScpM -> a -> (State -> RollbackScpM -> ProcessM (ProcessHistory, a)) -> ProcessM a
+terminateM state rb k_continue k_stop = withHistory' $ \hist -> case terminate hist (state, rb) of
+    Continue hist'                   -> return (hist', k_continue)
+    Stop (shallow_state, shallow_rb) -> k_stop shallow_state shallow_rb
+  where
+    withHistory' :: (ProcessHistory -> ProcessM (ProcessHistory, a)) -> ProcessM a
+    withHistory' act = lift State.get >>= \hist -> act hist >>= \(hist', x) -> lift (State.put hist') >> return x
+
+
 data Promise = P {
     fun        :: Var,      -- Name assigned in output program
     abstracted :: [AbsVar], -- Abstracted over these variables
@@ -336,7 +321,6 @@ memo opt state = StateT $ \ms ->
                 where (p, ms') = promise state ms
 
 
--- FIXME: I'm not convinced this is being extended correctly!!
 type SpecT = ReaderT AlreadySpeculated
 
 runSpecT :: SpecT m a -> m a
@@ -350,7 +334,22 @@ liftSpeculatedStateT :: (forall a. State -> (State -> m a)        -> m a)
 liftSpeculatedStateT speculated state k = StateT $ \s -> speculated state (\state' -> unStateT (k state') s)
 
 
-newtype RollbackScpM = RB { doRB :: forall c. LevelM (Deeds, Out FVedTerm) -> ProcessM c }
+type LevelM = FulfilmentT (SpecT ScpM)
+
+-- NB: monads *within* the ContT are persistent over a rollback. Ones outside get reset.
+type ProcessM = ContT (Out FVedTerm) HistoryThreadM
+type ScpM = DelayM (MemoT ProcessM)
+
+traceRenderScpM :: (Outputable a, Monad m) => String -> a -> m ()
+traceRenderScpM msg x = pprTraceSC msg (pPrint x) $ return () -- TODO: include depth, refine to ScpM monad only
+
+runScpM :: (Applicative m, Monad m) => m (DelayM m a) -> m a
+runScpM mx = mx >>= runDelayM eval_strat
+  where
+    -- Doing things this way prevents GHC bleating about depthFirst being unused
+    eval_strat | False     = depthFirst
+               | otherwise = breadthFirst
+
 
 sc' :: State -> ProcessM (LevelM (Deeds, Out FVedTerm))
 sc' state = callCC (\k -> try (RB k))
diff --git a/compiler/supercompile/Supercompile/Termination/Combinators.hs b/compiler/supercompile/Supercompile/Termination/Combinators.hs
index 1f103d1..5f66425 100644
--- a/compiler/supercompile/Supercompile/Termination/Combinators.hs
+++ b/compiler/supercompile/Supercompile/Termination/Combinators.hs
@@ -219,9 +219,9 @@ instance History GraphicalHistory where
 mkGraphicalHistory :: forall a. TTest a -> GraphicalHistory (NodeKey, a)
 mkGraphicalHistory (WQO (prepare :: a -> b) embed) = go_init emptyTopologicalOrder [] 0
   where
-    go_init topo abs key' = GH {
-        unGH = \(key, a) -> let Just topo' = insertTopologicalOrder topo (key, key') in go topo' [] abs key key' a (prepare a),
-        generatedKey = key'
+    go_init topo abs generated_key = GH {
+        unGH = \(key, a) -> let Just topo' = insertTopologicalOrder topo (key, generated_key + 1) in go topo' [] abs key (generated_key + 1) a (prepare a),
+        generatedKey = generated_key
       }
 
     go topo new_abs []                  key key' new_a new_b = Continue $ go_init topo (reverse ((key, new_a, new_b):new_abs)) (key' + 1)