-- we need to end up. Especially of note is that we do not yet parse any
-- sort of pragmas for augmenting our disposition list.
--
--- XXX The handling for "is/2" is probably wrong. Right now it's not
--- 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 The handling for "is/2" is probably wrong, but differently wrong than
+-- before, at least.
--
-- XXX We really should do some CSE/GVN somewhere right after this pass, but
-- be careful about linearity!
import qualified Dyna.ParserHS.Parser as P
import Dyna.Term.TTerm
+import Dyna.XXX.DataUtils (mapInOrApp)
import Dyna.XXX.PPrint (valign)
-- import Dyna.Test.Trifecta -- XXX
data ANFState = AS
{ as_next :: !Int
, as_evals :: M.Map DVar EVF
- , as_unifs :: M.Map DVar ENF
+ , as_assgn :: M.Map DVar ENF
+ , as_unifs :: [(DVar,DVar)]
, 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 -> ENF -> m DVar
-newUnif pfx t = do
+newAssign :: (MonadState ANFState m) => String -> ENF -> m DVar
+newAssign pfx t = do
n <- nextVar pfx
- uns <- gets as_unifs
- modify (\s -> s { as_unifs = M.insert n t uns })
+ uns <- gets as_assgn
+ modify (\s -> s { as_assgn = 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 (Left $ NTString x)
-newUnifNT pfx (NTNumeric x) = newUnif pfx (Left $ NTNumeric x)
+newAnnot :: (MonadState ANFState m)
+ => DVar -> T.Spanned (Annotation DTerm) -> m ()
+newAnnot v a = do
+ modify (\s -> s { as_annot = mapInOrApp v a (as_annot s) })
+
+newAssignNT :: (MonadState ANFState m) => String -> NTV -> m DVar
+newAssignNT _ (NTVar x) = return x
+newAssignNT pfx (NTString x) = newAssign pfx (Left $ NTString x)
+newAssignNT pfx (NTNumeric x) = newAssign pfx (Left $ NTNumeric x)
+
+doUnif :: (MonadState ANFState m) => DVar -> DVar -> m ()
+doUnif v w = if v == w
+ then return ()
+ else modify (\s -> s { as_unifs = (v,w):(as_unifs s) })
newWarn :: (MonadState ANFState m) => B.ByteString -> [T.Span] -> m ()
newWarn msg loc = modify (\s -> s { as_warns = (msg,loc):(as_warns s) })
-- XXX These should be read from declarations
dynaFunctorArgDispositions :: (DFunct, Int) -> [ArgDispos]
dynaFunctorArgDispositions x = case x of
- ("is", 2) -> [ADQuote,ADEval]
-- evaluate arithmetic / math
("exp", 1) -> [ADEval]
("log", 1) -> [ADEval]
return nt
_ -> return nt
+-- "is/2" is sort of exciting. We normalize the second argument in an
+-- evaluation context and the first in a quoted context. Then, if the
+-- result is quoted, we simply build up some structure. If it's evaluated,
+-- on the other hand, we reduce it to a unification of these two pieces and
+-- return (XXX what ought to be) a unit.
+normTerm_ c ss (P.TFunctor "is" [x T.:~ sx, v T.:~ sv]) = do
+ nx <- normTerm_ (ECFunctor, ADQuote) (sx:ss) x >>= newAssign "_i" . Left
+ nv <- normTerm_ (ECFunctor, ADEval ) (sv:ss) v >>= newAssign "_i" . Left
+ case c of
+ (_,ADEval) -> do
+ _ <- doUnif nx nv
+ return $ NTNumeric (Left 42) -- XXX ought to be NTUnit
+ _ -> do
+ NTVar `fmap` newAssign "_u" (Right ("is",[nx,nv]))
+
-- Annotations are stripped of their span information
--
-- XXX this is probably the wrong thing to do
normas <- mapM (\(a T.:~ s,d) -> normTerm_ (ECFunctor,d) (s:ss) a)
(zip as argdispos)
- normas' <- mapM (newUnifNT "_x") normas
+ normas' <- mapM (newAssignNT "_x") normas
selfdispos <- asks $ flip ($) (f,length as) . ad_self_dispos
fmap NTVar $
case dispos of
ADEval -> newEval "_f" . Right
- ADQuote -> newUnif "_u" . Right
+ ADQuote -> newAssign "_u" . Right
$ (f,normas')
normTerm :: (Functor m, MonadState ANFState m, MonadReader ANFDict m)
normRule :: T.Spanned P.Rule -- ^ Term to digest
-> FRule
normRule (P.Rule h a es r T.:~ span) = uncurry ($) $ runNormalize $ do
- nh <- normTerm False h >>= newUnifNT "_h"
- nr <- normTerm True r >>= newUnifNT "_r"
- nes <- mapM (\e -> normTerm True e >>= newUnifNT "_c") es
+ nh <- normTerm False h >>= newAssignNT "_h"
+ nr <- normTerm True r >>= newAssignNT "_r"
+ nes <- mapM (\e -> normTerm True e >>= newAssignNT "_c") es
return $ FRule nh a nes nr span
------------------------------------------------------------------------}}}
-- Use as @runNormalize nRule
runNormalize :: ReaderT ANFDict (State ANFState) a -> (a, ANFState)
runNormalize =
- flip runState (AS 0 M.empty M.empty M.empty []) .
+ flip runState (AS 0 M.empty M.empty [] M.empty []) .
flip runReaderT (AD dynaFunctorArgDispositions dynaFunctorSelfDispositions)
------------------------------------------------------------------------}}}
-- Pretty Printer {{{
printANF :: FRule -> Doc e
-printANF (FRule h a s result span (AS {as_evals = evals, as_unifs = unifs})) =
+printANF (FRule h a s result span
+ (AS {as_evals = evals, as_assgn = assgn, as_unifs = unifs})) =
";;" <+> (text $ show span) `above` (
parens $ (pretty a)
<+> valign [ (pretty h)
, parens $ text "side" <+> (valign $ map pretty s)
- , parens $ text "evals" <+> (pev evals)
- , parens $ text "unifs" <+> (pun unifs)
+ , parens $ text "evals" <+> pev
+ , parens $ text "unifs" <+> pun
, parens $ text "result" <+> (pretty result)
]
)
where
-
pft :: FDT -> Doc e
pft (fn,args) = parens $ hsep $ (pretty fn : (map pretty args))
penf (Left n) = pretty n
penf (Right t) = pft t
- 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
+ pev = valign $ map (\(y,z)-> parens $ pretty y <+> pevf z)
+ $ M.toList evals
+
+ pun = valign $ map (\(y,z)-> parens $ pretty y <+> penf z)
+ (M.toList assgn)
+ ++ map (\(y,z) -> parens $ pretty y <+> pretty z)
+ unifs
------------------------------------------------------------------------}}}
-- could report which line of the source caused an error.
procANF :: FRule -> Either String (DFunctAr, DAgg)
-procANF (FRule h a _ _ _ (AS { as_unifs = us })) =
- case M.lookup h us of
+procANF (FRule h a _ _ _ (AS { as_assgn = as })) =
+ case M.lookup h as of
Nothing -> Left $ "I can't process head-variables"
Just t -> case t of
Left _ -> Left "Malformed head"
-- Cruxes {{{
data Crux v n = CFCall v [v] DFunct
- | CFUnif v [v] DFunct
+ | CFStruct v [v] DFunct
+ | CFUnif v v
| CFAssign v n
| CFEval v v
deriving (Eq,Ord,Show)
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
+ 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)
where
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)
+ 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]
------------------------------------------------------------------------}}}
-- DOpAMine {{{
type Action = [DOpAMine]
-- XXX we shouldn't need to know this
-isMath f = f `elem` ["^", "+", "-", "*", "/"]
+--
+-- XXX please observe duplication of knowledge with
+-- Dyna.Analysis.ANF.dynaFunctorArgDispositions
+--
+-- 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.
(Left i', MB o') -> [[OPAssign i' (NTVar o')]]
(Right _, MF o') -> [[OPAssign o' ni]]
- -- Unification
- CFUnif o is funct ->
+ -- Structure building
+ CFStruct o is funct ->
case o of
-- If the output is free, the only supported case is when all
-- inputs are known.
(is',mcis) = unzip $ zipWith mkChks [0::Int ..] is
cis = MA.catMaybes mcis
+ -- 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
-- XXX Missing cases
unif_cruxes :: ANFState -> [Crux DVar NTV]
-unif_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_unifs
+unif_cruxes (AS { as_assgn = assigns, as_unifs = unifs }) =
+ M.foldrWithKey (\o i -> (crux o i :)) [] assigns
+ ++ map (uncurry CFUnif) 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
+ crux o (Right (f,as)) = CFStruct o as f
------------------------------------------------------------------------}}}
-- Costing Plans {{{
) ++ ps
) [] rc
-stepAgenda st sc = go
+stepAgenda st sc = go []
where
- go [] = []
- go (p:ps) = case stepPartialPlan st sc p of
- Left df -> df : (go ps)
- Right ps' -> go (ps'++ps)
+ go [] [] = []
+ go (r:rs) [] = go rs r
+ go rs (p:ps) = case stepPartialPlan st sc p of
+ Left df -> df : (go rs ps)
+ Right ps' -> go (ps':rs) ps
initialPlanForCrux :: (Crux DVar a, DVar, DVar) -> Action
initialPlanForCrux (cr, hi, v) = case cr of
}
in stepAgenda st sc [initPlan]
+plan :: (Crux (ModedVar) (ModedNT) -> [Action])
+ -> (PartialPlan -> Action -> Cost)
+ -> ANFState
+ -> Maybe (Crux DVar NTV, DVar, DVar)
+ -> Maybe (Cost, Action)
plan st sc anf mi =
(\x -> case x of
[] -> Nothing
ntMode _ (NTNumeric _) = MBound
-}
-testPlanRule x = planEachEval "HEAD" "VALUE" $ normRule (unsafeParse DP.drule x)
+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
+ CFCall _ is f | not $ isMath f
+ -> Just $ (c,(f,length is))
+ _ -> Nothing )
+ $ eval_cruxes anf
+
+
+
+testPlanRule x = planEachEval_ "HEAD" "VALUE" $ normRule (unsafeParse DP.drule x)
-main :: IO ()
-main = mapM_ (\(c,msp) -> do
+run = mapM_ (\(c,msp) -> do
putStrLn $ show c
case msp of
- Nothing -> putStrLn "NO PLAN"
- Just sps -> forM_ [sps] $ \(s,p) -> do
- putStrLn $ "SCORE: " ++ show s
+ [] -> putStrLn "NO PLAN"
+ sps -> forM_ sps $ \(s,p) -> do
+ putStrLn $ "\n\nSCORE: " ++ show s
forM_ p (putStrLn . show)
putStrLn "")
- $ take 1 $ testPlanRule
- -- "fib(X) :- fib(X-1) + fib(X-2)"
- "path(pair(Y,Z),V) min= path(pair(X,Y),1,U) + cost(X,Y,Z,U,V)."
- -- "goal += f(&pair(Y,Y))."
+ . take 1 . testPlanRule
------------------------------------------------------------------------}}}
import Dyna.Analysis.RuleMode
import Dyna.Term.TTerm
import qualified Dyna.ParserHS.Parser as P
+import Dyna.XXX.DataUtils (mapInOrApp)
import Dyna.XXX.PPrint
import Dyna.XXX.TrifectaTest
import System.IO
import Text.PrettyPrint.Free
import qualified Text.Trifecta as T
+------------------------------------------------------------------------}}}
+-- Utilities {{{
+
+renderSpan (T.Span s e bs) =
+ T.prettyTerm s
+ <+> char '-'
+ <+> T.prettyTerm e
+ <+> colon
+ `above` (indent 2 (T.prettyTerm $ T.rendering s bs))
+
------------------------------------------------------------------------}}}
-- Top Level Exceptions {{{
--
-- Make the control flow a little cleaner by bailing out rather than
-- anything right-branching. Probably not what we actually want.
-data TopLevelException = TLEAggPlan String
- | TLEUpdPlan String
- deriving (DT.Typeable,Eq,Show)
+data TopLevelException = TLEAggPlan String
+ | TLENoUpdPlan FRule (DFunct,Int)
+ deriving (DT.Typeable)
+
+instance Eq TopLevelException where
+ (==) (TLENoUpdPlan (FRule h1 a1 e1 r1 s1 _) f1)
+ (TLENoUpdPlan (FRule h2 a2 e2 r2 s2 _) f2) =
+ h1 == h2 && a1 == a2 && e1 == e2
+ && r1 == r2 && s1 == s2 && f1 == f2
+
+ (==) (TLEAggPlan s1) (TLEAggPlan s2) = s1 == s2
+ (==) _ _ = False
+
+instance Show TopLevelException where
+ show (TLEAggPlan s) = "TLEAggPlan: " ++ s
+ show (TLENoUpdPlan r fa) = show $
+ text "TLENoUpdPlan" <+> text "for" <+> pretty fa <> line
+ <> printANF r
instance Exception TopLevelException
------------------------------------------------------------------------}}}
-- Experimental Detritus {{{
+-- | Return all plans for each functor/arity
+--
-- XXX This belongs elsewhere.
--
-- XXX This guy wants span information.
--
-- timv: might want to fuse these into one circuit
---
combinePlans :: [(FRule,[(DFunctAr, Maybe (Cost,Action))])] ->
- Either String (M.Map DFunctAr [(FRule, Cost, Action)]) -- all plans for functor/arity
- -- XXX: are FDR's unique keys? suppose a rule is repeated?
+ M.Map DFunctAr [(FRule, Cost, Action)]
combinePlans = go (M.empty)
where
- go m [] = Right m
+ go m [] = m
go m ((fr,cmca):xs) = go' xs fr cmca m
go' xs _ [] m = go m xs
go' xs fr ((fa,mca):ys) m =
case mca of
- Nothing -> Left $ "No plan for " ++ (show fa) -- timv: throw error here?
- ++ " in " ++ (show fr)
- Just (c,a) -> go' xs fr ys $ iora fa (fr,c,a) m
-
- -- Insert OR Append
- iora :: (Ord k) => k -> v -> M.Map k [v] -> M.Map k [v]
- iora k v m = M.alter (\mv -> Just $ v:nel mv) k m
- where
- nel Nothing = []
- nel (Just x) = x
-
+ Nothing -> throw $ TLENoUpdPlan fr fa
+ Just (c,a) -> go' xs fr ys $ mapInOrApp fa (fr,c,a) m
-- timv: consider flattening FRUle and ANFState
displayIO fh $ renderPretty 1.0 100
$ py fa mu r dope <> line
hPutStrLn fh ""
- where
- renderSpan (T.Span s e bs) =
- T.prettyTerm s
- <+> char '-'
- <+> T.prettyTerm e
- <+> colon
- `above` (indent 2 (T.prettyTerm $ T.rendering s bs))
$ map (\x -> (x, planInitializer x)) frs
in do
aggm <- case buildAggMap frs of
- Left e -> throw $ TLEAggPlan e -- multiple aggregators
- Right a -> return a
- cPlans <- case combinePlans -- crux plans
- $ map (\x -> (x, planEachEval headVar valVar x)) frs of
- Left e -> throw $ TLEUpdPlan e -- no plan found
- Right a -> return a
+ Left e -> throw $ TLEAggPlan e
+ Right x -> return x
+ cPlans <- return $! combinePlans -- crux plans
+ $ map (\x -> (x, planEachEval headVar valVar x)) frs
forM_ (M.toList cPlans) $ \(fa, ps) -> do -- plans aggregated by functor/arity
hPutStrLn fh ""
hPutStrLn fh $ "# =============="
forM_ initializers $ \(f,c,a) -> printPlan fh (findHeadFA f) Nothing (f,c,a)
where
- findHeadFA (FRule h _ _ _ _ (AS { as_unifs = us })) =
- case M.lookup h us of
+ findHeadFA (FRule 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)
mapExists, mapForall,
-- ** Upsertion
mapUpsert,
+ -- ** Insertion into a map of lists
+ mapInOrApp,
-- * 'Data.Set' utilities
-- ** Quantification
setExists, setForall
let (mo, m') = M.insertLookupWithKey (\_ _ _ -> v) k v m
r = Right m'
in maybe r (\o -> if o == v then r else Left o) mo
+
+-- XXX maybe consider generalizing this to any collection type?
+mapInOrApp :: (Ord k) => k -> v -> M.Map k [v] -> M.Map k [v]
+mapInOrApp k v m = M.alter (\mv -> Just $ v:nel mv) k m
+ where
+ nel Nothing = []
+ nel (Just x) = x
projects / dyna2 / commitdiff