From 1cdaa2732a9c5f00d6bd4439a684362c4142237c Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 11 Dec 2012 14:07:16 -0500 Subject: [PATCH] Add planning for initializers; make python write them --- src/Dyna/Analysis/ANF.hs | 6 +++ src/Dyna/Analysis/RuleMode.hs | 32 ++++++++------ src/Dyna/Backend/Python.hs | 78 ++++++++++++++++++++++++++--------- src/Dyna/XXX/PPrint.hs | 16 ++++++- 4 files changed, 98 insertions(+), 34 deletions(-) diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 93581e9..6600a22 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -40,6 +40,12 @@ -- -- XXX We really should do some CSE/GVN somewhere right after this pass, but -- be careful about linearity! +-- +-- XXX Maybe we should be doing something differently for the head variable +-- of the ANF -- we know (or should know, anyway) that it's either the +-- result of evaluation (in the tricky examples like @*f += 1@) or a +-- structured term. None of our as_* fields give us that guarantee. See +-- "Dyna.Backend.Python"'s @findHeadFA@ function. -- FIXME: "str" is the same a constant str. diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index 29bb648..a3c6c5e 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -17,7 +17,7 @@ module Dyna.Analysis.RuleMode ( DOpAMine(..), detOfDop, - Action, Cost, Det(..), planEachEval, + Action, Cost, Det(..), planInitializer, planEachEval, adornedQueries ) where @@ -317,8 +317,8 @@ stepAgenda st sc = go Left df -> df : (go ps) Right ps' -> go (ps'++ps) -initialPlanForCrux :: DVar -> DVar -> Crux DVar a -> Action -initialPlanForCrux hi v cr = case cr of +initialPlanForCrux :: (Crux DVar a, DVar, DVar) -> Action +initialPlanForCrux (cr, hi, v) = case cr of CFCall o is f -> [ OPGetArgsIf is hi f, OPAssign o (NTVar v) ] _ -> error "Don't know how to initially plan !CFCall" @@ -327,32 +327,38 @@ initialPlanForCrux hi v cr = case cr of -- -- XXX If the intial entrypoint is nonlinear, we need to insert some -- checks into the plan. Fixing that is moderately invasive... +-- +-- XXX This has no idea what to do about non-range-restricted rules. plan_ :: (Crux (ModedVar) (ModedNT) -> [Action]) -- ^ Available steps -> (PartialPlan -> Action -> Cost) -- ^ Scoring function -> ANFState -- ^ Normal form - -> Crux DVar NTV -- ^ Initial crux - -> DVar -- ^ Head Intern - -> DVar -- ^ Value + -> Maybe (Crux DVar NTV, DVar, DVar) -- ^ Initial crux, + -- item intern, and + -- value, if any. -> [(Cost, Action)] -- ^ If there's a plan... -plan_ st sc anf cr hi v = +plan_ st sc anf mi = let cruxes = eval_cruxes anf ++ unif_cruxes anf - initPlan = PP { pp_cruxes = S.delete cr (S.fromList cruxes) - , pp_binds = cruxVars cr + initPlan = PP { pp_cruxes = maybe id (\(c,_,_) -> S.delete c) mi + $ S.fromList cruxes + , pp_binds = maybe S.empty (\(c,_,_) -> cruxVars c) mi , pp_score = 0 - , pp_plan = initialPlanForCrux hi v cr + , pp_plan = maybe [] initialPlanForCrux mi } in stepAgenda st sc [initPlan] -plan st sc anf cr hi v = +plan st sc anf mi = (\x -> case x of [] -> Nothing plans -> Just $ L.minimumBy (O.comparing fst) plans) - $ plan_ st sc anf cr hi v + $ plan_ st sc anf mi + +planInitializer :: FRule -> Maybe (Cost,Action) +planInitializer (FRule { fr_anf = anf }) = plan possible simpleCost anf Nothing planEachEval :: DVar -> DVar -> FRule -> [(DFunctAr, Maybe (Cost,Action))] planEachEval hi v (FRule { fr_anf = anf }) = - map (\(c,fa) -> (fa, plan possible simpleCost anf c hi v)) + map (\(c,fa) -> (fa, plan possible simpleCost anf $ Just (c,hi,v))) $ MA.mapMaybe (\c -> case c of CFCall _ is f | not $ isMath f -> Just $ (c,(f,length is)) diff --git a/src/Dyna/Backend/Python.hs b/src/Dyna/Backend/Python.hs index b7152af..928b583 100644 --- a/src/Dyna/Backend/Python.hs +++ b/src/Dyna/Backend/Python.hs @@ -119,22 +119,53 @@ combinePlans = go (M.empty) -- timv: consider flattening FRUle and ANFState -py (cruxf,cruxa) (FRule h _ _ r span _) dope = - "@register" <> (parens $ dquotes $ pretty cruxf <> "/" <> (text $ show cruxa)) - `above` "def _(_h, _v):" - `above` (indent 4 $ go dope) +py (f,a) mu (FRule h _ _ r span _) dope = + case mu of + Just (hv,v) -> + "@register" + <> pfsa + `above` "def" <+> char '_' + <+> tupled (map pretty [hv,v]) + <+> colon + Nothing -> "@initializer" <> pfsa + `above` "def _():" + `above` (indent 4 $ go dope emit) where - go [x] = pdope x `above` emit + pfsa = (parens $ dquotes $ + pretty f <> "/" <> (text $ show a)) + + go [] = id go (x:xs) = let px = pdope x - pxstr = (show $ px) - indents = ((pxstr !! (length pxstr - 1)) == ':') + indents = case x of OPIter _ _ _ -> True ; _ -> False in - px `above` (if indents then indent 4 $ go xs else go xs) + above px . (if indents then indent 4 else id) . go xs emit = "emit" <> tupled [pretty h, pretty r] +printPlan :: Handle + -> (DFunct,Int) -- ^ Functor & arity + -> Maybe (DVar,DVar) -- ^ if update, input intern & value + -> (FRule, Cost, Action) -- ^ rule and plan + -> IO () +printPlan fh fa mu (r, cost, dope) = do -- display plan + hPutStrLn fh $ "# --" + displayIO fh $ prefixSD "# " $ renderPretty 1.0 100 + $ (renderSpan $ fr_span r) <> line + hPutStrLn fh $ "# Cost: " ++ (show cost) + displayIO fh $ renderPretty 1.0 100 + $ py fa mu r dope <> line + hPutStrLn fh "" + where + renderSpan (T.Span s e bs) = + T.prettyTerm s + <+> char '-' + <+> T.prettyTerm e + <+> colon + `above` (indent 2 (T.prettyTerm $ T.rendering s bs)) + + processFile fileName = do fh <- openFile (fileName ++ ".plan") WriteMode @@ -152,28 +183,35 @@ processFile_ fileName fh = do case pr of T.Failure td -> T.display td T.Success rs -> - let urs = map (\(P.LRule x T.:~ _) -> x) rs - anfs = map normRule urs + let urs = map (\(P.LRule x T.:~ _) -> x) rs + frs = map normRule urs + initializers = MA.mapMaybe (\(f,mca) -> (\(c,a) -> (f,c,a)) `fmap` mca) + $ map (\x -> (x, planInitializer x)) frs in do - aggm <- case buildAggMap anfs of -- only used for error checking? + aggm <- case buildAggMap frs of Left e -> throw $ TLEAggPlan e -- multiple aggregators Right a -> return a cPlans <- case combinePlans -- crux plans - $ map (\x -> (x, planEachEval headVar valVar x)) anfs of + $ map (\x -> (x, planEachEval headVar valVar x)) frs of Left e -> throw $ TLEUpdPlan e -- no plan found Right a -> return a forM_ (M.toList cPlans) $ \(fa, ps) -> do -- plans aggregated by functor/arity - hPutStrLn fh $ "\n# ==============" + hPutStrLn fh "" + hPutStrLn fh $ "# ==============" hPutStrLn fh $ "# " ++ show fa - forM_ ps $ \(r, cost, dope) -> do -- display plan - hPutStrLn fh $ "# --" - hPutStrLn fh $ "# Cost: " ++ (show cost) - displayIO fh $ renderPretty 1.0 100 - $ py fa r dope - hPutStrLn fh "" --- hPutStrLn fh "" + forM_ ps $ printPlan fh fa (Just (headVar,valVar)) + hPutStrLn fh "" + hPutStrLn fh $ "# ==============" + hPutStrLn fh $ "# Initializers" + forM_ initializers $ \(f,c,a) -> printPlan fh (findHeadFA f) Nothing (f,c,a) where + findHeadFA (FRule h _ _ _ _ (AS { as_unifs = us })) = + case M.lookup h us of + Nothing -> error "No unification for head variable?" + Just (Left _) -> error "NTVar head?" + Just (Right (f,a)) -> (f, length a) + headVar = "_h" valVar = "_v" diff --git a/src/Dyna/XXX/PPrint.hs b/src/Dyna/XXX/PPrint.hs index b6cb0ae..162f1b3 100644 --- a/src/Dyna/XXX/PPrint.hs +++ b/src/Dyna/XXX/PPrint.hs @@ -1,14 +1,28 @@ -- XXX contribute back to wl-pprint-extras module Dyna.XXX.PPrint ( - sepBy, valign + prefixSD, sepBy, valign ) where import qualified Data.Foldable as F import Text.PrettyPrint.Free +-- | encloseSep with empty enclosers sepBy :: Doc e -> [Doc e] -> Doc e sepBy = encloseSep empty empty valign :: F.Foldable f => f (Doc e) -> Doc e valign = align . vcat + +-- | Prefix all lines of a 'SimpleDoc' with a given string +prefixSD :: String -> SimpleDoc e -> SimpleDoc e +prefixSD p = pt . go + where + pt = SText (length p) p + + go SEmpty = SEmpty + go (SChar c s) = SChar c (go s) + go (SText i t s) = SText i t (go s) + go x@(SLine i SEmpty) = x + go (SLine i s) = (SLine i (pt $ go s)) + go (SEffect e s) = SEffect e (go s) -- 2.50.1