-- special at all, but every Dyna program is defined to include
-- @is(X,Y) :- X = *Y.@. Is that something we should be normalizing out
-- here or should be waiting for some further unfolding optimization phase?
+--
+-- XXX We really should do some CSE/GVN somewhere right after this pass, but
+-- be careful about linearity!
-- FIXME: "str" is the same a constant str.
{-# LANGUAGE OverloadedStrings #-}
module Dyna.Analysis.ANF (
- ANFState(..), NT(..), FDT, NTV, EVF, FDR(..),
+ ANFState(..), NT(..), FDT, NTV, ENF, EVF, FDR(..),
normTerm, normRule, runNormalize, printANF
) where
-- | Normalized Term over 'DVar' (that is, either a primitive or a variable)
type NTV = NT DVar
--- | Flat Dyna Term (that is, either a primitive or a term built up from a
--- functor over primitives and variables)
-type FDT = TermF DVar NTV
+-- | Flat Dyna Term (that is, a functor over variables)
+type FDT = (DFunct,[DVar])
--- | Either a 'DVar' or a flat Dyna term
+-- | 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
- , as_unifs :: M.Map DVar FDT
+ , as_unifs :: M.Map DVar ENF
, as_annot :: M.Map DVar [T.Spanned (Annotation DTerm)]
, as_warns :: [(B.ByteString, [T.Span])]
}
modify (\s -> s { as_evals = M.insert n t evs })
return n
-newUnif :: (MonadState ANFState m) => String -> FDT -> m DVar
+newUnif :: (MonadState ANFState m) => String -> ENF -> m DVar
newUnif pfx t = do
n <- nextVar pfx
uns <- gets as_unifs
modify (\s -> s { as_unifs = M.insert n t uns })
return n
+newUnifNT :: (MonadState ANFState m) => String -> NTV -> m DVar
newUnifNT _ (NTVar x) = return x
-newUnifNT pfx (NTString x) = newUnif pfx (TString x)
-newUnifNT pfx (NTNumeric x) = newUnif pfx (TNumeric x)
+newUnifNT pfx (NTString x) = newUnif pfx (Left $ NTString x)
+newUnifNT pfx (NTNumeric x) = newUnif pfx (Left $ NTNumeric x)
newWarn :: (MonadState ANFState m) => B.ByteString -> [T.Span] -> m ()
newWarn msg loc = modify (\s -> s { as_warns = (msg,loc):(as_warns s) })
normas <- mapM (\(a T.:~ s,d) -> normTerm_ (ECFunctor,d) (s:ss) a)
(zip as argdispos)
+ normas' <- mapM (newUnifNT "_$x") normas
+
selfdispos <- asks $ flip ($) (f,length as) . ad_self_dispos
let dispos = mergeDispositions selfdispos c
fmap NTVar $
case dispos of
ADEval -> newEval "_$f" . Right
- ADQuote -> newUnif "_$u"
- $ TFunctor f normas
+ ADQuote -> newUnif "_$u" . Right
+ $ (f,normas')
normTerm :: (Functor m, MonadState ANFState m, MonadReader ANFDict m)
=> Bool -- ^ In an evaluation context?
, parens $ text "result" <+> (pretty result)
]
where
+ pnt :: (Pretty v) => NT v -> Doc e
pnt (NTNumeric (Left x)) = pretty x
pnt (NTNumeric (Right x)) = pretty x
pnt (NTString s) = dquotes (pretty s)
pnt (NTVar v) = pretty v
- pft (TFunctor fn args) = parens $ hcat $ punctuate (text " ")
- $ (pretty fn : (map pnt args))
- pft (TNumeric (Left x)) = pretty x
- pft (TNumeric (Right x)) = pretty x
- pft (TString s) = pretty s
+ pft :: FDT -> Doc e
+ pft (fn,args) = parens $ hsep $ (pretty fn : (map pretty args))
- pef (Left v) = pretty v
- pef (Right t) = pft t
+ pevf :: EVF -> Doc e
+ pevf (Left v) = pretty v
+ pevf (Right t) = pft t
- pet (Left n) = pnt n
- pet (Right t) = pft t
+ penf :: ENF -> Doc e
+ penf (Left n) = pnt n
+ penf (Right t) = pft t
- pev x = valign $ map (\(y,z)-> parens $ pretty y <+> pef z) $ M.toList x
- pun x = valign $ map (\(y,z)-> parens $ pretty y <+> pft z) $ M.toList x
+ pev x = valign $ map (\(y,z)-> parens $ pretty y <+> pevf z) $ M.toList x
+ pun x = valign $ map (\(y,z)-> parens $ pretty y <+> penf z) $ M.toList x
------------------------------------------------------------------------}}}
{-# LANGUAGE ScopedTypeVariables #-}
module Dyna.Analysis.RuleMode (
- Det(..), DOpAMine(..), detOfDop, planEachEval
+ Mode(..), Moded(..), ModedNT, isBound, isFree,
+
+ Crux(..),
+
+ DOpAMine(..), detOfDop,
+
+ Action, Cost, Det(..), planEachEval,
+
+ adornedQueries
) where
import Control.Monad
import qualified Dyna.ParserHS.Parser as DP
import Dyna.XXX.TrifectaTest
-------------------------------------------------------------------------}}}
--- Utilities {{{
-
-filterNTs :: [NT v] -> [v]
-filterNTs = MA.mapMaybe isNTVar
- where
- isNTVar (NTVar x) = Just x
- isNTVar _ = Nothing
-
------------------------------------------------------------------------}}}
-- Modes {{{
-- | What things have thus far been bound under the plan?
type BindChart = S.Set DVar
-varMode :: BindChart -> NTV -> Mode
-varMode c (NTVar v) = if v `S.member` c then MBound else MFree
-varMode _ (NTString _) = MBound
-varMode _ (NTNumeric _) = MBound
-
-type ModedVar = (Mode,DVar)
+varMode :: BindChart -> DVar -> Mode
+varMode c v = if v `S.member` c then MBound else MFree
-data ModedNT = MF DVar
- | MB NTV
+data Moded v = MF DVar
+ | MB v
deriving (Eq,Ord,Show)
-modeOfMNT :: ModedNT -> Mode
-modeOfMNT (MF _) = MFree
-modeOfMNT (MB _) = MBound
+modeOf :: Moded a -> Mode
+modeOf (MF _) = MFree
+modeOf (MB _) = MBound
-ntvOfMNT :: ModedNT -> NTV
-ntvOfMNT (MB x) = x
-ntvOfMNT (MF v) = NTVar v
+isBound, isFree :: Moded a -> Bool
+isBound = (== MBound) . modeOf
+isFree = (== MFree ) . modeOf
-isBound, isFree :: ModedNT -> Bool
-isBound = (== MBound) . modeOfMNT
-isFree = (== MFree) . modeOfMNT
+type ModedVar = Moded DVar
-data Det = Det -- ^ Exactly one answer
- | DetSemi -- ^ At most one answer
- | DetNon -- ^ Unknown number of answers
- deriving (Eq,Ord,Show)
+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 {{{
-data CFunct = CFCall DFunct
- | CFUnif DFunct
- | CFAssign
- | CFEval
+data Crux v n = CFCall v [v] DFunct
+ | CFUnif v [v] DFunct
+ | CFAssign v n
+ | CFEval v v
deriving (Eq,Ord,Show)
-type Crux n = (CFunct,[n],n)
-
-cruxMode :: Crux NTV -> BindChart -> Crux ModedNT
-cruxMode (f,is,o) c = (f, map (mode c) is, mode c o)
+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
+ CFUnif o is f -> CFUnif (mv o) (map mv is) f
+ CFAssign o i -> CFAssign (mv o) (modedNT c i)
+ CFEval o i -> CFEval (mv o) (mv i)
where
- mode b x@(NTVar v) = case varMode b x of
- MBound -> MB x
- MFree -> MF v
- mode _ (NTString s) = MB (NTString s)
- mode _ (NTNumeric x) = MB (NTNumeric x)
+ mv = modedVar c
+
+cruxVars :: Crux DVar NTV -> S.Set DVar
+cruxVars cr = case cr of
+ CFCall o is _ -> S.fromList (o:is)
+ CFUnif 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]
------------------------------------------------------------------------}}}
-- DOpAMine {{{
--
-- It makes us happy.
--- Opcode Out In
-data DOpAMine = OPAssign DVar NTV -- -+
- | OPCheck DVar NTV -- ++
+-- Opcode Out In Ancillary
+data DOpAMine = OPAssign DVar NTV -- -+
+ | OPCheck DVar NTV -- ++
+
+ | OPGetArgsIf [DVar] DVar DFunct Int -- -+
+ | OPBuild DVar [NTV] DFunct -- -+
- | OPCheckFunctor DVar DFunct Int -- +
- | OPGetArgs [DVar] DVar -- -+
- | OPBuild DVar [NTV] DFunct -- -+
+ | OPCall DVar [NTV] DFunct -- -+
+ | OPIter (ModedVar) [ModedVar] DFunct -- ??
+ | OPIndirEval DVar DVar -- -+
+ deriving (Eq,Ord,Show)
- | OPCall DVar [NTV] DFunct -- -+
- | OPIter ModedNT [ModedNT] DFunct -- ??
- | OPIndirEval DVar DVar -- -+
+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
- OPCheckFunctor _ _ _ -> DetSemi
- OPGetArgs _ _ -> Det
+ OPGetArgsIf _ _ _ _ -> DetSemi
OPBuild _ _ _ -> Det
OPIndirEval _ _ -> DetSemi
OPCall _ _ _ -> Det
OPIter o is _ -> -- XXX
- case (modeOfMNT o, foldr min MBound (map modeOfMNT is)) of
- (MFree, MBound) -> DetSemi
- _ -> DetNon
+ case (modeOf o, foldr min MBound (map modeOf is)) of
+ (MFree, MBound) -> DetSemi
+ _ -> DetNon
------------------------------------------------------------------------}}}
-- Actions {{{
type Action = [DOpAMine]
--- XXX
+-- XXX we shouldn't need to know this
isMath f = f `elem` ["^", "+", "-", "*", "/"]
-- XXX This function really ought to be generated from some declarations in
--- the source program, rather than hard-coded.
-possible :: Crux ModedNT -> [Action]
-possible (f,is,o) = case f of
+-- 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
-- XXX Indirect evaluation is not yet supported
- CFEval -> []
+ CFEval _ _ -> []
-- Assign or check
- CFAssign -> case is of
- [i] -> case (i, o) of
- (MF _, MF _) -> []
- (MB i', MB o') -> let chk = "_chk" in
- [[ OPAssign chk i'
- , OPCheck chk o']]
- (MF o', MB i') -> [[OPAssign o' i']]
- (MB i', MF o') -> [[OPAssign o' i']]
- _ -> []
+ CFAssign o i -> let ni = ntvOfMNT i in
+ case (evnOfMNT i, o) of
+ (Left _, MF _) -> []
+ (Right _, MB o') -> let chk = "_chk" in
+ [[ OPAssign chk ni
+ , OPCheck chk (NTVar o')]]
+ (Left i', MB o') -> [[OPAssign i' (NTVar o')]]
+ (Right _, MF o') -> [[OPAssign o' ni]]
-- Unification
- CFUnif funct ->
+ CFUnif 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 let is' = map ntvOfMNT is
- in [[OPBuild o' is' funct]]
+ then [[OPBuild o' (map (NTVar . 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.
- --
- -- XXX Does not understand nonlinear patterns D:
- MB (NTVar o') -> [ (OPCheckFunctor o' funct $ length is)
- : (OPGetArgs is' o')
- : map (\(c,x) -> (OPCheck c x)) cis
- ]
+ MB o' -> [ (OPGetArgsIf is' o' funct $ length is)
+ : map (\(c,x) -> (OPCheck c (NTVar 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
- MB _ -> [] -- XXX shouldn't happen
-
-- Backward-chainable mathematics (this is such a hack XXX)
- CFCall funct | isMath funct ->
+ CFCall o is funct | isMath funct ->
if not $ all isBound is
- then case inv funct is o of
- Nothing -> []
- Just (f',is',o') -> [[OPCall o' is' f']]
- else let is' = map ntvOfMNT is in
+ then inv funct is o
+ else let is' = map (NTVar . 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'
+ ,OPCheck cv (NTVar o')
]]
-- Otherwise, we assume it's an extensional table and ask to iterate
-- over it.
- CFCall funct | otherwise -> [[OPIter o is funct]]
+ CFCall o is funct | otherwise -> [[OPIter o is funct]]
where
+
+ {-
inv "+" is' (MB o') | length is' == 2
= case L.partition isFree is' of
([MF fi],bis) -> Just ("-",o':map ntvOfMNT bis,fi)
inv "-" [(MF x),(MB y)] (MB o')
= Just ("+",[o',y],x)
- inv _ _ _ = Nothing
+ -}
+ inv _ _ _ = []
------------------------------------------------------------------------}}}
--- Plans {{{
+-- ANF to Cruxes {{{
+
+eval_cruxes :: ANFState -> [Crux DVar NTV]
+eval_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_evals
+ where
+ crux :: DVar -> EVF -> Crux DVar NTV
+ 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 = M.foldrWithKey (\o i -> (crux o i :)) [] . as_unifs
+ where
+ crux :: DVar -> ENF -> Crux 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
+ crux o (Right (f,as)) = CFUnif o as f
+
+------------------------------------------------------------------------}}}
+-- Costing Plans {{{
type Cost = Double
-data PartialPlan = PP { pp_cruxes :: S.Set (Crux NTV)
+simpleCost :: PartialPlan -> Action -> Cost
+simpleCost (PP { pp_score = osc }) act =
+ osc + sum (map stepCost act)
+ where
+ stepCost :: DOpAMine -> Double
+ stepCost x = case x of
+ OPAssign _ _ -> 0
+ OPCheck _ _ -> 1
+ OPGetArgsIf _ _ _ _ -> 0
+ OPBuild _ _ _ -> 0
+ OPCall _ _ _ -> 0
+ OPIter o is _ -> fromIntegral $ length $ filter isFree (o:is)
+ OPIndirEval _ _ -> 10
+
+------------------------------------------------------------------------}}}
+-- Planning {{{
+
+data PartialPlan = PP { pp_cruxes :: S.Set (Crux DVar NTV)
, pp_binds :: BindChart
, pp_score :: Cost
, pp_plan :: Action
}
-stepPartialPlan :: (Crux ModedNT -> [Action])
+stepPartialPlan :: (Crux (ModedVar) (ModedNT) -> [Action])
-> (PartialPlan -> Action -> Cost)
-> PartialPlan
-> Either (Cost, Action) [PartialPlan]
then Left $ (pp_score p, pp_plan p)
else Right $
let rc = pp_cruxes p
- in S.fold (\(crux@(_,vis,vo)) ps -> (
+ in S.fold (\crux ps -> (
let bc = pp_binds p
pl = pp_plan p
- plans = steps (cruxMode crux bc)
- bc' = bc `S.union` (S.fromList $ filterNTs (vo:vis))
+ plans = steps (cruxMode bc crux)
+ bc' = bc `S.union` cruxVars crux
rc' = S.delete crux rc
in map (\act -> PP rc' bc' (score p act) (pl ++ act))
plans
Left df -> df : (go ps)
Right ps' -> go (ps'++ps)
-------------------------------------------------------------------------}}}
--- Costing Plans {{{
-
-simpleCost :: PartialPlan -> Action -> Cost
-simpleCost (PP { pp_score = osc }) act =
- osc + sum (map stepCost act)
- where
- stepCost :: DOpAMine -> Double
- stepCost x = case x of
- OPAssign _ _ -> 0
- OPCheck _ _ -> 1
- OPCheckFunctor _ _ _ -> 0
- OPGetArgs _ _ -> 0
- OPBuild _ _ _ -> 0
- OPCall _ _ _ -> 0
- OPIter o is _ -> fromIntegral $ length $ filter isFree (o:is)
- OPIndirEval _ _ -> 10
-
-------------------------------------------------------------------------}}}
--- ANF to Cruxes {{{
-
-eval_cruxes :: ANFState -> [Crux NTV]
-eval_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_evals
- where
- crux :: DVar -> EVF -> Crux NTV
- crux o (Left v) = (CFEval,[NTVar v],NTVar o)
- crux o (Right (TFunctor n as)) = (CFCall n,as,NTVar o)
- -- XXX Missing cases
-
-unif_cruxes :: ANFState -> [Crux NTV]
-unif_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_unifs
- where
- crux :: DVar -> FDT -> Crux NTV
- crux o (TString s) = (CFAssign,[NTString s], NTVar o)
- crux o (TNumeric n) = (CFAssign,[NTNumeric n], NTVar o)
- crux o (TFunctor x as) = (CFUnif x, as, NTVar o)
+initialPlanForCrux :: DVar -> DVar -> Crux DVar a -> Action
+initialPlanForCrux hi v cr = case cr of
+ CFCall o is f -> [ OPGetArgsIf is hi f $ length is, OPAssign o (NTVar v) ]
+ _ -> error "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.
-plan :: (Crux ModedNT -> [Action])
- -> (PartialPlan -> Action -> Cost)
- -> ANFState
- -> Crux NTV
- -> Maybe (Cost, Action)
-plan st sc anf cr@(_,ci,co) =
+--
+-- XXX If the intial entrypoint is nonlinear, we need to insert some
+-- checks into the plan. Fixing that is moderately invasive...
+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 (Cost, Action) -- ^ If there's a plan...
+plan st sc anf cr hi v =
let cruxes = eval_cruxes anf
++ unif_cruxes anf
initPlan = PP { pp_cruxes = S.delete cr (S.fromList cruxes)
- , pp_binds = S.fromList $ filterNTs (co:ci)
+ , pp_binds = cruxVars cr
, pp_score = 0
- , pp_plan = []
+ , pp_plan = initialPlanForCrux hi v cr
}
in case stepAgenda st sc [initPlan] of
[] -> Nothing
plans -> Just $ L.minimumBy (O.comparing fst) plans
-planEachEval anf =
- map (\c -> (c, plan possible simpleCost anf c))
- $ filter (\(f,_,_) -> case f of
- CFCall f' -> not $ isMath f'
- _ -> False )
+planEachEval :: DVar -> DVar -> ANFState -> [(DFunctAr, Maybe (Cost,Action))]
+planEachEval hi v anf =
+ map (\(c,fa) -> (fa, plan possible simpleCost anf c hi v))
+ $ MA.mapMaybe (\c -> case c of
+ CFCall _ is f | not $ isMath f
+ -> Just $ (c,(f,length is))
+ _ -> Nothing )
$ eval_cruxes anf
+------------------------------------------------------------------------}}}
+-- Adorned Queries {{{
+
+-- 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 = go S.empty
+ where
+ go x [] = x
+ 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
+
------------------------------------------------------------------------}}}
-- Experimental Detritus {{{
+{-
+filterNTs :: [NT v] -> [v]
+filterNTs = MA.mapMaybe isNTVar
+ where
+ isNTVar (NTVar x) = Just x
+ isNTVar _ = Nothing
+
+ntMode :: BindChart -> NTV -> Mode
+ntMode c (NTVar v) = varMode c v
+ntMode _ (NTString _) = MBound
+ntMode _ (NTNumeric _) = MBound
+-}
+
testPlanRule x =
let (_,anf) = runNormalize $ normRule (unsafeParse DP.drule x)
- in planEachEval anf
+ in planEachEval "HEAD" "VALUE" anf
main :: IO ()
main = mapM_ (\(c,msp) -> do
Nothing -> putStrLn "NO PLAN"
putStrLn "")
$ testPlanRule
- -- $ "fib(X) :- fib(X-1) + fib(X-2)"
- $ "path(pair(Y,Z),V) min= path(pair(X,Y),U) + cost(X,Y,Z,U,V)."
- -- $ "goal += f(&pair(Y,Y))." --
+ -- "fib(X) :- fib(X-1) + fib(X-2)"
+ -- "path(pair(Y,Z),V) min= path(pair(X,Y),U) + cost(X,Y,Z,U,V)."
+ "goal += f(&pair(Y,Y))."
------------------------------------------------------------------------}}}
projects / dyna2 / commitdiff