Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/b4103f8985aa02761aa5e262ede8d7a3ef887699 >--------------------------------------------------------------- commit b4103f8985aa02761aa5e262ede8d7a3ef887699 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
