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