[commit: ghc] supercompiler: Fix the rollback check, which appeared to be totally broken (e8691a0)

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

On branch  : supercompiler

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

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

commit e8691a09a7e7454e2b9f13eda0785210db8c3219
Author: Max Bolingbroke <[email protected]>
Date:   Wed Apr 4 17:01:31 2012 +0100

    Fix the rollback check, which appeared to be totally broken

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

 .../supercompile/Supercompile/Drive/Process3.hs    |   10 +++---
 compiler/supercompile/Supercompile/Utilities.hs    |   33 +++++++++++++++++--
 2 files changed, 34 insertions(+), 9 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index d3d41bc..d69da56 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -71,10 +71,8 @@ appendHead ys1 (Loco ys2)        = Loco (ys1 ++ ys2)
 leftExtension :: Train (Promise, a) b -- ^ Longer list
               -> Train (Promise, a) b -- ^ Shorter list
               -> Maybe ([(Promise, a)], Train (Promise, a) b) -- Pair of the prefix present in the longer list and the common suffix (== shorter list)
-leftExtension xs_train ys_train = case splitBy (trainCars ys_train) (reverse (trainCars xs_train)) of
+leftExtension = trainLeftExtensionBy (\orig@(p1, _) (p2, _) -> if fun p1 == fun p2 then Just orig else Nothing) (\b1 _b2 -> Just b1)
     -- We can only roll back to direct ancestors, or we risk loops/other madness
-    (prefix_rev, Right suffix_rev) | on (==) (map (fun . fst)) (trainCars ys_train) suffix_rev -> Just (reverse prefix_rev, ys_train)
-    (_, _) -> Nothing -- pprPanic "leftExtension" (ppr (on (,) (map (fun . fst) . trainCars) xs_train ys_train))
 
 
 data MemoState = MS {
@@ -174,7 +172,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 -> trace "rollback failed" $ 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 -> 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
@@ -186,7 +184,9 @@ catchM try handler = do
       Right res -> return res
 
 rolledBackTo :: ScpState -> ScpState -> Maybe ScpState
-rolledBackTo s' s = flip fmap (on leftExtension (promises . scpMemoState) s' s) $ \(dangerous_promises, ok_promises) ->
+rolledBackTo s' s = case on leftExtension (promises . scpMemoState) s' s of
+ Nothing -> pprTrace "rollback failed" (on (curry ppr) (fmapTrain (map fun . uncurry (:)) (map fun) . promises . scpMemoState) s' s) Nothing
+ Just (dangerous_promises, ok_promises) -> Just $
   let -- We have to roll back any promise on the "stack" above us:
       (spine_rolled_back, possibly_rolled_back) = (second concat) $ unzip dangerous_promises
       -- NB: rolled_back includes names of both unfulfilled promises rolled back from the stack and fulfilled promises that have to be dumped as a result
diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs
index b1f0976..7fc59e5 100644
--- a/compiler/supercompile/Supercompile/Utilities.hs
+++ b/compiler/supercompile/Supercompile/Utilities.hs
@@ -648,17 +648,23 @@ supercompileUniqSupply = unsafePerformIO $ mkSplitUniqSupply 'p'
 
 data Train a b = Car a (Train a b) | Loco b
 
+instance (Outputable a, Outputable b) => Outputable (Train a b) where
+    ppr xs = brackets (fsep (punctuate comma (trainFoldr (\a -> (ppr a :)) (\b -> (ppr b :)) [] xs)))
+
 {-# INLINE trainAppend #-}
 trainAppend :: Train a b -> (b -> Train a b') -> Train a b'
 trainAppend init_abs mk_tl = go init_abs
   where go (Car a abs) = Car a (go abs)
         go (Loco b)    = mk_tl b
 
-{-# INLINE fmapCars #-}
-fmapCars :: (a -> a') -> Train a b -> Train a' b
-fmapCars f = go
+{-# INLINE fmapTrain #-}
+fmapTrain :: (a -> a') -> (b -> b') -> Train a b -> Train a' b'
+fmapTrain f g = go
   where go (Car a abs) = Car (f a) (go abs)
-        go (Loco b)    = Loco b
+        go (Loco b)    = Loco (g b)
+
+fmapCars :: (a -> a') -> Train a b -> Train a' b
+fmapCars f = fmapTrain f id
 
 fmapLoco :: (b -> b') -> Train a b -> Train a b'
 fmapLoco f abs = trainAppend abs (Loco . f)
@@ -712,6 +718,25 @@ trainMapAccumL f_car f_loco = go
         go s (Car a abs) = second (Car a') (go s' abs)
           where (s', a') = f_car s a
 
+{-# INLINE trainLeftExtensionBy #-}
+trainLeftExtensionBy :: (a1 -> a2 -> Maybe a)
+                     -> (b1 -> b2 -> Maybe b)
+                     -> Train a1 b1 -- ^ Longer list
+                     -> Train a2 b2 -- ^ Shorter list
+                     -> Maybe ([a1], Train a b) -- Pair of the prefix present in the longer list and the common suffix (== shorter list)
+trainLeftExtensionBy f_car f_loco xs ys = do
+    loco <- f_loco xs_loco ys_loco
+    go (reverse xs_cars) (reverse ys_cars) (Loco loco)
+  where
+    (xs_cars, xs_loco) = trainToList xs
+    (ys_cars, ys_loco) = trainToList ys
+
+    go xs_cars         []              train = Just (reverse xs_cars, train)
+    go []              _               _     = Nothing
+    go (x_car:xs_cars) (y_car:ys_cars) train = do
+        car <- f_car x_car y_car
+        go xs_cars ys_cars (Car car train)
+
 
 data Stream a = a :< Stream a