From 11fde0cf95d59e59ef2de572a388476159c7c6f5 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 18 Jun 2013 02:02:13 -0400 Subject: [PATCH] Improve handling of planner failures The planner now reports Either an exhaustive list of failed moves or a list of successful plans. When we find a plan, we forget the failures and begin accumulating succeses. Add --dump-failed-plans to facilitate debugging Report a user program error if a rule fails to have an initializer, partially addressing github nwf/dyna#5 . --- src/Dyna/Analysis/ANFPretty.hs | 58 +++++++++++++++++++---------- src/Dyna/Analysis/RuleMode.hs | 66 +++++++++++++++++++++++---------- src/Dyna/Main/Driver.hs | 68 +++++++++++++++++++++++++++------- 3 files changed, 138 insertions(+), 54 deletions(-) diff --git a/src/Dyna/Analysis/ANFPretty.hs b/src/Dyna/Analysis/ANFPretty.hs index b2a7a2e..5e04aba 100644 --- a/src/Dyna/Analysis/ANFPretty.hs +++ b/src/Dyna/Analysis/ANFPretty.hs @@ -1,48 +1,66 @@ -module Dyna.Analysis.ANFPretty (printANF) where +module Dyna.Analysis.ANFPretty (renderANF, renderCruxes) where +import Data.Either import qualified Data.IntMap as IM import qualified Data.Set as S import Dyna.Analysis.ANF import Dyna.Term.Normalized +import Dyna.Term.TTerm import Dyna.XXX.PPrint (valign) import Text.PrettyPrint.Free import Dyna.XXX.Trifecta (prettySpanLoc) ------------------------------------------------------------------------}}} --- Pretty Printer {{{ +-- Pretty Printers {{{ -printANF :: Rule -> Doc e -printANF (Rule rix h a result sp _ unifs evals) = +renderANF :: Rule -> Doc e +renderANF (Rule rix h a result sp _ unifs evals) = text ";;" <+> prettySpanLoc sp `above` text ";; index" <+> pretty rix `above` ( parens $ (pretty a) <+> valign [ (pretty h) - , parens $ text "evals" <+> pevs - , parens $ text "unifs" <+> puns + , parens $ text "evals" <+> pevs (IM.toAscList evals) + , parens $ text "unifs" <+> puns (S.toList unifs) , parens $ text "result" <+> (pretty result) ] ) <> line - where - pft :: FDT -> Doc e - pft (fn,args) = hsep $ (pretty fn : (map pretty args)) - pnft :: (Int,FDT) -> Doc e - pnft (n,(f,args)) = parens $ hsep $ ( pretty f <> char '@' <> pretty n - : (map pretty args)) +renderCruxes :: S.Set (Crux DVar TBase) -> Doc e +renderCruxes cs = + let (es, us) = partitionEithers (S.toList cs) + in valign + [ text "evals" indent 2 (pevs es) + , text "unifs" indent 2 (puns us) + ] - pev n (CEval o i) = parens (pretty o <+> pretty i <> char '@' <> pretty n) - pev n (CCall o is f) = parens (pretty o <+> pnft (n,(f,is))) +------------------------------------------------------------------------}}} +-- Internals {{{ + +pft :: FDT -> Doc e +pft (fn,args) = hsep $ (pretty fn : (map pretty args)) + +pnft :: (Int,FDT) -> Doc e +pnft (n,(f,args)) = parens $ hsep $ ( pretty f <> char '@' <> pretty n + : (map pretty args)) + +pev :: Int -> EvalCrux DVar -> Doc e +pev n (CEval o i) = parens (pretty o <+> pretty i <> char '@' <> pretty n) +pev n (CCall o is f) = parens (pretty o <+> pnft (n,(f,is))) + +pevs :: [(Int, EvalCrux DVar)] -> Doc e +pevs = valign . map (uncurry pev) - pun (CStruct o is f) = parens (pretty o <+> parens (char '&' <+> pft (f,is))) - pun (CAssign o v ) = parens (pretty o <+> parens (equals <+> pretty v)) - pun (CEquals v1 v2 ) = parens (pretty v1 <+> parens (equals <+> pretty v2)) - pun (CNotEqu v1 v2 ) = parens (pretty v1 <+> parens (char '!' <+> pretty v2)) +pun :: (Pretty a) => UnifCrux DVar a -> Doc e +pun (CStruct o is f) = parens (pretty o <+> parens (char '&' <+> pft (f,is))) +pun (CAssign o v ) = parens (pretty o <+> parens (equals <+> pretty v)) +pun (CEquals v1 v2 ) = parens (pretty v1 <+> parens (equals <+> pretty v2)) +pun (CNotEqu v1 v2 ) = parens (pretty v1 <+> parens (char '!' <+> pretty v2)) - pevs = valign $ map (uncurry pev) (IM.toAscList evals) - puns = valign $ map pun (S.toList unifs) +puns :: (Pretty a) => [UnifCrux DVar a] -> Doc e +puns = valign . map pun ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index 834ef2e..23bdc67 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -161,6 +161,8 @@ possible fp cr = -- unification crank out a series of DOpAMine opcodes for us, but for -- the moment, since everything we do is either IFree or IUniv, just use -- iEq everywhere. + -- + -- XXX Rescue the new planner from plan-nonground, when convenient. -- XXX Actually, this is all worse than it should be. The unification -- should be done before any case analysis. Note that we also don't do @@ -291,7 +293,6 @@ simpleCost (PP { pp_score = osc, pp_plan = pfx }) act = ------------------------------------------------------------------------}}} -- Planning {{{ - data PartialPlan fbs = PP { pp_cruxes :: S.Set (Crux DVar TBase) , pp_binds :: BindChart , pp_score :: Cost @@ -301,6 +302,14 @@ data PartialPlan fbs = PP { pp_cruxes :: S.Set (Crux DVar TBase) pp_liveVars :: PartialPlan fbs -> S.Set DVar pp_liveVars p = allCruxVars (pp_cruxes p) +-- XXX This certainly belongs elsewhere +renderPartialPlan rd (PP crs bs c pl) = + vcat [ text "cost=" <> pretty c + , text "pendingCruxes:" indent 2 (renderCruxes crs) + , text "context:" indent 2 (pretty bs) + , text "actions:" indent 2 (rd pl) + ] + -- XXX This does not have a way to signal UFNotReached back to its caller. -- That is particularly disappointing since any unification producing that -- means that there's certainly no plan for the whole rule. @@ -343,7 +352,8 @@ stepPartialPlan poss score p = plan ) [] -planner_ :: (Crux DVar TBase -> SIMCT Identity DFunct (Actions fbs)) +planner_ :: forall fbs . + (Crux DVar TBase -> SIMCT Identity DFunct (Actions fbs)) -- ^ Available steps -> (PartialPlan fbs -> Actions fbs -> Cost) -- ^ Scoring function @@ -356,7 +366,7 @@ planner_ :: (Crux DVar TBase -> SIMCT Identity DFunct (Actions fbs)) -> SIMCtx DVar -- ^ Initial context (which must cover all the variables -- in the given cruxes) - -> [(Cost, Actions fbs)] + -> Either [PartialPlan fbs] [(Cost, Actions fbs)] -- ^ Plans and their costs planner_ st sc cr mic ictx = runAgenda $ PP { pp_cruxes = cr @@ -365,18 +375,32 @@ planner_ st sc cr mic ictx = runAgenda , pp_plan = ip } where - runAgenda = go . (flip mioaPlan M.empty) + runAgenda = goMF [] . (flip mioaPlan M.empty) where mioaPlan :: PartialPlan fbs -> M.Map Cost [PartialPlan fbs] -> M.Map Cost [PartialPlan fbs] mioaPlan p@(PP{pp_score=psc}) = mapInOrCons psc p - go pq = maybe [] go' $ mapMinRepView pq + goMF fs pq = maybe (Left fs) (go' goMFkf (\df pq' -> Right (df:go pq'))) + $ mapMinRepView pq where - go' (p, pq') = case stepPartialPlan st sc p of - Left df -> df : (go pq') - Right ps' -> go (foldr mioaPlan pq' ps') + goMFkf Nothing = goMF fs + goMFkf (Just p) = goMF (p:fs) + + go :: M.Map Cost [PartialPlan fbs] + -> [(Cost, Actions fbs)] + go pq = maybe [] (go' (\_ -> go) (\df -> (df :) . go)) + $ mapMinRepView pq + + go' :: (Maybe (PartialPlan fbs) -> M.Map Cost [PartialPlan fbs] -> x) + -> ((Cost,Actions fbs) -> M.Map Cost [PartialPlan fbs] -> x) + -> (PartialPlan fbs, M.Map Cost [PartialPlan fbs]) + -> x + go' kf ks (p, pq') = case stepPartialPlan st sc p of + Right [] -> kf (Just p) pq' + Left df -> ks df pq' + Right ps' -> kf Nothing (foldr mioaPlan pq' ps') ctx' = either (const $ dynacPanicStr "Unable to bind input variable") snd @@ -399,9 +423,11 @@ planner_ st sc cr mic ictx = runAgenda -- considering at most a constant number of plans. -- -- XXX This is probably not the right idea -bestPlan :: [(Cost, a)] -> Maybe (Cost, a) -bestPlan [] = Nothing -bestPlan plans = Just $ argmin fst (take 1000 plans) +bestPlan :: Either e [(Cost, a)] -> Either e (Cost, a) +bestPlan = fmap go + where + go [] = dynacPanic "Planner claimed success with no plans!" + go plans@(_:_) = argmin fst (take 1000 plans) -- | Add the last Emit verb to a string of actions from the planner. -- @@ -422,11 +448,12 @@ planUpdate :: BackendPossible fbs -> S.Set (Crux DVar TBase) -- ^ Normal form -> (EvalCrux DVar, DVar, DVar) -> SIMCtx DVar - -> Maybe (Cost, Actions fbs) + -> Either [PartialPlan fbs] (Cost, Actions fbs) planUpdate bp r sc anf mi ictx = fmap (second (finalizePlan r)) $ bestPlan $ planner_ (possible bp) sc anf (Just mi) ictx -planInitializer :: BackendPossible fbs -> Rule -> Maybe (Cost, Actions fbs) +planInitializer :: BackendPossible fbs -> Rule + -> Either [PartialPlan fbs] (Cost, Actions fbs) planInitializer bp r = fmap (second (finalizePlan r)) $ let cruxes = r_cruxes r in bestPlan $ planner_ (possible bp) simpleCost cruxes Nothing @@ -494,8 +521,7 @@ handleDoubles vc e r = S.fold (go e) S.empty r planEachEval :: BackendPossible fbs -- ^ The backend's primitive support -> (DFunctAr -> Bool) -- ^ Indicator for constant function -> Rule - -> [(Int, Maybe (Cost, DVar, DVar, Actions fbs))] --- planEachEval _ _ _ = [] + -> [(Int, Either [PartialPlan fbs] (Cost, DVar, DVar, Actions fbs))] planEachEval bp cs r = map (\(n,cr) -> let @@ -577,7 +603,7 @@ type UpdateEvalMap fbs = M.Map (Maybe DFunctAr) -- timv: might want to fuse these into one circuit -- combineUpdatePlans :: [(Rule,[( Int, - Maybe (Cost, DVar, DVar, Actions fbs))])] + Either a (Cost, DVar, DVar, Actions fbs))])] -> UpdateEvalMap fbs combineUpdatePlans = go (M.empty) where @@ -587,18 +613,18 @@ combineUpdatePlans = go (M.empty) go' xs _ [] m = go m xs go' xs fr ((n,mca):ys) m = case mca of - Nothing -> dynacUserErr + Left _ -> dynacUserErr $ "No update plan for" <+> maybe "indirection" (\(f,a) -> pretty f <> char '/' <> pretty a) fa <+> "in rule at" <> line <> indent 2 (prettySpanLoc $ r_span fr) - Just (c,v1,v2,a) -> go' xs fr ys $ mapInOrCons fa (fr,n,c,v1,v2,a) m + Right (c,v1,v2,a) -> go' xs fr ys $ mapInOrCons fa (fr,n,c,v1,v2,a) m where fa = evalCruxFA ev - ev = maybe (dynacPanic $ "Eval index without eval crux in rule " - <+> (printANF fr)) + ev = maybe (dynacPanic $ "Eval index without eval crux in rule:" + (renderANF fr)) id (IM.lookup n (r_ecruxes fr)) diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index 10ce800..345dbe0 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -17,6 +17,7 @@ import Control.Applicative ((<*)) import Control.Exception -- import Control.Monad import qualified Data.ByteString.UTF8 as BU +import Data.Either import qualified Data.Map as M import qualified Data.Maybe as MA -- import qualified Data.Set as S @@ -48,6 +49,7 @@ data DumpType = DumpAgg | DumpANF | DumpDopIni | DumpDopUpd + | DumpFailedPlans | DumpParsed deriving (Eq,Ord,Show) @@ -79,6 +81,7 @@ dumpOpts nos = ++ mkDumpOpt "anf" DumpANF "Administrative Normal Form" ++ mkDumpOpt "dopini" DumpDopIni "DOpAMine planning results: initializers" ++ mkDumpOpt "dopupd" DumpDopUpd "DOpAMine planning results: updates" + ++ mkDumpOpt "failed-plans" DumpFailedPlans "Planner failures" ++ mkDumpOpt "parse" DumpParsed "Parser output" where mkDumpOpt arg fl hm = @@ -154,7 +157,7 @@ quickExit QEHelp = do ++ "There are known inefficiencies and less-than-ideal code.\n" ++ "We hope that you enjoy using it despite these woes! :)" - h = "\nUsage: dyna -B backend -o FILE.out FILE.dyna\n\nOption summary:" + h = "\nUsage: dyna -B backend [-o FILE.out] FILE.dyna\n\nOption summary:" quickExit QEHelpBackend = do qeBanner "Backend information" putDoc backendHelp @@ -278,6 +281,18 @@ renderDopInis ddi im = vsep $ flip map im $ \(r,c,ps) -> <+> text "head=" <> pretty (r_head r) <+> text "res=" <> pretty (r_result r) +renderFailedInit rd (r,ps) = + text ";; failed initialization attempts for" + (prettySpanLoc $ r_span r) + indent 2 (vsep $ map (renderPartialPlan rd) ps) + +renderFailedUpdate rd (r,i,ps) = + text ";; failed update plans for" + (prettySpanLoc $ r_span r) + <+> (text "evalix=" <> pretty i) + indent 2 (vsep $ map (renderPartialPlan rd) ps) + + ------------------------------------------------------------------------}}} -- Warnings {{{ @@ -306,7 +321,7 @@ processFile fileName = bracket openOut hClose go let (frs, anfWarns) = unzip $ map normRule rs - dump DumpANF (vcat $ map printANF frs) + dump DumpANF (vcat $ map renderANF frs) hPutDoc stderr $ vcat $ MA.mapMaybe maybeWarnANF anfWarns @@ -318,14 +333,17 @@ processFile fileName = bracket openOut hClose go case dcfg_backend ?dcfg of Backend _ be_b be_c be_ddi be_d -> - let initializers = MA.mapMaybe - (\(f,mca) -> (\(c,a) -> (f,c,a)) `fmap` mca) - $ map (\x -> (x, planInitializer be_b x)) frs - + let + initializers = map (\(f,mca) -> either (\e -> Left (f,e)) + (\(c,a) -> Right (f,c,a)) mca) + $ map (\x -> (x, planInitializer be_b x)) frs + + cInitializers = rights initializers - uPlans = combineUpdatePlans - $ map (\x -> (x, planEachEval be_b be_c x)) - frs + uPlans = map (\x -> (x, planEachEval be_b be_c x)) + frs + + cuPlans = combineUpdatePlans uPlans {- qPlans = combineQueryPlans @@ -334,16 +352,38 @@ processFile fileName = bracket openOut hClose go -} in do + -- Do this before forcing cInitializers, cuPlans, etc., + -- as those will panic and stop the pipeline. + dump DumpFailedPlans $ + vcat [ vcat $ map (renderFailedInit (renderDop be_ddi)) + $ lefts initializers + , let + shuffle (r,ips) = map sgo ips + where + sgo (i,Left e) = Left (r,i,e) + sgo (_,Right _) = Right () + in vcat $ map (renderFailedUpdate (renderDop be_ddi)) + $ lefts + $ concat + $ map shuffle uPlans + ] + -- Force evaluation of a lot of the work of the compiler, -- even if the backend and dump flags won't do it for us. - initializers' <- evaluate $ initializers - uPlans' <- evaluate $ uPlans + cInitializers' <- evaluate $ cInitializers + cuPlans' <- evaluate $ cuPlans + + case lefts initializers of + [] -> return () + xs -> dynacUserErr $ "Unable to plan initializers for rule(s):" + (indent 2 $ vcat $ + map (prettySpanLoc . r_span . fst) xs) - dump DumpDopIni (renderDopInis be_ddi initializers') - dump DumpDopUpd (renderDopUpds be_ddi uPlans') + dump DumpDopIni (renderDopInis be_ddi cInitializers') + dump DumpDopUpd (renderDopUpds be_ddi cuPlans') -- Invoke the backend code generator - be_d aggm uPlans' {- qPlans -} initializers' pp out + be_d aggm cuPlans' {- qPlans -} cInitializers' pp out parse aggs = do pr <- T.parseFromFileEx (P.oneshotDynaParser aggs <* T.eof) fileName -- 2.50.1