From 445ebb3fccf65ec14dc4e61df10fd46b5ec87ffd Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Mon, 17 Dec 2012 18:30:43 -0500 Subject: [PATCH] Rework rule planner to take modes from backend While here, factor out some material to Dyna.Analysis.Base, and execute a proof-of-concept change by adding true/0 and false/0 as constants which evaluate to True and False in the Python backend. Some other minor changes seem to have crept in, too. --- bin/defn.py | 3 + src/Dyna/Analysis/ANF.hs | 39 +---- src/Dyna/Analysis/Base.hs | 141 ++++++++++++++++++ src/Dyna/Analysis/RuleMode.hs | 265 ++++++++++++---------------------- src/Dyna/Backend/Python.hs | 106 +++++++++++--- src/Dyna/Main/Exception.hs | 6 +- 6 files changed, 332 insertions(+), 228 deletions(-) create mode 100644 src/Dyna/Analysis/Base.hs diff --git a/bin/defn.py b/bin/defn.py index ef1579b..df5e4b6 100644 --- a/bin/defn.py +++ b/bin/defn.py @@ -36,6 +36,9 @@ call = {'*/2': operator.mul, '|/1': lambda x,y: x or y, '&/2': lambda x,y: x and y, + 'true/0': lambda: True, + 'false/0': lambda: False, + # comparisons ' Pretty (NT v) where - pretty (NTNumeric (Left x)) = pretty x - pretty (NTNumeric (Right x)) = pretty x - pretty (NTString s) = dquotes (pretty s) - pretty (NTVar v) = pretty v - - --- | Normalized Term over 'DVar' (that is, either a primitive or a variable) -type NTV = NT DVar - --- | Flat Dyna Term (that is, a functor over variables) -type FDT = (DFunct,[DVar]) - --- | Either a variable or a functor of variables) -type EVF = Either DVar FDT - --- | Either a constant, another variable, or a flat Dyna term -type ENF = Either NTV FDT - data ANFState = AS { as_next :: !Int , as_evals :: M.Map DVar EVF @@ -230,8 +203,6 @@ dynaFunctorArgDispositions x = case x of -- XXX These should be read from declarations dynaFunctorSelfDispositions :: (DFunct,Int) -> SelfDispos dynaFunctorSelfDispositions x = case x of - ("true",0) -> SDQuote - ("false",0) -> SDQuote ("pair",2) -> SDQuote (name, _) -> -- If it starts with a nonalpha, it prefers to evaluate diff --git a/src/Dyna/Analysis/Base.hs b/src/Dyna/Analysis/Base.hs new file mode 100644 index 0000000..609927c --- /dev/null +++ b/src/Dyna/Analysis/Base.hs @@ -0,0 +1,141 @@ +--------------------------------------------------------------------------- +-- | Common, basic definitions of our Analysis modules +-- +-- Much of this is pending rework once we get to the mode system of Mercury. + +module Dyna.Analysis.Base ( + -- * Normalized Term Representations + NT(..), FDT, NTV, ENF, EVF, + + -- * Modes + Mode(..), Moded(..), modeOf, isBound, isFree, + ModedVar, varOfMV, ModedNT, evnOfMNT, ntvOfMNT, + + -- * DOpAMine + DOpAMine(..), + + -- * Determinism + Det(..), detOfDop, +) where + +import qualified Data.ByteString as B +import Dyna.Term.TTerm +import qualified Text.PrettyPrint.Free as PP + +------------------------------------------------------------------------}}} +-- Normalized Term Representations {{{ + +-- | A Normalized Term, parametric in the variable case +-- +-- The Ord instance is solely for Data.Set's use +data NT v = NTNumeric (Either Integer Double) + | NTString B.ByteString + | NTVar v + deriving (Eq,Ord,Show) + +instance (PP.Pretty v) => PP.Pretty (NT v) where + pretty (NTNumeric (Left x)) = PP.pretty x + pretty (NTNumeric (Right x)) = PP.pretty x + pretty (NTString s) = PP.dquotes (PP.pretty s) + pretty (NTVar v) = PP.pretty v + + +-- | Normalized Term over 'DVar' (that is, either a primitive or a variable) +type NTV = NT DVar + +-- | Flat Dyna Term (that is, a functor over variables) +type FDT = (DFunct,[DVar]) + +-- | Either a variable or a functor of variables) +type EVF = Either DVar FDT + +-- | Either a constant, another variable, or a flat Dyna term +type ENF = Either NTV FDT + +------------------------------------------------------------------------}}} +-- Modes {{{ + +data Mode = MBound | MFree deriving (Eq,Ord,Show) + + +data Moded v = MF DVar + | MB v + deriving (Eq,Ord,Show) + +modeOf :: Moded a -> Mode +modeOf (MF _) = MFree +modeOf (MB _) = MBound + +isBound, isFree :: Moded a -> Bool +isBound = (== MBound) . modeOf +isFree = (== MFree ) . modeOf + +type ModedVar = Moded DVar + +varOfMV :: ModedVar -> DVar +varOfMV (MF x) = x +varOfMV (MB x) = x + +type ModedNT = NT (ModedVar) + +evnOfMNT :: ModedNT -> Either DVar NTV +evnOfMNT (NTVar mv) = case mv of + MB v -> Right (NTVar v) + MF v -> Left v +evnOfMNT (NTString s) = Right (NTString s) +evnOfMNT (NTNumeric n) = Right (NTNumeric n) + +ntvOfMNT :: ModedNT -> NTV +ntvOfMNT (NTVar mx) = NTVar $ varOfMV mx +ntvOfMNT (NTString s) = NTString s +ntvOfMNT (NTNumeric n) = NTNumeric n + +------------------------------------------------------------------------}}} +-- DOpAMine {{{ + +-- | Dyna OPerational Abstract MachINE +-- +-- It makes us happy. + +-- Opcode Out In Ancillary +data DOpAMine fbs + = OPAsgn DVar NTV -- -+ + | OPCheq DVar DVar -- ++ + + -- | Check that two dvars are not equal. This is used to + -- prevent double-counting of hyper-edges when any of their + -- tails can be made to be the same item by specialization. + -- + -- XXX While inspired by Blatz & Eisner 2006, it's unclear + -- that this is actually what we should be doing. Oh well, + -- live and learn. + | OPCkne DVar DVar -- ++ + + | OPPeel [DVar] DVar DFunct -- -+ + | OPWrap DVar [DVar] DFunct -- -+ + + | OPIter (ModedVar) [ModedVar] DFunct -- ?? + Det + (Maybe fbs) + | OPIndr DVar DVar -- -+ + deriving (Eq,Ord,Show) + +------------------------------------------------------------------------}}} +-- Determinism {{{ + +data Det = Det -- ^ Exactly one answer + | DetSemi -- ^ At most one answer + | DetNon -- ^ Unknown number of answers + deriving (Eq,Ord,Show) + +detOfDop :: DOpAMine fbs -> Det +detOfDop x = case x of + OPAsgn _ _ -> Det + OPCheq _ _ -> DetSemi + OPCkne _ _ -> DetSemi + OPPeel _ _ _ -> DetSemi + OPWrap _ _ _ -> Det + OPIndr _ _ -> DetSemi + OPIter _ _ _ d _ -> d + +------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index a7e8697..3bd2d9d 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -15,8 +15,6 @@ module Dyna.Analysis.RuleMode ( Crux(..), - DOpAMine(..), detOfDop, - Action, Cost, Det(..), planInitializer, planEachEval, adornedQueries @@ -31,6 +29,7 @@ import qualified Data.Maybe as MA import qualified Data.Set as S import qualified Debug.Trace as XT import Dyna.Analysis.ANF +import Dyna.Analysis.Base import Dyna.Term.TTerm import Dyna.Main.Exception import qualified Dyna.ParserHS.Parser as DP @@ -40,56 +39,22 @@ import Dyna.XXX.TrifectaTest ------------------------------------------------------------------------}}} -- Modes {{{ -data Mode = MBound | MFree deriving (Eq,Ord,Show) - -- | What things have thus far been bound under the plan? type BindChart = S.Set DVar varMode :: BindChart -> DVar -> Mode varMode c v = if v `S.member` c then MBound else MFree -data Moded v = MF DVar - | MB v - deriving (Eq,Ord,Show) - -modeOf :: Moded a -> Mode -modeOf (MF _) = MFree -modeOf (MB _) = MBound - -isBound, isFree :: Moded a -> Bool -isBound = (== MBound) . modeOf -isFree = (== MFree ) . modeOf - -type ModedVar = Moded DVar - modedVar :: BindChart -> DVar -> ModedVar modedVar b x = case varMode b x of MBound -> MB x MFree -> MF x -varOfMV :: ModedVar -> DVar -varOfMV (MF x) = x -varOfMV (MB x) = x - -type ModedNT = NT (ModedVar) - modedNT :: BindChart -> NTV -> ModedNT modedNT b (NTVar v) = NTVar $ modedVar b v modedNT _ (NTString s) = NTString s modedNT _ (NTNumeric x) = NTNumeric x -evnOfMNT :: ModedNT -> Either DVar NTV -evnOfMNT (NTVar mv) = case mv of - MB v -> Right (NTVar v) - MF v -> Left v -evnOfMNT (NTString s) = Right (NTString s) -evnOfMNT (NTNumeric n) = Right (NTNumeric n) - -ntvOfMNT :: ModedNT -> NTV -ntvOfMNT (NTVar mx) = NTVar $ varOfMV mx -ntvOfMNT (NTString s) = NTString s -ntvOfMNT (NTNumeric n) = NTNumeric n - ------------------------------------------------------------------------}}} -- Cruxes {{{ @@ -124,77 +89,37 @@ cruxIsEval (CFEval _ _) = True cruxIsEval (CFCall _ _ _) = True cruxIsEval _ = False -------------------------------------------------------------------------}}} --- DOpAMine {{{ - --- | Dyna OPerational Abstract MachINE --- --- It makes us happy. - --- Opcode Out In Ancillary -data DOpAMine = OPAssign DVar NTV -- -+ - | OPCheck DVar DVar -- ++ - - -- | Check that two dvars are not equal. This is used to - -- prevent double-counting of hyper-edges when any of their - -- tails can be made to be the same item by specialization. - -- - -- XXX While inspired by Blatz & Eisner 2006, it's unclear - -- that this is actually what we should be doing. Oh well, - -- live and learn. - | OPCheckNE DVar DVar -- ++ - - | OPGetArgsIf [DVar] DVar DFunct -- -+ - | OPBuild DVar [DVar] DFunct -- -+ - - -- XXX OPCall and OPIter are actually the same thing, - -- in the end. OPCall is just the MF+[MB] variant - -- of OPIter; at the moment we use them to distinguish - -- builtins, but that's wrong. - | OPCall DVar [DVar] DFunct -- -+ - | OPIter (ModedVar) [ModedVar] DFunct -- ?? - | OPIndirEval DVar DVar -- -+ - deriving (Eq,Ord,Show) - -data Det = Det -- ^ Exactly one answer - | DetSemi -- ^ At most one answer - | DetNon -- ^ Unknown number of answers - deriving (Eq,Ord,Show) - -detOfDop :: DOpAMine -> Det -detOfDop x = case x of - OPAssign _ _ -> Det - OPCheck _ _ -> DetSemi - OPCheckNE _ _ -> DetSemi - OPGetArgsIf _ _ _ -> DetSemi - OPBuild _ _ _ -> Det - OPIndirEval _ _ -> DetSemi - OPCall _ _ _ -> Det - OPIter o is _ -> -- XXX - case (modeOf o, foldr min MBound (map modeOf is)) of - (_, MBound) -> DetSemi - _ -> DetNon - ------------------------------------------------------------------------}}} -- Actions {{{ -type Action = [DOpAMine] +type Action fbs = [DOpAMine fbs] --- XXX we shouldn't need to know this --- --- XXX please observe duplication of knowledge with --- Dyna.Analysis.ANF.dynaFunctorArgDispositions +-- XXX Is this really the right type? Maybe we'd rather that this be a +-- function rather than a map? -- --- XXX Also cross-reference python backend -isMath f = f `elem` [ "^", "+", "-", "*", "/", "&", "|", "~" - , "%", "**", "<", ">", "<<", ">>" - , "log", "exp", "and", "or", "not"] - --- XXX This function really ought to be generated from some declarations in --- the source program, rather than hard-coded in quite the way it is. --- Maybe the knowledge of unification is OK. -possible :: Crux (ModedVar) (ModedNT) -> [Action] -possible cr = case cr of +-- Note that there's a big wad of complexity here: we want to announce, for +-- example, that predicates may support generation (full-minus moding) but +-- that they can take bound variables, or that some predicates may insist +-- upon being run in mode minus, necessitating the insertion of checks. +-- (Primitives, unfortunately, fall into the latter category! We have to +-- run +/2 and then check the output, for example). Right now, the backend +-- is responsible for dealing with the check insertions. That might be +-- wrong. +type BackendPossible fbs = (DFunct,[Mode],Mode) -> Either Bool (Det,fbs) + +type Possible fbs = Crux (ModedVar) (ModedNT) -> [Action fbs] + +{- +mapMaybeModeCompat mis mo = + MA.mapMaybe (\(is',o',d,f) -> do + guard $ modeOf mo <= o' + && length mis == length is' + && and (zipWith (\x y -> modeOf x <= y) mis is') + return (d,f)) +-} + +possible :: BackendPossible fbs -> Possible fbs +possible fp cr = case cr of -- XXX Indirect evaluation is not yet supported CFEval _ _ -> [] @@ -203,10 +128,10 @@ possible cr = case cr of case (evnOfMNT i, o) of (Left _, MF _) -> [] (Right _, MB o') -> let chk = "_chk" in - [[ OPAssign chk ni - , OPCheck chk o']] - (Left i', MB o') -> [[OPAssign i' (NTVar o')]] - (Right _, MF o') -> [[OPAssign o' ni]] + [[ OPAsgn chk ni + , OPCheq chk o']] + (Left i', MB o') -> [[OPAsgn i' (NTVar o')]] + (Right _, MF o') -> [[OPAsgn o' ni]] -- Structure building CFStruct o is funct -> @@ -214,12 +139,12 @@ possible cr = case cr of -- If the output is free, the only supported case is when all -- inputs are known. MF o' -> if all isBound is - then [[OPBuild o' (map varOfMV is) funct]] + then [[OPWrap o' (map varOfMV is) funct]] else [] -- On the other hand, if the output is known, then any subset -- of the inputs may be known and will be checked. - MB o' -> [ (OPGetArgsIf is' o' funct) - : map (\(c,x) -> (OPCheck c x)) cis + MB o' -> [ (OPPeel is' o' funct) + : map (\(c,x) -> (OPCheq c x)) cis ] where mkChks _ (MF i) = (i, Nothing) @@ -231,28 +156,17 @@ possible cr = case cr of -- Unification CFUnif (MF _) (MF _) -> [] - CFUnif (MB x) (MB y) -> [[OPCheck x y]] - CFUnif (MB x) (MF y) -> [[OPAssign y (NTVar x)]] - CFUnif (MF y) (MB x) -> [[OPAssign y (NTVar x)]] - - -- Backward-chainable mathematics (this is such a hack XXX) - CFCall o is funct | isMath funct -> - if not $ all isBound is - then inv funct is o - else let is' = map varOfMV is in - case o of - MF o' -> [[OPCall o' is' funct]] - MB o' -> let cv = "_chk" - in [[OPCall cv is' funct - ,OPCheck cv o' - ]] - - -- Otherwise, we assume it's an extensional table and ask to iterate - -- over it. - CFCall o is funct | otherwise -> [[OPIter o is funct]] + CFUnif (MB x) (MB y) -> [[OPCheq x y]] + CFUnif (MB x) (MF y) -> [[OPAsgn y (NTVar x)]] + CFUnif (MF y) (MB x) -> [[OPAsgn y (NTVar x)]] - where + CFCall o is funct -> case fp (funct,map modeOf is, modeOf o) of + Left False -> [[OPIter o is funct DetNon Nothing ]] + Left True -> [] + Right (d,f) -> [[OPIter o is funct d (Just f)]] + where +{- -- XXX this really ought to be done some other way inv :: DFunct -> [ModedVar] -> ModedVar -> [Action] inv "+" [(MB x), (MF y)] (MB o) @@ -268,6 +182,7 @@ possible cr = case cr of = [[ OPCall x [o,y] "+" ]] inv _ _ _ = [] +-} ------------------------------------------------------------------------}}} -- ANF to Cruxes {{{ @@ -298,48 +213,51 @@ type Cost = Double -- XXX I don't understand why this heuristic works, but it seems to exclude -- some of the... less intelligent plans. -simpleCost :: PartialPlan -> Action -> Cost +simpleCost :: PartialPlan fbs -> Action fbs -> Cost simpleCost (PP { pp_score = osc, pp_plan = pfx }) act = 2 * osc + (1 + loops pfx) * actCost act where actCost = sum . map stepCost - stepCost :: DOpAMine -> Double + stepCost :: DOpAMine fbs -> Double stepCost x = case x of - OPAssign _ _ -> 1 - OPCheck _ _ -> -1 -- Checks are issued with Assigns, so + OPAsgn _ _ -> 1 + OPCheq _ _ -> -1 -- Checks are issued with Assigns, so -- counter-act the cost to encourage them -- to be earlier in the plan. - OPCheckNE _ _ -> 0 - OPGetArgsIf _ _ _ -> 0 - OPBuild _ _ _ -> 1 -- Upweight building due to side-effects + OPCkne _ _ -> 0 + OPPeel _ _ _ -> 0 + OPWrap _ _ _ -> 1 -- Upweight building due to side-effects -- in the intern table - OPCall _ _ _ -> 0 - OPIter o is _ -> 2 ** (fromIntegral $ length $ filter isFree (o:is)) - - 1 - OPIndirEval _ _ -> 100 + OPIter o is _ d _ -> case d of + Det -> 0 + DetSemi -> 1 + DetNon -> 2 ** (fromIntegral $ length $ + filter isFree (o:is)) + - 1 + OPIndr _ _ -> 100 loops = fromIntegral . length . filter isLoop - isLoop :: DOpAMine -> Bool + isLoop :: DOpAMine fbs -> Bool isLoop = (== DetNon) . detOfDop ------------------------------------------------------------------------}}} -- Planning {{{ -data PartialPlan = PP { pp_cruxes :: S.Set (Crux DVar NTV) - , pp_binds :: BindChart - , pp_restrictSearch :: Bool - , pp_score :: Cost - , pp_plan :: Action - } +data PartialPlan fbs = PP { pp_cruxes :: S.Set (Crux DVar NTV) + , pp_binds :: BindChart + , pp_restrictSearch :: Bool + , pp_score :: Cost + , pp_plan :: Action fbs + } stepPartialPlan :: -- | Possible actions - (Crux (ModedVar) (ModedNT) -> [Action]) + Possible fbs -- | Plan scoring function - -> (PartialPlan -> Action -> Cost) + -> (PartialPlan fbs -> Action fbs -> Cost) -- | The 'DFunctAr', intern representation, and -- result variable of the @@ -351,8 +269,8 @@ stepPartialPlan :: -- a given crux is "before" or "after" the initial one -- in this ordering. -> Maybe (DFunctAr, DVar, DVar) - -> PartialPlan - -> Either (Cost, Action) [PartialPlan] + -> PartialPlan fbs + -> Either (Cost, Action fbs) [PartialPlan fbs] stepPartialPlan steps score mic p = if S.null (pp_cruxes p) then Left $ (pp_score p, pp_plan p) @@ -392,13 +310,13 @@ stepPartialPlan steps score mic p = Nothing -> id Just ((f,a),i,ov) -> concatMap $ \dop -> case dop of - OPIter ov' ivs' f' | f' == f + OPIter ov' ivs' f' _ _ | f' == f && length ivs' == a && ov > varOfMV ov' -> let cv = "_chk" in [ dop - , OPBuild cv (map varOfMV ivs') f' - , OPCheckNE i cv + , OPWrap cv (map varOfMV ivs') f' + , OPCkne i cv ] _ -> [dop] @@ -413,23 +331,23 @@ stepAgenda st sc mic = go [] . (\x -> [x]) -- XXX we're going to need to initially plan a unification crux as part of -- backward chaining, but we don't yet. initializeForCrux :: (Crux DVar a, DVar, DVar) - -> ((DFunctAr, DVar, DVar), Action) + -> ((DFunctAr, DVar, DVar), Action fbs) initializeForCrux (cr, hi, v) = case cr of CFCall o is f -> ( ((f,length is), hi, o) - , [ OPGetArgsIf is hi f, OPAssign o (NTVar v) ]) - _ -> sorryDynac "Don't know how to initially plan !CFCall" + , [ OPPeel is hi f, OPAsgn o (NTVar v) ]) + _ -> dynacSorry "Don't know how to initially plan !CFCall" -- | Given a normalized form and an initial crux, saturate the graph and -- get a plan for doing so. -- -- 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 +plan_ :: Possible fbs -- ^ Available steps + -> (PartialPlan fbs -> Action fbs -> Cost) -- ^ Scoring function -> ANFState -- ^ Normal form -> Maybe (Crux DVar NTV, DVar, DVar) -- ^ Initial crux, -- item intern, and -- value, if any. - -> [(Cost, Action)] -- ^ If there's a plan... + -> [(Cost, Action fbs)] -- ^ If there's a plan... plan_ st sc anf mi = let cruxes = eval_cruxes anf ++ unif_cruxes anf @@ -443,25 +361,28 @@ plan_ st sc anf mi = } in stepAgenda st sc mic initPlan -plan :: (Crux (ModedVar) (ModedNT) -> [Action]) - -> (PartialPlan -> Action -> Cost) +plan :: Possible fbs + -> (PartialPlan fbs -> Action fbs -> Cost) -> ANFState -> Maybe (Crux DVar NTV, DVar, DVar) - -> Maybe (Cost, Action) + -> Maybe (Cost, Action fbs) plan st sc anf mi = (\x -> case x of [] -> Nothing plans -> Just $ argmin fst plans) $ plan_ st sc anf mi -planInitializer :: FRule -> Maybe (Cost,Action) -planInitializer (FRule { fr_anf = anf }) = plan possible simpleCost anf Nothing +planInitializer :: BackendPossible fbs -> FRule -> Maybe (Cost,Action fbs) +planInitializer bp (FRule { fr_anf = anf }) = plan (possible bp) + 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 $ Just (c,hi,v))) +planEachEval :: BackendPossible fbs + -> S.Set DFunctAr + -> DVar -> DVar -> FRule -> [(DFunctAr, Maybe (Cost,Action fbs))] +planEachEval bp cs hi v (FRule { fr_anf = anf }) = + map (\(c,fa) -> (fa, plan (possible bp) simpleCost anf $ Just (c,hi,v))) $ MA.mapMaybe (\c -> case c of - CFCall _ is f | not $ isMath f + CFCall _ is f | S.notMember (f,length is) cs -> Just $ (c,(f,length is)) _ -> Nothing ) $ eval_cruxes anf @@ -471,11 +392,11 @@ planEachEval hi v (FRule { fr_anf = anf }) = -- XXX We really ought to be returning something about math, as well, but -- as all that's handled specially up here... -adornedQueries :: Action -> S.Set (DFunct,[Mode],Mode) +adornedQueries :: Action fbs -> S.Set (DFunct,[Mode],Mode) adornedQueries = go S.empty where go x [] = x - go x ((OPIter o is f):as) = + go x ((OPIter o is f _ _):as) = go (x `S.union` S.singleton (f, map modeOf is, modeOf o)) as go x (_:as) = go x as @@ -495,6 +416,7 @@ ntMode _ (NTString _) = MBound ntMode _ (NTNumeric _) = MBound -} +{- planEachEval_ hi v (FRule { fr_anf = anf }) = map (\(c,fa) -> (fa, plan_ possible simpleCost anf $ Just (c,hi,v))) $ MA.mapMaybe (\c -> case c of @@ -516,5 +438,6 @@ run = mapM_ (\(c,msp) -> do forM_ p (putStrLn . show) putStrLn "") . testPlanRule +-} ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Backend/Python.hs b/src/Dyna/Backend/Python.hs index f32eea6..fe2604a 100644 --- a/src/Dyna/Backend/Python.hs +++ b/src/Dyna/Backend/Python.hs @@ -23,6 +23,7 @@ import qualified Data.Ord as O import qualified Data.Set as S import qualified Debug.Trace as XT import Dyna.Analysis.ANF +import Dyna.Analysis.Base import Dyna.Analysis.Aggregation import Dyna.Analysis.RuleMode import Dyna.Main.Exception @@ -35,17 +36,73 @@ import System.IO import Text.PrettyPrint.Free import qualified Text.Trifecta as T - +------------------------------------------------------------------------}}} +-- DOpAMine Backend Information {{{ + +constants = S.fromList + [ ("+",2) + , ("-",2) + , ("*",2) + , ("/",2) + , ("^",2) + , ("&",2) + , ("|",2) + , ("%",2) + , ("**",2) + , ("<",2) + , (">",2) + , ("<<",2) + , (">>",2) + , ("~",2) + , ("log",1) + , ("exp",1) + , ("and",2) + , ("or",2) + , ("not",1) + , ("true",0) + ] + +data PyDopeBS = PDBAsIs + | PDBRewrite (([ModedVar],ModedVar) -> [DOpAMine PyDopeBS]) + +builtin (f,is,o) = case () of + _ | all (== MBound) is && S.member (f,length is) constants + -> case o of + MFree -> Right (Det,PDBAsIs) + MBound -> Right (DetSemi, + PDBRewrite $ \(is,o) -> let chkv = "_chk" in + [ OPIter (MF chkv) is f Det $ Just PDBAsIs + , OPCheq chkv (varOfMV o) + ]) + + _ | f == "+" + -> case (is,o) of + ([MBound,MFree],MBound) -> Right (Det, + PDBRewrite $ \([x,y],o) -> [OPIter y [o,x] "-" Det $ Just PDBAsIs]) + ([MFree,MBound],MBound) -> Right (Det, + PDBRewrite $ \([x,y],o) -> [OPIter x [o,y] "-" Det $ Just PDBAsIs]) + _ -> Left True + + _ | f == "-" + -> case (is,o) of + ([MBound,MFree],MBound) -> Right (Det, + PDBRewrite $ \([x,y],o) -> [OPIter y [x,o] "-" Det $ Just PDBAsIs]) + ([MFree,MBound],MBound) -> Right (Det, + PDBRewrite $ \([x,y],o) -> [OPIter x [o,y] "+" Det $ Just PDBAsIs]) + _ -> Left True + + _ | S.member (f,length is) constants -> Left True + _ -> Left False ------------------------------------------------------------------------}}} -- DOpAMine Printout {{{ -pdope :: DOpAMine -> Doc e -pdope (OPIndirEval _ _) = error "indirect evaluation not implemented" -pdope (OPAssign v val) = pretty v <+> equals <+> pretty val -pdope (OPCheck v val) = "if" <+> pretty v <+> "!=" <+> pretty val <> ": continue" -pdope (OPCheckNE v val) = "if" <+> pretty v <+> "==" <+> pretty val <> ": continue" -pdope (OPGetArgsIf vs id f) = +pdope :: DOpAMine PyDopeBS -> Either [DOpAMine PyDopeBS] (Doc e) +pdope (OPIndr _ _) = dynacSorry "indirect evaluation not implemented" +pdope (OPAsgn v val) = Right $ pretty v <+> equals <+> pretty val +pdope (OPCheq v val) = Right $ "if" <+> pretty v <+> "!=" <+> pretty val <> ": continue" +pdope (OPCkne v val) = Right $ "if" <+> pretty v <+> "==" <+> pretty val <> ": continue" +pdope (OPPeel vs id f) = Right $ "try:" `above` (indent 4 $ tupledOrUnderscore vs @@ -56,14 +113,20 @@ pdope (OPGetArgsIf vs id f) = `above` "except (TypeError, AssertionError): continue" -- you'll get a "TypeError: 'NoneType' is not iterable." -pdope (OPBuild v vs f) = pretty v <+> equals +pdope (OPWrap v vs f) = Right $ pretty v <+> equals <+> "build" <> (parens $ fa f vs <> comma <> (sepBy "," $ map pretty vs)) -pdope (OPCall v vs f) = pretty v <+> equals - <+> functorIndirect "call" f vs - <> (tupled $ map pretty vs) +pdope (OPIter v vs f _ (Just b)) = + case b of + PDBAsIs -> Right $ pretty (varOfMV v) + <+> equals + <+> functorIndirect "call" f vs + <> (tupled $ map (pretty . varOfMV) vs) + + PDBRewrite rf -> Left $ rf (vs,v) + -pdope (OPIter o m f) = +pdope (OPIter o m f _ Nothing) = Right $ let mo = m ++ [o] in "for" <+> (tupledOrUnderscore $ filterBound mo) <+> "in" <+> functorIndirect "chart" f m <> pslice mo <> colon @@ -94,8 +157,8 @@ pf f vs = pretty f <> (tupled $ map pretty vs) -- -- timv: might want to fuse these into one circuit -- -combinePlans :: [(FRule,[(DFunctAr, Maybe (Cost,Action))])] -> - M.Map DFunctAr [(FRule, Cost, Action)] +combinePlans :: [(FRule,[(DFunctAr, Maybe (Cost,Action fbs))])] -> + M.Map DFunctAr [(FRule, Cost, Action fbs)] combinePlans = go (M.empty) where go m [] = m @@ -129,10 +192,13 @@ py (f,a) mu (FRule h _ _ r span _) dope = pretty f <> "/" <> (text $ show a)) go [] = id - go (x:xs) = let px = pdope x - indents = case x of OPIter _ _ _ -> True ; _ -> False + go (x:xs) = let indents = case x of OPIter _ _ _ d _ -> d /= Det ; _ -> False in - above px . (if indents then indent 4 else id) . go xs + case pdope x of + Left rw -> go (rw++xs) + Right px -> above px + . (if indents then indent 4 else id) + . go xs emit = "emit" <> tupled [pretty h, pretty r] @@ -140,7 +206,7 @@ py (f,a) mu (FRule h _ _ r span _) dope = printPlan :: Handle -> (DFunct,Int) -- ^ Functor & arity -> Maybe (DVar,DVar) -- ^ if update, input intern & value - -> (FRule, Cost, Action) -- ^ rule and plan + -> (FRule, Cost, Action PyDopeBS) -- ^ rule and plan -> IO () printPlan fh fa mu (r, cost, dope) = do -- display plan hPutStrLn fh $ "# --" @@ -167,7 +233,7 @@ processFile_ fileName fh = do 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 + $ map (\x -> (x, planInitializer builtin x)) frs in do aggm <- case buildAggMap frs of Left e -> throw $ UserProgramError (text e) @@ -180,7 +246,7 @@ processFile_ fileName fh = do } cPlans <- return $! combinePlans -- crux plans - $ map (\x -> (x, planEachEval headVar valVar x)) frs + $ map (\x -> (x, planEachEval builtin constants headVar valVar x)) frs forM_ (M.toList cPlans) $ \(fa, ps) -> do -- plans aggregated by functor/arity hPutStrLn fh "" hPutStrLn fh $ "# ==============" diff --git a/src/Dyna/Main/Exception.hs b/src/Dyna/Main/Exception.hs index d6d3eda..b40ad68 100644 --- a/src/Dyna/Main/Exception.hs +++ b/src/Dyna/Main/Exception.hs @@ -34,9 +34,9 @@ instance Exception DynacException ------------------------------------------------------------------------}}} -- Utilities {{{ -throwDynac :: DynacException -> a -throwDynac = throw +dynacThrow :: DynacException -> a +dynacThrow = throw -sorryDynac = throw . Sorry +dynacSorry = throw . Sorry ------------------------------------------------------------------------}}} -- 2.50.1