Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/bd7d252bf86c937d56e146775a46fff346047582 >--------------------------------------------------------------- commit bd7d252bf86c937d56e146775a46fff346047582 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Thu Feb 16 08:45:29 2012 +0000 Let the splitBy functions report failure >--------------------------------------------------------------- .../supercompile/Supercompile/Drive/Process1.hs | 4 ++-- .../supercompile/Supercompile/Drive/Process3.hs | 2 +- compiler/supercompile/Supercompile/Drive/Split.hs | 6 +++--- compiler/supercompile/Supercompile/Utilities.hs | 9 +++++---- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process1.hs b/compiler/supercompile/Supercompile/Drive/Process1.hs index 336b032..73c5073 100644 --- a/compiler/supercompile/Supercompile/Drive/Process1.hs +++ b/compiler/supercompile/Supercompile/Drive/Process1.hs @@ -70,7 +70,7 @@ data Promise = P { instance MonadStatics ScpBM where bindCapturedFloats = bindFloats - monitorFVs mx = ScpM $ \e s k -> unScpM mx e s (\x s' -> let (fss_delta, _fss_common) = splitByReverse (pTreeHole s) (pTreeHole s') + monitorFVs mx = ScpM $ \e s k -> unScpM mx e s (\x s' -> let (Right fss_delta, _fss_common) = splitByReverse (pTreeHole s) (pTreeHole s') in k (unionVarSets [fvedTermFreeVars e' | (_, e') <- concatMap fulfilmentTreeFulfilments fss_delta], x) s') -- Note [Floating h-functions past the let-bound variables to which they refer] @@ -347,7 +347,7 @@ catchScpM :: ((forall b. c -> ScpBM b) -> ScpBM a) -- ^ Action to try: supplies catchScpM f_try f_abort = ScpM $ \e s k -> unScpM (f_try (\c -> ScpM $ \e' s' _k' -> unScpM (f_abort c) e (if False -- dISCARD_FULFILMENTS_ON_ROLLBACK then s - else let (fss_candidates, _fss_common) = splitByReverse (pTreeContext e) (pTreeContext e') + else let (Right fss_candidates, _fss_common) = splitByReverse (pTreeContext e) (pTreeContext e') -- Since we are rolling back we need to float as many of the fulfilments created in between here and the rollback point -- upwards. This means that we don't lose the work that we already did to supercompile those bindings. diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index c69cffd..0778d6b 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -72,7 +72,7 @@ leftExtension :: Train a b -- ^ Longer list -> Train a b -- ^ Shorter list -> ([a], Train a b) -- Pair of the prefix present in the longer list and the common suffix (== shorter list) leftExtension xs_train ys_train = (reverse prefix_rev, ys_train) - where (prefix_rev, _suffix_rev) = splitBy (trainCars ys_train) (reverse (trainCars xs_train)) -- NB: we actually assume ys == suffix_rev + where (prefix_rev, Right _suffix_rev) = splitBy (trainCars ys_train) (reverse (trainCars xs_train)) -- NB: we actually assume ys == suffix_rev data MemoState = MS { diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs b/compiler/supercompile/Supercompile/Drive/Split.hs index 41867dd..3a7388a 100644 --- a/compiler/supercompile/Supercompile/Drive/Split.hs +++ b/compiler/supercompile/Supercompile/Drive/Split.hs @@ -435,7 +435,7 @@ zipBracketeds (TailsUnknown bshell bholes) = TailsUnknown (Shell shell_tags shel = (plusResidTags shell_extra_tags (bracketedExtraTags rbracketed), shell_extra_fvs `unionVarSet` nonRecBindersFreeVars bvs (bracketedExtraFvs rbracketed), \es rev_es' -> case splitBy (bracketedHoles rbracketed) es of - (es_here, es_later) -> shell_wrapper es_later (shellWrapper (bracketedShell rbracketed) es_here:rev_es'), + (es_here, Right es_later) -> shell_wrapper es_later (shellWrapper (bracketedShell rbracketed) es_here:rev_es'), bracketedHoles rbracketed ++ holes) where rbracketed = rigidizeBracketed bracketed zipBracketeds (TailsKnown bty mk_bshell bholes) = case ei_holes of @@ -450,12 +450,12 @@ zipBracketeds (TailsKnown bty mk_bshell bholes) = case ei_holes of -> (\ty -> plusResidTags (shell_extra_tags ty) (shellExtraTags (mk_shell ty)), \ty -> shell_extra_fvs ty `unionVarSet` nonRecBindersFreeVars bvs (shellExtraFvs (mk_shell ty)), \ty es rev_es' -> case splitBy holes' es of - (es_here, es_later) -> shell_wrapper ty es_later (shellWrapper (mk_shell ty) es_here:rev_es'), + (es_here, Right es_later) -> shell_wrapper ty es_later (shellWrapper (mk_shell ty) es_here:rev_es'), Right (holes' ++ holes)) _ -> (\ty -> plusResidTags (shell_extra_tags ty) (bracketedExtraTags rbracketed), \ty -> shell_extra_fvs ty `unionVarSet` nonRecBindersFreeVars bvs (bracketedExtraFvs rbracketed), \ty es rev_es' -> case splitBy (bracketedHoles rbracketed) es of - (es_here, es_later) -> shell_wrapper ty es_later (shellWrapper (bracketedShell rbracketed) es_here:rev_es'), + (es_here, Right es_later) -> shell_wrapper ty es_later (shellWrapper (bracketedShell rbracketed) es_here:rev_es'), case ei_holes of Left holes -> Left (bracketedHoles rbracketed ++ holes) Right holes | is_tail -> Left (bracketedHoles rbracketed ++ map tailishHole holes) | otherwise -> Right (map (TailishHole False) (bracketedHoles rbracketed) ++ holes)) diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs index 44f2d3c..c22a6af 100644 --- a/compiler/supercompile/Supercompile/Utilities.hs +++ b/compiler/supercompile/Supercompile/Utilities.hs @@ -425,12 +425,13 @@ safeTail (_:xs) = xs expectHead :: String -> [a] -> a expectHead s = expectJust s . safeHead -splitBy :: [b] -> [a] -> ([a], [a]) -splitBy [] xs = ([], xs) +splitBy :: [b] -> [a] -> ([a], Either [b] [a]) +splitBy [] xs = ([], Right xs) +splitBy (y:ys) [] = ([], Left (y:ys)) splitBy (_:ys) (x:xs) = first (x:) $ splitBy ys xs -splitByReverse :: [b] -> [a] -> ([a], [a]) -splitByReverse ys xs = case splitBy ys (reverse xs) of (xs1, xs2) -> (reverse xs2, reverse xs1) +splitByReverse :: [b] -> [a] -> (Either [b] [a], [a]) +splitByReverse ys xs = case splitBy (reverse ys) (reverse xs) of (xs1, ei_ys1_xs2) -> (either (Left . reverse) (Right . reverse) ei_ys1_xs2, reverse xs1) listContexts :: [a] -> [([a], a, [a])] listContexts xs = zipWith (\is (t:ts) -> (is, t, ts)) (inits xs) (init (tails xs)) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
