[commit: ghc] supercompiler: Checkpoint adding exceptions to Process3 (a0e1613)

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

On branch  : supercompiler

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

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

commit a0e161356f2eaecbe751fe90592637036aa94382
Author: Max Bolingbroke <[email protected]>
Date:   Wed Jan 18 18:03:55 2012 +0000

    Checkpoint adding exceptions to Process3

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

 .../supercompile/Supercompile/Drive/Process3.hs    |   40 ++++++++++++++++++-
 1 files changed, 37 insertions(+), 3 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index b7397ed..9b21a99 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes #-}
 module Supercompile.Drive.Process3 (supercompile) where
 
 import Supercompile.Drive.Match
@@ -29,6 +29,7 @@ import FastString (mkFastString)
 
 import Control.Monad (join)
 
+import Data.Function (on)
 import qualified Data.Map as M
 import Data.Monoid (mempty)
 
@@ -116,8 +117,10 @@ data ScpEnv = ScpEnv {
     scpTagAnnotations :: TagAnnotations
   }
 
+type ScpResType = (FVedTerm, ScpState)
+
 newtype ScpM a = ScpM { unScpM :: StateT ScpState
-                                         (ReaderT ScpEnv Identity) a }
+                                         (ReaderT ScpEnv (ContT ScpResType Identity)) a }
                deriving (Functor, Applicative, Monad)
 
 instance MonadStatics ScpM where
@@ -133,11 +136,42 @@ runScpM tag_anns me = fvedTermSize e' `seq` trace ("Deepest path:\n" ++ showSDoc
         hist = pROCESS_HISTORY
         fs = FS { fulfilments = [] }
         parent = generatedKey hist
-        (e, s') = unI $ 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 0 parent [] nothingSpeculated tag_anns)
         fulfils = fulfilments (scpFulfilmentState s')
         e' = letRec fulfils e
 
 
+callCCM :: ((forall b. a -> ScpM b) -> ScpM a) -> ScpM a
+callCCM act = ScpM $ StateT $ \s -> ReaderT $ \env -> callCC (\jump_back -> unReaderT (unStateT (unScpM (act (\a -> ScpM $ StateT $ \s' -> ReaderT $ \_ -> jump_back (a, s' `rolledBackTo` s)))) s) env)
+
+catchM :: ((forall b. c -> ScpM b) -> 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
+       -> ScpM a                              -- ^ Result from either the main action or the handler
+catchM try handler = do
+    ei_exc_res <- callCCM $ \jump_back -> fmap Right (try (jump_back . Left))
+    case ei_exc_res of
+      Left exc  -> handler exc
+      Right res -> return res
+
+rolledBackTo :: ScpState -> ScpState -> ScpState
+rolledBackTo s s' = ScpState {
+      scpMemoState = MS {
+          promises = promises (scpMemoState s),
+          hNames   = hNames (scpMemoState s')
+        },
+      scpProcessHistory = scpProcessHistory s,
+      scpFulfilmentState = FS {
+          fulfilments = ((\funs' funs -> pruneFulfilments (fulfilments (scpFulfilmentState s')) (funs' `minusVarSet` funs)) `on` (mkVarSet . map fun . promises . scpMemoState)) s' s
+        },
+      scpResidTags      = scpResidTags s', -- FIXME: not totally accurate
+      scpParentChildren = scpParentChildren s'
+    }
+  where
+    pruneFulfilments fulfilments rolled_back
+      | null dump = fulfilments
+      | otherwise = pruneFulfilments keep (rolled_back `unionVarSet` mkVarSet (map fst dump))
+      where (dump, keep) = partition (\(_, e) -> fvedTermFreeVars e `intersectsVarSet` rolled_back) fulfilments
+
 scpDepth :: ScpEnv -> Int
 scpDepth = length . scpParents