# -*- indent-tabs-mode:t; -*-
-all: deps
+all: build
upstream:
git submodule init
.PHONY: clean veryclean
clean:
- rm -rf examples/*.dyna.plan examples/*.dyna.d
+ rm -rf examples/*.dyna.plan \
+ examples/*.dyna.*.out \
+ examples/*.dyna.d
veryclean: clean
rm -rf dist
-- unless explicitly evaluated, or 3) prefer to be evaluated unless
-- explicitly quoted.
--
--- In short, explicit marks are always obeyed; absent one, the functor's
--- self disposition is obeyed; if the functor has no preference, the outer
--- functor's argument disposition is used as a last resort. There is,
--- however, one important caveat: /variables/ and /primitive terms/ (e.g.
--- numerics, strings, literal dynabases, foreign terms, ...) have self
--- dispositions of preferring structural interpretation. Variables may be
--- meaningfully explicitly evaluated, with the effect of evaluating their
--- bindings. Attempting to evaluate a primitive is an error.
+-- In short, explicit marks ('ECExplicit') are always obeyed; absent one,
+-- ('ECFunctor') the functor's self disposition ('SDQuote' or 'SDEval') is
+-- obeyed; if the functor has no preference ('SDInherit'), the outer
+-- functor's argument disposition is used as a last resort ('ADQuote' or
+-- 'ADEval'). There is, however, one important caveat: /variables/ and
+-- /primitive terms/ (e.g. numerics, strings, literal dynabases, foreign
+-- terms, ...) have self dispositions of preferring structural
+-- interpretation. Variables may be meaningfully explicitly evaluated, with
+-- the effect of evaluating their bindings. Attempting to evaluate a
+-- primitive is an error.
--
-- Note that in rules, the head is by default not evaluated (regardless of
-- the disposition of their outer functor), while the body is interpreted as
-- FIXME: "str" is the same a constant str.
--- TODO: ANF Normalizer should return *flat terms* so that we have type-safety
--- can a lint checker can verify we have exhaustive pattern matching... etc.
-
-- timv: should there ever be more than one side condition? shouldn't it be
-- a single result variable after normalization? I see that if I use comma
-- to combine my conditions I get mutliple variables but should side
("and", 2) -> [ADEval, ADEval]
("or", 2) -> [ADEval, ADEval]
("not", 1) -> [ADEval]
+ ("=",2) -> [ADQuote,ADQuote]
(name, arity) ->
-- If it starts with a nonalpha, it prefers to evaluate arguments
let d = if C.isAlphaNum $ head $ BU.toString name
_ -> return ()
return $ NTString s
+-- Annotations
+--
+-- XXX this is probably the wrong thing to do
+normTerm_ c ss (P.TAnnot a (t T.:~ st)) = do
+ v <- normTerm_ c (st:ss) t >>= newAssignNT "_a"
+ newAnnot v a
+ return (NTVar v)
+
-- Quote makes the context explicitly a quoting one
normTerm_ _ ss (P.TFunctor "&" [t T.:~ st]) = do
normTerm_ (ECExplicit,ADQuote) (st:ss) t
_ -> do
NTVar `fmap` newAssign "_u" (Right ("is",[nx,nv]))
--- Annotations
---
--- XXX this is probably the wrong thing to do
-normTerm_ c ss (P.TAnnot a (t T.:~ st)) = do
- v <- normTerm_ c (st:ss) t >>= newAssignNT "_a"
- newAnnot v a
- return (NTVar v)
-
-- Functors have both top-down and bottom-up dispositions on
-- their handling.
normTerm_ c ss (P.TFunctor f as) = do
-- Normalize a Rule {{{
data Rule = Rule { r_index :: Int
- , r_functor :: DVar
+ , r_head :: DVar
, r_aggregator :: DAgg
, r_side :: [DVar]
, r_result :: DVar
-- | Run the normalization routine.
--
--- Use as @runNormalize nRule
+-- Use as @runNormalize nRule@
runNormalize :: ReaderT ANFDict (State ANFState) a -> (a, ANFState)
runNormalize =
flip runState (AS 0 M.empty M.empty [] M.empty []) .
-- 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,
+ -- * Normalized Term Representations
+ NT(..), FDT, NTV, ENF, EVF,
- -- * Modes
- Mode(..), Moded(..), modeOf, isBound, isFree,
+ -- * Modes
+ Mode(..), Moded(..), modeOf, isBound, isFree,
ModedVar, varOfMV, ModedNT, evnOfMNT, ntvOfMNT,
- -- * DOpAMine
+ -- * DOpAMine
DOpAMine(..),
- -- * Determinism
- Det(..), detOfDop,
+ -- * Determinism
+ Det(..), detOfDop,
) where
import qualified Data.ByteString as B
-- | 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)
+data NT v = NTBool Bool
+ | NTNumeric (Either Integer Double)
| NTString B.ByteString
| NTVar v
deriving (Eq,Ord,Show)
-- live and learn.
| OPCkne DVar DVar -- ++
+ -- | 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 -- -+
+
+ -- | The reverse of OPPeel
| OPWrap DVar [DVar] DFunct -- -+
+ -- | Perform a query
| OPIter (ModedVar) [ModedVar] DFunct -- ??
Det
(Maybe fbs)
+
+ -- | Perform an arbitrary evaluation query. Semantically,
+ --
+ -- @OPWrap x ys f ; OPIndr z x@ is indistinguishable from
+ -- @OPIter (MF z) (map MB ys) f DetSemi Nothing@.
| OPIndr DVar DVar -- -+
deriving (Eq,Ord,Show)
-- XXX Gotta start somewhere.
-- Header material {{{
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
module Dyna.Analysis.RuleMode (
Mode(..), Moded(..), ModedNT, isBound, isFree,
Crux(..),
- Action, Cost, Det(..), planInitializer,
- BackendPossible, planEachEval,
+ Action, Cost, Det(..),
+ BackendPossible,
+
+ planInitializer, planEachEval, planGroundBackchain,
- EvalMap, combinePlans,
+ UpdateEvalMap, combineUpdatePlans,
+
+ QueryEvalMap, combineQueryPlans,
adornedQueries
) where
import Text.PrettyPrint.Free
------------------------------------------------------------------------}}}
--- Modes {{{
+-- Bindings {{{
-- | What things have thus far been bound under the plan?
type BindChart = S.Set DVar
------------------------------------------------------------------------}}}
-- Cruxes {{{
-data Crux v n = CFCall v [v] DFunct
- | CFStruct v [v] DFunct
- | CFUnif v v
- | CFAssign v n
- | CFEval v v
+data EvalCrux v = CFCall v [v] DFunct
+ | CFEval v v
+ deriving (Eq,Ord,Show)
+
+data UnifCrux v n = CFStruct v [v] DFunct
+ | CFAssign v n
deriving (Eq,Ord,Show)
+type Crux v n = Either (EvalCrux v) (UnifCrux v n)
+
+cruxIsEval (Left _) = True
+cruxIsEval (Right _) = False
+
cruxMode :: BindChart -> Crux DVar NTV -> Crux (ModedVar) (ModedNT)
-cruxMode c cr = case cr of
- CFCall o is f -> CFCall (mv o) (map mv is) f
- CFStruct o is f -> CFStruct (mv o) (map mv is) f
- CFAssign o i -> CFAssign (mv o) (modedNT c i)
- CFEval o i -> CFEval (mv o) (mv i)
- CFUnif o i -> CFUnif (mv o) (mv i)
+cruxMode c cr = either (Left . evalMode) (Right . unifMode) cr
where
+ evalMode ec = case ec of
+ CFCall o is f -> CFCall (mv o) (map mv is) f
+ CFEval o i -> CFEval (mv o) (mv i)
+ unifMode uc = case uc of
+ CFStruct o is f -> CFStruct (mv o) (map mv is) f
+ CFAssign o i -> CFAssign (mv o) (modedNT c i)
mv = modedVar c
cruxVars :: Crux DVar NTV -> S.Set DVar
-cruxVars cr = case cr of
- CFCall o is _ -> S.fromList (o:is)
- CFStruct o is _ -> S.fromList (o:is)
- CFAssign o (NTVar i) -> S.fromList [o,i]
- CFAssign o _ -> S.singleton o
- CFEval o i -> S.fromList [o,i]
- CFUnif o i -> S.fromList [o,i]
-
-cruxIsEval :: Crux a b -> Bool
-cruxIsEval (CFEval _ _) = True
-cruxIsEval (CFCall _ _ _) = True
-cruxIsEval _ = False
+cruxVars = either evalVars unifVars
+ where
+ evalVars cr = case cr of
+ CFCall o is _ -> S.fromList (o:is)
+ CFEval o i -> S.fromList [o,i]
+ unifVars cr = case cr of
+ CFStruct o is _ -> S.fromList (o:is)
+ CFAssign o (NTVar i) -> S.fromList [o,i]
+ CFAssign o _ -> S.singleton o
------------------------------------------------------------------------}}}
-- Actions {{{
type Action fbs = [DOpAMine fbs]
--- XXX Is this really the right type? Maybe we'd rather that this be a
--- function rather than a map?
+-- XXX Is this really the right type?
--
-- 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
-- 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 BackendPossible fbs = (DFunct,[ModedVar],ModedVar)
+ -> Either Bool (Action fbs)
-type Possible fbs = Crux (ModedVar) (ModedNT) -> [Action fbs]
+type Possible fbs = (Crux (ModedVar) (ModedNT)) -> Maybe (Action fbs)
{-
mapMaybeModeCompat mis mo =
possible :: BackendPossible fbs -> Possible fbs
possible fp cr = case cr of
-- XXX Indirect evaluation is not yet supported
- CFEval _ _ -> []
+ Left (CFEval _ _) -> dynacSorry "Indir eval"
-- Assign or check
- CFAssign o i -> let ni = ntvOfMNT i in
- case (evnOfMNT i, o) of
- (Left _, MF _) -> []
- (Right _, MB o') -> let chk = "_chk" in
- [[ OPAsgn chk ni
- , OPCheq chk o']]
- (Left i', MB o') -> [[OPAsgn i' (NTVar o')]]
- (Right _, MF o') -> [[OPAsgn o' ni]]
+ Right (CFAssign o i) ->
+ let ni = ntvOfMNT i in
+ case (evnOfMNT i, o) of
+ (Left _, MF _) -> Nothing
+ (Right _, MB o') -> let chk = "_chk" in
+ Just [ OPAsgn chk ni
+ , OPCheq chk o']
+ (Left i', MB o') -> Just [OPAsgn i' (NTVar o')]
+ (Right _, MF o') -> Just [OPAsgn o' ni]
-- Structure building
- CFStruct o is funct ->
+ Right (CFStruct o is funct) ->
case o of
-- If the output is free, the only supported case is when all
-- inputs are known.
MF o' -> if all isBound is
- then [[OPWrap o' (map varOfMV is) funct]]
- else []
+ then Just [OPWrap o' (map varOfMV is) funct]
+ else Nothing
-- On the other hand, if the output is known, then any subset
-- of the inputs may be known and will be checked.
- MB o' -> [ (OPPeel is' o' funct)
- : map (\(c,x) -> (OPCheq c x)) cis
- ]
+ MB o' -> Just $ (OPPeel is' o' funct)
+ : map (\(c,x) -> (OPCheq c x)) cis
where
mkChks _ (MF i) = (i, Nothing)
mkChks n (MB v) = let chk = BC.pack $ "_chk_" ++ (show n)
(is',mcis) = unzip $ zipWith mkChks [0::Int ..] is
cis = MA.catMaybes mcis
- -- Unification
- CFUnif (MF _) (MF _) -> []
- 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)]]
-
- 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)
- = [[ OPCall y [o,x] "-" ]]
-
- inv "+" [(MF x), (MB y)] (MB o)
- = [[ OPCall x [o,y] "-" ]]
-
- inv "-" [(MB x),(MF y)] (MB o)
- = [[ OPCall y [x,o] "-" ]]
-
- inv "-" [(MF x),(MB y)] (MB o)
- = [[ OPCall x [o,y] "+" ]]
-
- inv _ _ _ = []
--}
+ Left (CFCall o is funct) ->
+ case fp (funct,is,o) of
+ Left False -> Just [OPIter o is funct DetNon Nothing ]
+ Left True -> Nothing
+ Right a -> Just a
------------------------------------------------------------------------}}}
-- ANF to Cruxes {{{
-eval_cruxes :: ANFState -> [Crux DVar NTV]
+eval_cruxes :: ANFState -> [EvalCrux DVar]
eval_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_evals
where
- crux :: DVar -> EVF -> Crux DVar NTV
+ crux :: DVar -> EVF -> EvalCrux DVar
crux o (Left v) = CFEval o v
crux o (Right (f,as)) = CFCall o as f
- -- XXX Missing cases
-unif_cruxes :: ANFState -> [Crux DVar NTV]
+unif_cruxes :: ANFState -> [UnifCrux DVar NTV]
unif_cruxes (AS { as_assgn = assigns, as_unifs = unifs }) =
M.foldrWithKey (\o i -> (crux o i :)) [] assigns
- ++ map (uncurry CFUnif) unifs
+ ++ map (\(v1,v2) -> CFAssign v1 (NTVar v2)) unifs
where
- crux :: DVar -> ENF -> Crux DVar NTV
+ crux :: DVar -> ENF -> UnifCrux DVar NTV
crux o (Left (NTString s)) = CFAssign o $ NTString s
crux o (Left (NTNumeric n)) = CFAssign o $ NTNumeric n
crux o (Left (NTVar i)) = CFAssign o $ NTVar i
------------------------------------------------------------------------}}}
-- Planning {{{
+-- $dupcrux
+--
+-- Consider a rule like @a += b(X) * b(Y).@ This desugars into an ANF with
+-- two separate evaluations of @b(_)@. This is problematic, since we will
+-- plan each evaluation separately. (Note that CSE won't help; we really do
+-- mean to compute the cross-product in this case, but not double-count the
+-- diagonal!) The workaround here is to /order/ the evaluations (by their
+-- ANF temporary variables, for the moment).
+--
+-- For replacement updates, the correct action is to @continue@ the
+-- evaluation loop when an eariler (by the intrinsic ordering) iterator
+-- within a update to a later (by the intrinsic ordering) evaluation
+-- lands at the same position.
+--
+-- For delta updates, the ordering is used for the Blatz-Eisner update
+-- propagation strategy -- new values are used in earlier evaluations (than
+-- the one being updated) and old values are used in later evaluations.
+--
+-- When backward chaining, we get to ignore all of this, since we only
+-- produce one backward chaining plan.
+--
+-- XXX It's unclear that this is really the right solution. Maybe we should
+-- be planning a single stream of instructions for each dfuctar, rather than
+-- each evalution arc, but it's not quite clear that there's a nice
+-- graphical story to be told in that case?
+--
+-- XXX What do we do in the CFEval case?? We need to check every evaluation
+-- inside a CFEval update?
+
data PartialPlan fbs = PP { pp_cruxes :: S.Set (Crux DVar NTV)
, pp_binds :: BindChart
, pp_restrictSearch :: Bool
-- | The 'DFunctAr', intern representation, and
-- result variable of the
-- initial /evaluation/ crux, if any. This is used to
- -- avoid double-counting during updates.
- --
- -- Cruxes are implicitly ordered by the name of their
- -- evaluation variable, so we can easily look to see if
- -- a given crux is "before" or "after" the initial one
- -- in this ordering.
- -> Maybe (DFunctAr, DVar, DVar)
+ -- avoid double-counting during updates. See $dupcrux
+ -> Maybe (Maybe DFunctAr, DVar, DVar)
-> PartialPlan fbs
-> Either (Cost, Action fbs) [PartialPlan fbs]
stepPartialPlan steps score mic p =
xs -> [argmin (flip score []) xs]
else step rc
where
- step = S.fold (\crux ps -> (
+ step = S.fold (\crux ps ->
let bc = pp_binds p
pl = pp_plan p
- plans = steps (cruxMode bc crux)
+ plan = steps (cruxMode bc crux)
bc' = bc `S.union` cruxVars crux
rc' = S.delete crux (pp_cruxes p)
r' = (not $ cruxIsEval crux) || (pp_restrictSearch p)
- in map (\act -> let act' = handleConflictors act
- in PP rc' bc' r' (score p act') (pl ++ act'))
- plans
- ) ++ ps
+ in maybe ps
+ (\act -> let act' = handleConflictors act
+ in PP rc' bc' r' (score p act') (pl ++ act')
+ : ps)
+ plan
) []
handleConflictors =
case mic of
Nothing -> id
- Just ((f,a),i,ov) -> concatMap $ \dop ->
+ Just (mfa,i,ov) -> concatMap $ \dop ->
case dop of
- OPIter ov' ivs' f' _ _ | f' == f
- && length ivs' == a
- && ov > varOfMV ov'
- -> let cv = "_chk"
- in [ dop
- , OPWrap cv (map varOfMV ivs') f'
- , OPCkne i cv
- ]
+ OPIter ov' ivs' f' _ _ |
+ -- We must insert checks whenever this step involves
+ -- an evaluation. As an easy optimisation, if we know
+ -- the 'DFunctAr' being updated, we can elide this check
+ -- when we're evaluating a different 'DFunctAr'.
+ (maybe True (== (f',length ivs')) mfa)
+ && ov > varOfMV ov'
+ -> let cv = "_chk"
+ in [ dop
+ , OPWrap cv (map varOfMV ivs') f'
+ , OPCkne i cv
+ ]
_ -> [dop]
stepAgenda st sc mic = go [] . (\x -> [x])
go [] [] = []
go (r:rs) [] = go rs r
go rs (p:ps) = case stepPartialPlan st sc mic p of
- Left df -> (\(c,a) -> (c,fmap (\(_,x,y) -> (x,y)) mic,a)) df
- : (go rs ps)
+ Left df -> df : (go rs ps)
Right ps' -> go (ps':rs) ps
--- 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)
- -> ((DFunctAr, DVar, DVar), Action fbs)
-initializeForCrux cr = case cr of
- CFCall o is f -> ( ((f,length is), _hi, o)
- , [ OPPeel is _hi f ])
- _ -> dynacSorry "Don't know how to initially plan !CFCall"
+planner_ :: -- | Available steps
+ Possible fbs
+ -- | Scoring function
+ -> (PartialPlan fbs -> Action fbs -> Cost)
+ -- | Cruxes to be planned over
+ -> S.Set (Crux DVar NTV)
+ -- | Maybe the updated evaluation crux, the interned
+ -- representation of the term being updated, and
+ -- result variable.
+ -> Maybe (EvalCrux DVar, DVar, DVar)
+ -- | Any variables bound on the way in, in addition to
+ -- the two given for an initial crux
+ -> S.Set DVar
+ -- | Plans and their costs
+ -> [(Cost, Action fbs)]
+planner_ st sc cr mic bv = stepAgenda st sc mic'
+ $ PP { pp_cruxes = cr
+ , pp_binds = S.union bv $
+ maybe S.empty (\(_,i,o) -> S.fromList [i,o]) mic
+ , pp_restrictSearch = False
+ , pp_score = 0
+ , pp_plan = ip
+ }
where
- _hi = "_i"
+ -- XREF:INITPLAN
+ (ip,mic') = case mic of
+ Nothing -> ([],Nothing)
+ Just (CFCall o is f, hi, ho) -> ( [ OPPeel is hi f
+ , OPAsgn o (NTVar ho)]
+ , Just (Just (f,length is),o,hi))
+ Just (CFEval o i, hi, ho) -> ( [ OPAsgn i (NTVar hi)
+ , OPAsgn o (NTVar ho)]
+ , Just (Nothing,o,i))
+
+anfPlanner_ st sc anf mic bv = planner_ st sc cruxes mic bv
+ where
+ cruxes = S.fromList (map Left (eval_cruxes anf))
+ `S.union` S.fromList (map Right (unif_cruxes anf))
+
+bestPlan [] = Nothing
+bestPlan plans = Just $ argmin fst plans
--- | Given a normalized form and an initial crux, saturate the graph and
--- get a plan for doing so.
+-- | Given a normalized form and, optionally, an initial crux,
+-- saturate the graph and get all the plans for doing so.
--
-- XXX This has no idea what to do about non-range-restricted rules.
-plan_ :: Possible fbs -- ^ Available steps
- -> (PartialPlan fbs -> Action fbs -> Cost) -- ^ Scoring function
- -> ANFState -- ^ Normal form
- -> Maybe (Crux DVar NTV) -- ^ Initial crux
- -> [(Cost, Maybe (DVar,DVar), Action fbs)] -- ^ If there's a plan...
-plan_ st sc anf mi =
- let cruxes = eval_cruxes anf
- ++ unif_cruxes anf
- (mic,ip) = maybe (Nothing, []) (first Just . initializeForCrux) mi
- initPlan = PP { pp_cruxes = maybe id S.delete mi $ S.fromList cruxes
- , pp_binds = maybe S.empty cruxVars mi
- , pp_restrictSearch = False
- , pp_score = 0
- , pp_plan = ip
- }
- in stepAgenda st sc mic initPlan
-
-plan :: Possible fbs
- -> (PartialPlan fbs -> Action fbs -> Cost)
- -> ANFState
- -> Maybe (Crux DVar NTV)
- -> Maybe (Cost, Maybe (DVar,DVar), Action fbs)
-plan st sc anf mi =
- (\x -> case x of
- [] -> Nothing
- plans -> Just $ argmin (\(c,_,_) -> c) plans)
- $ plan_ st sc anf mi
+planUpdate_ :: BackendPossible fbs -- ^ Available steps
+ -> (PartialPlan fbs -> Action fbs -> Cost) -- ^ Scoring function
+ -> ANFState -- ^ Normal form
+ -> Maybe (EvalCrux DVar, DVar, DVar) -- ^ Initial eval crux
+ -> [(Cost, Action fbs)] -- ^ If there's a plan...
+planUpdate_ bp sc anf mic = anfPlanner_ (possible bp) sc anf mic S.empty
+
+planUpdate :: BackendPossible fbs
+ -> (PartialPlan fbs -> Action fbs -> Cost)
+ -> ANFState
+ -> Maybe (EvalCrux DVar, DVar, DVar)
+ -> Maybe (Cost, Action fbs)
+planUpdate bp sc anf mi =
+ bestPlan $ planUpdate_ bp sc anf mi
planInitializer :: BackendPossible fbs -> Rule -> Maybe (Cost, Action fbs)
planInitializer bp (Rule { r_anf = anf }) =
- fmap (\(c,m,a) -> case m of
- Nothing -> (c,a)
- Just _ -> dynacPanic "Initializer wants input variables?")
- $ plan (possible bp) simpleCost anf Nothing
+ planUpdate bp simpleCost anf Nothing
planEachEval :: BackendPossible fbs -- ^ The backend's primitive support
-> (DFunctAr -> Bool) -- ^ Indicator for constant function
-> Rule
- -> [(DFunctAr, Maybe (Cost, Maybe (DVar, DVar), Action fbs))]
+ -> [(Maybe DFunctAr, Maybe (Cost, DVar, DVar, Action fbs))]
planEachEval bp cs (Rule { r_anf = anf }) =
- map (\(c,fa) -> (fa, plan (possible bp) simpleCost anf $ Just c))
- $ MA.mapMaybe (\c -> case c of
- CFCall _ is f | cs (f,length is)
- -> Just $ (c,(f,length is))
- _ -> Nothing )
- $ eval_cruxes anf
+ map (\(mfa,cr) -> (mfa, varify $ planUpdate bp simpleCost anf $ Just $ mic cr))
+ -- Filter out non-constant evaluations
+ $ MA.mapMaybe (\ec -> case ec of
+ CFCall _ is f | not (cs (f,length is))
+ -> Just (Just (f,length is), ec)
+ CFCall _ _ _ -> Nothing
+ CFEval o i -> Just (Nothing,ec))
+
+ -- Grab all evaluations
+ $ eval_cruxes anf
+ where
+ -- XXX I am not terribly happy about these, but it'll do for the moment.
+ --
+ -- If the mechanism of feeding updates into these plans is to change,
+ -- please ensure that XREF:INITPLAN also changes appropriately.
+ varify = fmap $ \(c,a) -> (c,varHead,varVal,a)
+ mic x = (x,varHead,varVal)
+ varHead = "__i"
+ varVal = "__v"
+
+planGroundBackchain :: BackendPossible fbs
+ -> Rule
+ -> Maybe (Cost, DVar, Action fbs)
+planGroundBackchain bp (Rule { r_anf = anf, r_head = h }) =
+ varify
+ $ bestPlan
+ $ anfPlanner_ (possible bp) simpleCost anf Nothing (S.singleton h)
+ where
+ varify = fmap $ \(c,a) -> (c,h,a)
------------------------------------------------------------------------}}}
--- Plan combination {{{
+-- Update plan combination {{{
-type EvalMap fbs = M.Map DFunctAr [(Rule, Cost, Maybe (DVar,DVar), Action fbs)]
+type UpdateEvalMap fbs = M.Map (Maybe DFunctAr)
+ [(Rule, Cost, DVar, DVar, Action fbs)]
-- | Return all plans for each functor/arity
--
--
-- timv: might want to fuse these into one circuit
--
-combinePlans :: [(Rule,[(DFunctAr, Maybe (Cost, Maybe (DVar, DVar), Action fbs))])]
- -> EvalMap fbs
-combinePlans = go (M.empty)
+combineUpdatePlans :: [(Rule,[( Maybe DFunctAr,
+ Maybe (Cost, DVar, DVar, Action fbs))])]
+ -> UpdateEvalMap fbs
+combineUpdatePlans = go (M.empty)
where
go m [] = m
go m ((fr,cmca):xs) = go' xs fr cmca m
<+> (pretty fa)
<+> "in rule at"
<+> (prettySpanLoc $ r_span fr)
- Just (c,mv,a) -> go' xs fr ys $ mapInOrApp fa (fr,c,mv,a) m
+ Just (c,v1,v2,a) -> go' xs fr ys $ mapInOrApp fa (fr,c,v1,v2,a) m
+
+------------------------------------------------------------------------}}}
+-- Backward chaining plan combination {{{
+
+type QueryEvalMap fbs = M.Map (Maybe DFunctAr)
+ [(Rule, Cost, DVar, Action fbs)]
+
+combineQueryPlans :: [(Rule, Maybe (Cost, DVar, Action fbs))]
+ -> QueryEvalMap fbs
+combineQueryPlans = go (M.empty)
+ where
+ go m [] = m
+ go m ((fr,mcva):xs) = go' xs fr mcva m
+
+ go' xs fr Nothing m = dynacUserErr
+ $ "No query plan for rule at"
+ <+> (prettySpanLoc $ r_span fr)
+ go' xs fr (Just (c,v,a)) m = go (mapInOrApp (findHeadFA fr)
+ (fr,c,v,a)
+ m)
+ xs
+
+ -- XXX This is unforunate and wrong, but our ANF is not quite right to
+ -- let us do this right. See also Dyna.Backend.Python's use of this
+ -- function.
+ findHeadFA (Rule _ h _ _ _ _ (AS { as_assgn = as })) =
+ case M.lookup h as of
+ Nothing -> error "No unification for head variable?"
+ Just (Left _) -> error "NTVar head?"
+ Just (Right (f,a)) -> Just (f, length a)
+
+
------------------------------------------------------------------------}}}
-- Adorned Queries {{{
------------------------------------------------------------------------}}}
-- DOpAMine Backend Information {{{
-data PyDopeBS = PDBAsIs
- | PDBRewrite (([ModedVar],ModedVar) -> [DOpAMine PyDopeBS])
+-- At the moment, we pass through a @Maybe ()@ to indicate whether or not
+-- we're making a call. See the call to pycall in pdope_ below.
+type PyDopeBS = ()
+builtins :: BackendPossible PyDopeBS
builtins (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)
- ])
+ _ | all isBound is && S.member (f,length is) constants
+ -> case modeOf o of
+ MFree -> Right [OPIter o is f Det (Just ())]
+ MBound -> let chkv = "_chk"
+ in Right $ [ OPIter (MF chkv) is f Det (Just ())
+ , 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])
+ ([x@(MB _),y@(MF _)],MB _) -> Right [OPIter y [o,x] "-" Det $ Just ()]
+ ([x@(MF _),y@(MB _)],MB _) -> Right [OPIter x [o,y] "-" Det $ Just ()]
_ -> 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])
+ ([x@(MB _),y@(MF _)],MB _) -> Right [OPIter y [x,o] "-" Det $ Just ()]
+ ([x@(MF _),y@(MB _)],MB _) -> Right [OPIter x [o,y] "+" Det $ Just ()]
_ -> Left True
_ | S.member (f,length is) constants -> Left True
------------------------------------------------------------------------}}}
-- DOpAMine Printout {{{
-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
- <+> equals <> " "
- <> "peel" <> (parens $ fa f vs <> comma <> pretty id)
- )
-
- `above` "except (TypeError, AssertionError): continue" -- you'll get a "TypeError: 'NoneType' is not iterable."
+-- | Print functor and arity based on argument list
+pfas f args = dquotes $ pretty f <> "/" <> (pretty $ length args)
+pfa f n = parens $ dquotes $ pretty f <> "/" <> pretty n
-pdope (OPWrap v vs f) = Right $ pretty v <+> equals
- <+> "build" <> (parens $ fa f vs <> comma <> (sepBy "," $ map pretty vs))
+-- pf f vs = pretty f <> (tupled $ map pretty vs)
-pdope (OPIter v vs f _ (Just b)) =
- case b of
- PDBAsIs -> Right $ pretty (varOfMV v)
- <+> equals
- <+> pycall "call" f vs
-
- PDBRewrite rf -> Left $ rf (vs,v)
-
-
-pdope (OPIter o m f _ Nothing) = Right $
- let mo = m ++ [o] in
- "for" <+> (tupledOrUnderscore $ filterBound mo)
- <+> "in" <+> functorIndirect "chart" f m <> pslice mo <> colon
-
-fa f a = dquotes $ pretty f <> "/" <> (text $ show $ length a)
+functorIndirect table f vs = table <> (brackets $ pfas f vs)
-- this comes up because can't assign to ()
-tupledOrUnderscore vs = if length vs > 0 then parens ((sepBy "," $ map pretty vs) <> ",") else text "_"
-
-pslice vs = brackets $
- sepBy "," (map (\x -> case x of (MF v) -> ":" ; (MB v) -> pretty v) vs)
- <> "," -- add a list comma to ensure getitem is always passed a tuple.
+tupledOrUnderscore vs = if length vs > 0
+ then parens ((sepBy "," $ map pretty vs) <> ",")
+ else text "_"
filterBound = map (\(MF v) -> pretty v) . filter (not.isBound)
-functorIndirect table f vs = table <> (brackets $ dquotes $ (pretty f <> "/" <> (text $ show $ length vs)))
+pslice vs = brackets $
+ sepBy "," (map (\x -> case x of (MF _) -> ":" ; (MB v) -> pretty v) vs)
+ <> "," -- add a list comma to ensure getitem is always passed a tuple.
-pycall table f vs = case (f, length vs) of
+pycall f vs = case (f, length vs) of
( "*", 2) -> infixOp " * "
( "+", 2) -> infixOp " + "
( "-", 2) -> infixOp " - "
-- TODO: add useful error message.
-- _ -> functorIndirect "call" f vs <> (tupled $ pretty_vs)
+
where pretty_vs = map (pretty . varOfMV) vs
call name = name <> (parens $ sepBy ", " $ pretty_vs)
infixOp op = sepBy op $ pretty_vs
-pf f vs = pretty f <> (tupled $ map pretty vs)
-py (f,a) mu (Rule _ 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 $ "for _ in [None]:")
- `above` (indent 8 $ go dope emit)
+-- | Render a single dopamine opcode or its surrogate
+pdope_ :: DOpAMine PyDopeBS -> Doc e
+pdope_ (OPIndr _ _) = dynacSorry "indirect evaluation not implemented"
+pdope_ (OPAsgn v val) = pretty v <+> equals <+> pretty val
+pdope_ (OPCheq v val) = "if" <+> pretty v <+> "!="
+ <+> pretty val <> ": continue"
+pdope_ (OPCkne v val) = "if" <+> pretty v <+> "=="
+ <+> pretty val <> ": continue"
+pdope_ (OPPeel vs i f) =
+ "try:" `above` (indent 4 $
+ tupledOrUnderscore vs
+ <+> equals <> " "
+ <> "peel" <> (parens $ pfas f vs <> comma <> pretty i)
+ )
+ -- you'll get a "TypeError: 'NoneType' is not iterable."
+ `above` "except (TypeError, AssertionError): continue"
+pdope_ (OPWrap v vs f) = pretty v
+ <+> equals
+ <+> "build"
+ <> (parens $ pfas f vs <> comma
+ <> (sepBy "," $ map pretty vs))
+
+pdope_ (OPIter v vs f _ (Just ())) = pretty (varOfMV v)
+ <+> equals
+ <+> pycall f vs
+
+pdope_ (OPIter o m f _ Nothing) =
+ let mo = m ++ [o] in
+ "for" <+> (tupledOrUnderscore $ filterBound mo)
+ <+> "in" <+> functorIndirect "chart" f m <> pslice mo <> colon
+-- | Render a dopamine sequence's checks and loops above a (indended) core.
+pdope :: [DOpAMine PyDopeBS] -> Doc e -> Doc e
+pdope _d _e = (indent 4 $ "for _ in [None]:")
+ `above` (indent 8 $ go _d _e)
where
- pfsa = (parens $ dquotes $
- pretty f <> "/" <> (text $ show a))
-
- go [] = id
- go (x:xs) = let indents = case x of OPIter _ _ _ d _ -> d /= Det ; _ -> False
- in
- case pdope x of
- Left rw -> go (rw++xs)
- Right px -> above px
- . (if indents then indent 4 else id)
- . go xs
+ go [] = id
+ go (x:xs) = let indents = case x of OPIter _ _ _ d _ -> d /= Det ; _ -> False
+ in above (pdope_ x)
+ . (if indents then indent 4 else id)
+ . go xs
+
+py mfa mu (Rule _ h _ _ r span _) dope =
+ case mu of
+ Just (hv,v) -> case mfa of
+ Nothing -> dynacSorry "Can't register indir eval"
+ Nothing -> case mfa of
+ Nothing -> dynacPanic "Initializer without head"
+ `above` pdope dope emit
+ where
emit = "emit" <> tupled [pretty h, pretty r]
-printPlan :: Handle
- -> (DFunct,Int) -- ^ Functor & arity
- -- | rule, cost, input variables, and plan
- -> (Rule, Cost, Maybe (DVar, DVar), Action PyDopeBS)
- -> IO ()
-printPlan fh fa (r, cost, mu, dope) = do -- display plan
- hPutStrLn fh $ "# --"
- displayIO fh $ prefixSD "# " $ renderPretty 1.0 100
- $ (prettySpanLoc $ r_span r) <> line
- hPutStrLn fh $ "# Cost: " ++ (show cost)
+printPlanHeader :: Handle -> Rule -> Cost -> IO ()
+printPlanHeader h r c = do
+ hPutStrLn h $ "# --"
+ -- XXX This "prefixSD" thing is the only real reason we're doing this in
+ -- IO; it'd be great if wl-pprint-extras understood how to prefix each
+ -- line it was laying out.
+ displayIO h $ prefixSD "# " $ renderPretty 1.0 100
+ $ (prettySpanLoc $ r_span r) <> line
+ hPutStrLn h $ "# Cost: " ++ (show c)
+
+-- XXX This is unforunate and wrong, but our ANF is not quite right to
+-- let us do this right. See also Dyna.Analysis.RuleMode's use of this
+-- function.
+findHeadFA (Rule _ h _ _ _ _ (AS { as_assgn = as })) =
+ case M.lookup h as of
+ Nothing -> error "No unification for head variable?"
+ Just (Left _) -> error "NTVar head?"
+ Just (Right (f,a)) -> Just (f, length a)
+
+printInitializer :: Handle -> Rule -> Action PyDopeBS -> IO ()
+printInitializer fh rule@(Rule _ h _ _ r _ _) dope = do
displayIO fh $ renderPretty 1.0 100
- $ py fa mu r dope <> line
- hPutStrLn fh ""
+ $ "@initializer" <> parens (uncurry pfa $ MA.fromJust $ findHeadFA rule)
+ `above` "def" <+> char '_' <> tupled [] <+> colon
+ `above` pdope dope emit
+ <> line
+ where
+ emit = "emit" <> tupled [pretty h, pretty r]
+
+-- XXX INDIR EVAL
+printUpdate :: Handle -> Rule -> Maybe DFunctAr -> (DVar, DVar) -> Action PyDopeBS -> IO ()
+printUpdate fh rule@(Rule _ h _ _ r _ _) (Just (f,a)) (hv,v) dope = do
+ displayIO fh $ renderPretty 1.0 100
+ $ "@register" <> parens (pfa f a)
+ `above` "def" <+> char '_' <> tupled (map pretty [hv,v]) <+> colon
+ `above` pdope dope emit
+ <> line
+ where
+ emit = "emit" <> tupled [pretty h, pretty r]
------------------------------------------------------------------------}}}
-- Driver {{{
-driver am em is fh = do
+driver :: BackendDriver PyDopeBS
+driver am um qm is fh = do
-- Aggregation mapping
hPutStrLn fh $ "agg_decl = {}"
- forM (M.toList am) $ \((f,a),v) -> do
+ forM_ (M.toList am) $ \((f,a),v) -> do
hPutStrLn fh $ show $ "agg_decl"
<> brackets (dquotes $ pretty f <> "/" <> pretty a)
<+> equals <+> (dquotes $ pretty v)
+ hPutStrLn fh ""
+ hPutStrLn fh $ "# ==Updates=="
+
-- plans aggregated by functor/arity
- forM_ (M.toList em) $ \(fa, ps) -> do
+ forM_ (M.toList um) $ \(fa, ps) -> do
hPutStrLn fh ""
- hPutStrLn fh $ "# =============="
hPutStrLn fh $ "# " ++ show fa
- forM_ ps $ printPlan fh fa
+ forM_ ps $ \(r,c,vi,vo,act) -> do
+ printPlanHeader fh r c
+ printUpdate fh r fa (vi,vo) act
hPutStrLn fh ""
- hPutStrLn fh $ "# =============="
- hPutStrLn fh $ "# Initializers"
+ hPutStrLn fh $ "# ==Initializers=="
+ forM_ is $ \(r,c,a) -> do
+ printPlanHeader fh r c
+ printInitializer fh r a
- forM_ is $ \(f,c,a) -> printPlan fh (findHeadFA f) (f,c,Nothing,a)
+ hPutStrLn fh $ "# ==Queries=="
+
+ forM_ (M.toList qm) $ \(fa, ps) -> do
+ hPutStrLn fh $ "# " ++ show fa
+ forM_ ps $ \(r,c,qv,a) -> do
+ printPlanHeader fh r c
+ hPutStrLn fh $ "# " ++ show qv
+ -- XXX
+ -- displayIO fh $ renderPretty 1.0 100 $ pdope a "XXX"
+ hPutStrLn fh ""
- where
- findHeadFA (Rule _ h _ _ _ _ (AS { as_assgn = as })) =
- case M.lookup h as of
- Nothing -> error "No unification for head variable?"
- Just (Left _) -> error "NTVar head?"
- Just (Right (f,a)) -> (f, length a)
------------------------------------------------------------------------}}}
-- Export {{{
+pythonBackend :: Backend
pythonBackend = Backend builtins constants driver
------------------------------------------------------------------------}}}
module Dyna.Backend.Python.Selftest where
import Control.Exception (throw)
-import qualified Data.ByteString.Lazy as BL
import System.Exit (ExitCode(..))
import System.IO
import System.Process
------------------------------------------------------------------------}}}
-- Run Backend {{{
-runDynaPy :: String -> IO BL.ByteString
-runDynaPy f = do
+runDynaPy :: String -> String -> IO ()
+runDynaPy f out = do
devnull <- openFile "/dev/null" ReadWriteMode
- (Nothing,Just so,Nothing,ph) <- createProcess $ CreateProcess
+ (Nothing,Nothing,Nothing,ph) <- createProcess $ CreateProcess
{ cmdspec = RawCommand "/usr/bin/env"
- ["python", "bin/interpreter.py", "-o", "-", f]
+ ["python", "bin/interpreter.py", "-o", out, f]
, cwd = Nothing
, env = Nothing
, std_in = UseHandle devnull
- , std_out = CreatePipe
+ , std_out = UseHandle devnull
, std_err = UseHandle devnull
, close_fds = True
, create_group = False
}
- bs <- BL.hGetContents so
ec <- waitForProcess ph
case ec of
- ExitSuccess -> return bs
+ ExitSuccess -> return ()
ExitFailure _ -> throw ec
------------------------------------------------------------------------}}}
mkExample :: String -> TF.Test
mkExample name =
- let (dy,ex) = names in goldenVsString dy ex (runDynaPy dy)
+ let (dy,out,ex) = names in goldenVsFile dy ex out (runDynaPy dy out)
where
- names = ( "examples/" ++ name ++ ".dyna"
+ names = ( "examples/" ++ name ++ ".dyna"
+ , "examples/" ++ name ++ ".dyna.py.out"
, "examples/expected/" ++ name ++ ".py.out")
goldens :: TF.Test
import qualified Data.Set as S
import Dyna.Analysis.Aggregation (AggMap)
import Dyna.Analysis.ANF (Rule)
-import Dyna.Analysis.RuleMode (Action, BackendPossible, Cost, EvalMap)
+import Dyna.Analysis.RuleMode (Action, BackendPossible, Cost,
+ UpdateEvalMap, QueryEvalMap)
import Dyna.Term.TTerm (DFunctAr)
import System.IO (Handle)
-- plans, but that's not really how we should be doing it. The right
-- answer, of course, is to use update mode information, once we have it.
+type BackendDriver bs = AggMap -- ^ Aggregation
+ -> UpdateEvalMap bs -- ^ Rule update
+ -> QueryEvalMap bs -- ^ Rule query
+ -> [(Rule,Cost,Action bs)] -- ^ Initializers
+ -> Handle -- ^ Output
+ -> IO ()
+
data Backend = forall bs . Backend
{ -- | Builtin support hook for mode planning. Options are
-- to return
, be_constants :: S.Set DFunctAr
-- | Backend driver
- , be_driver :: AggMap -- ^ Aggregation
- -> EvalMap bs -- ^ Rules
- -> [(Rule,Cost,Action bs)] -- ^ Initializers
- -> Handle -- ^ Output
- -> IO ()
+ , be_driver :: BackendDriver bs
}
noBackend = Backend
{ be_builtin = \_ -> Left False
, be_constants = S.empty
- , be_driver = \_ _ _ _ -> hPutStrLn stderr
- "No backend specified; stopping"
+ , be_driver = \_ _ _ _ _ -> hPutStrLn stderr
+ "No backend specified; stopping"
}
parseBackend :: String -> Backend
options =
[ Option ['h'] ["help"] (NoArg OptHelp) "display this help message"
, Option ['V'] ["version"] (NoArg OptVersion) "display version and exit"
+ -- This is an excellent idea we might consider, taken from the 'pi'
+ -- program of http://www.ginac.de/CLN/
+ -- , Option [] ["bibliography"] (NoArg OptBiblio) "relevant papers"
]
++
[ Option ['B'] ["backend"] (ReqArg obe "BE")
$ map (\x -> (x, planInitializer be_b x)) frs
- cPlans = combinePlans
+ cPlans = combineUpdatePlans
$ map (\x -> (x, planEachEval be_b
- (not . flip S.member be_c) x))
+ (flip S.member be_c) x))
frs
- in be_d aggm cPlans initializers out
+
+ qPlans = combineQueryPlans
+ $ map (\x -> (x, planGroundBackchain be_b x))
+ frs
+
+ in be_d aggm cPlans qPlans initializers out
parse = do
pr <- T.parseFromFileEx (P.dlines <* T.eof) fileName
projects / dyna2 / commitdiff