From 591944b8cf1a3a01c7776c166ceb26fefe33aced Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Thu, 6 Jun 2013 02:06:30 -0400 Subject: [PATCH] Tweaks to the planner Mostly cosmetic changes, but of note: The planner now uses the alias-tracking contexts for mode analysis (though it does not actually yet do anything with this power; this change is in preparation for backward-chaining) DOpAMine unifications are now tagged with determinisim information, again in preparation for future work; these are all currently set to DetNon. DOpAMine and Python OPEmit printout is much more vertically compact. --- src/Dyna/Analysis/DOpAMine.hs | 20 ++++++----- src/Dyna/Analysis/RuleMode.hs | 56 ++++++++++++++---------------- src/Dyna/Backend/NoBackend.hs | 7 ++-- src/Dyna/Backend/Python/Backend.hs | 4 +-- src/Dyna/XXX/PPrint.hs | 15 ++++++-- 5 files changed, 59 insertions(+), 43 deletions(-) diff --git a/src/Dyna/Analysis/DOpAMine.hs b/src/Dyna/Analysis/DOpAMine.hs index 0d4f681..5e79be4 100644 --- a/src/Dyna/Analysis/DOpAMine.hs +++ b/src/Dyna/Analysis/DOpAMine.hs @@ -14,6 +14,7 @@ import Dyna.Analysis.Mode.Execution.NamedInst import Dyna.Main.Defns import Dyna.Term.Normalized import Dyna.Term.TTerm +import Dyna.XXX.PPrint import Text.PrettyPrint.Free ------------------------------------------------------------------------}}} @@ -51,7 +52,7 @@ data DOpAMine bscg -- | Check that the input dvar is an interned representation -- of the given functor (and arity as computed from the list -- length) and if so, unpack its arguments into those dvars. - | OPPeel [DVar] DVar DFunct -- -+ + | OPPeel [DVar] DVar DFunct Det -- -+ -- | The reverse of OPPeel | OPWrap DVar [DVar] DFunct -- -+ @@ -105,7 +106,7 @@ detOfDop x = case x of OPAsgn _ _ -> Det OPCheq _ _ -> DetSemi OPCkne _ _ -> DetSemi - OPPeel _ _ _ -> DetSemi + OPPeel _ _ _ d -> d OPWrap _ _ _ -> Det OPIndr _ _ -> DetSemi OPIter _ _ _ d _ -> d @@ -131,8 +132,10 @@ renderDOpAMine = r r _ (OPCheq a b) = text "OPCheq" <+> pretty a <+> pretty b r _ (OPCkne a b) = text "OPCkne" <+> pretty a <+> pretty b r _ (OPIndr a b) = text "OPIndr" <+> pretty a <+> pretty b - r _ (OPPeel vs v f) = text "OPPeel" <+> pretty vs - <+> pretty v <+> pretty f + r _ (OPPeel vs v f d) = text "OPPeel" <+> pretty vs + <+> pretty v + <+> pretty f + <+> text (show d) r _ (OPWrap v vs f) = text "OPWrap" <+> pretty v <+> pretty vs <+> pretty f r e (OPIter v vs f d b) = text "OPIter" @@ -143,9 +146,10 @@ renderDOpAMine = r <> maybe empty ((space <>) . braces . e v vs f d) b - r _ (OPEmit h v i vs) = text "OPEmit" <+> pretty h - <+> pretty v - <+> pretty i - <+> pretty vs + r _ (OPEmit h v i vs) = text "OPEmit" + <+> pretty h + <+> pretty v + <+> pretty i + <+> fillList (map pretty vs) ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index f944208..834ef2e 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -52,8 +52,8 @@ import Dyna.Analysis.ANF import Dyna.Analysis.ANFPretty import Dyna.Analysis.DOpAMine import Dyna.Analysis.Mode -import Dyna.Analysis.Mode.Execution.ContextNoAlias -import Dyna.Analysis.Mode.Execution.FunctionsNoAlias +import Dyna.Analysis.Mode.Execution.Context +import Dyna.Analysis.Mode.Execution.Functions import Dyna.Term.TTerm import Dyna.Term.Normalized import Dyna.Main.Exception @@ -137,7 +137,10 @@ mapMaybeModeCompat mis mo = -- | Free, Ground, or Neither. A rather simplistic take on unification. -- -- XXX There is nothing good about this. -fgn :: forall a m . (Monad m, MCVT m DVar ~ VR DFunct (NIX DFunct), MCR m DVar) +fgn :: forall a m k . + (Monad m, Functor m, + MCVT m k ~ ENKRI DFunct (NIX DFunct) k, MCR m k, + MCVT m DVar ~ VR DFunct (NIX DFunct) k, MCR m DVar) => DVar -> m a -> m a -> m a -> m a fgn v cf cg cn = do ff <- v `subVN` (nHide IFree) @@ -193,7 +196,8 @@ possible fp cr = (is', mcis) <- zipWithM maybeCheck is newvars >>= return . unzip let cis = MA.catMaybes mcis mapM_ bind is - return ([ OPPeel is' o funct ] ++ map (uncurry OPCheq) cis) + return ([ OPPeel is' o funct DetSemi ] + ++ map (uncurry OPCheq) cis) newvars = map (\n -> BC.pack $ "_chk_" ++ (show n)) [0::Int ..] @@ -261,7 +265,7 @@ simpleCost (PP { pp_score = osc, pp_plan = pfx }) act = -- counter-act the cost to encourage them -- to be earlier in the plan. OPCkne _ _ -> 0 - OPPeel _ _ _ -> 0 + OPPeel _ _ _ _ -> 0 OPWrap _ _ _ -> 1 -- Upweight building due to side-effects -- in the intern table OPIter o is _ d _ -> case d of @@ -290,7 +294,6 @@ simpleCost (PP { pp_score = osc, pp_plan = pfx }) act = data PartialPlan fbs = PP { pp_cruxes :: S.Set (Crux DVar TBase) , pp_binds :: BindChart - , pp_restrictSearch :: Bool , pp_score :: Cost , pp_plan :: Actions fbs } @@ -310,36 +313,32 @@ stepPartialPlan :: (Crux DVar TBase -> SIMCT Identity DFunct (Actions fbs)) stepPartialPlan poss score p = {- XT.trace ("SPP:\n" ++ " " ++ show (pp_cruxes p) ++ "\n" - ++ " " ++ show (pp_binds p) ++ "\n" + ++ show (indent 2 $ pretty $ pp_binds p) ++ "\n" ) $ -} if S.null (pp_cruxes p) then Left $ (pp_score p, pp_plan p) else Right $ let rc = pp_cruxes p - in if pp_restrictSearch p - -- XXX I am not sure this is right - -- - -- force consideration of non-evaluation cruxes if - -- any nonevaluation crux has a possible move. - -- If a non-evaluation plan exists, commit to its - -- cheapest choice as the only option here. - -- - -- This prevents us from considering the multitude - -- stupid plans that begin by evaluating when they - -- don't have to. - then case step (S.filter (not . cruxIsEval) rc) of - [] -> step (S.filter cruxIsEval rc) - xs -> [argmin (flip score []) xs] - else step rc + -- XXX I am not sure this is right + -- + -- force consideration of non-evaluation cruxes if + -- any nonevaluation crux has a possible move. + -- If a non-evaluation plan exists, commit to its + -- cheapest choice as the only option here. + -- + -- This prevents us from considering the multitude + -- stupid plans that begin by evaluating when they + -- don't have to. + in case step (S.filter (not . cruxIsEval) rc) of + [] -> step (S.filter cruxIsEval rc) + xs -> [argmin (flip score []) xs] where step = S.fold (\crux ps -> - let bc = pp_binds p - pl = pp_plan p - plan = runIdentity $ runSIMCT (poss crux) bc + let pl = pp_plan p + plan = runIdentity $ runSIMCT (poss crux) (pp_binds p) rc' = S.delete crux (pp_cruxes p) - r' = (not $ cruxIsEval crux) || (pp_restrictSearch p) in either (const ps) - (\(act,bc') -> PP rc' bc' r' (score p act) (pl ++ act) + (\(act,bc') -> PP rc' bc' (score p act) (pl ++ act) : ps) plan ) [] @@ -362,7 +361,6 @@ planner_ :: (Crux DVar TBase -> SIMCT Identity DFunct (Actions fbs)) planner_ st sc cr mic ictx = runAgenda $ PP { pp_cruxes = cr , pp_binds = ctx' - , pp_restrictSearch = False , pp_score = 0 , pp_plan = ip } @@ -390,7 +388,7 @@ planner_ st sc cr mic ictx = runAgenda -- XREF:INITPLAN (ip,bis) = case mic of Nothing -> ([],[]) - Just (CCall o is f, hi, ho) -> ( [ OPPeel is hi f + Just (CCall o is f, hi, ho) -> ( [ OPPeel is hi f DetSemi , OPAsgn o (NTVar ho)] , o:is) Just (CEval o i, hi, ho) -> ( [ OPAsgn i (NTVar hi) diff --git a/src/Dyna/Backend/NoBackend.hs b/src/Dyna/Backend/NoBackend.hs index 7f3149f..5c8f2a5 100644 --- a/src/Dyna/Backend/NoBackend.hs +++ b/src/Dyna/Backend/NoBackend.hs @@ -3,12 +3,15 @@ -- -- It is anticipated that this will be useful for debugging the earlier -- stages of the compiler. +-- +-- XXX Add a self-test that all primOps modes are supported by other +-- backends. -- Header material {{{ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} -module Dyna.Backend.NoBackend (noBackend) where +module Dyna.Backend.NoBackend (noBackend, primPossible) where import Control.Lens import Control.Monad @@ -97,7 +100,7 @@ primPossible (f,mvis,mvo) = maybe (Left False) go $ primOps (f,length mvis) go [] = Left True go (x:xs) = -- XT.traceShow ("PRIMPOSS",mvis,mvo,x) $ if and (zipWithTails nSub p p qim pim) - then Right $ BAct [OPIter mvo mvis f DetNon (Just ())] qom + then Right $ BAct [OPIter mvo mvis f (x^.qmode_det) (Just ())] qom else go xs where mvs = mvo:mvis diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs index 380919f..3fe23fd 100644 --- a/src/Dyna/Backend/Python/Backend.hs +++ b/src/Dyna/Backend/Python/Backend.hs @@ -202,7 +202,7 @@ pdope_ (OPCheq v val) = return $ "if" <+> pretty v <+> "!=" <+> pretty val <> ": continue" pdope_ (OPCkne v val) = return $ "if" <+> pretty v <+> "==" <+> pretty val <> ": continue" -pdope_ (OPPeel vs i f) = return $ +pdope_ (OPPeel vs i f _) = return $ --"try:" `above` (indent 4 $ tupledOrUnderscore vs <+> equals @@ -233,7 +233,7 @@ pdope_ (OPEmit h r i vs) = do ds <- get -- A python map of variable name to value - let varmap = encloseSep lbrace rbrace comma $ + let varmap = braces $ align $ fillPunct (comma <> space) $ ("'nodes'" <> colon <> (encloseSep lbracket rbracket comma $ map (("d"<>).pretty) [0..ds-1])) : (map (\v -> let v' = pretty v in dquotes v' <> colon <+> v') vs) diff --git a/src/Dyna/XXX/PPrint.hs b/src/Dyna/XXX/PPrint.hs index 162f1b3..85ef0e5 100644 --- a/src/Dyna/XXX/PPrint.hs +++ b/src/Dyna/XXX/PPrint.hs @@ -1,19 +1,30 @@ -- XXX contribute back to wl-pprint-extras module Dyna.XXX.PPrint ( - prefixSD, sepBy, valign + fillList, fillPunct, prefixSD, sepBy, valign ) where import qualified Data.Foldable as F +import qualified Data.Traversable as T import Text.PrettyPrint.Free -- | encloseSep with empty enclosers sepBy :: Doc e -> [Doc e] -> Doc e sepBy = encloseSep empty empty +-- | Align and vcat valign :: F.Foldable f => f (Doc e) -> Doc e valign = align . vcat +-- | Punctuate and fill out the ribbon. You almost assuredly want to use +-- 'align' or 'hang' with this. +fillPunct :: (T.Traversable f) => Doc e -> f (Doc e) -> Doc e +fillPunct p l = fillCat (punctuate p l) + +-- | Like 'fillPunct' but add list framing and commas and 'align'ment. +fillList :: (T.Traversable f) => f (Doc e) -> Doc e +fillList = brackets . align . fillPunct (comma <> space) + -- | Prefix all lines of a 'SimpleDoc' with a given string prefixSD :: String -> SimpleDoc e -> SimpleDoc e prefixSD p = pt . go @@ -23,6 +34,6 @@ prefixSD p = pt . go 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 x@(SLine _ SEmpty) = x go (SLine i s) = (SLine i (pt $ go s)) go (SEffect e s) = SEffect e (go s) -- 2.50.1