From b46bc31ba348330f020a8b62010cefb5ff382de9 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 11 Dec 2012 16:31:20 -0500 Subject: [PATCH] Attempt to handle "is/2" in normalizer; fallout --- src/Dyna/Analysis/ANF.hs | 81 ++++++++++++++++++++++---------- src/Dyna/Analysis/Aggregation.hs | 4 +- src/Dyna/Analysis/RuleMode.hs | 76 +++++++++++++++++++++--------- src/Dyna/Backend/Python.hs | 74 ++++++++++++++++------------- src/Dyna/XXX/DataUtils.hs | 9 ++++ 5 files changed, 160 insertions(+), 84 deletions(-) diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 6600a22..4c95e2c 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -33,10 +33,8 @@ -- 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! @@ -87,6 +85,7 @@ import qualified Text.Trifecta as T 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 @@ -160,7 +159,8 @@ type ENF = Either NTV FDT 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])] } @@ -179,17 +179,27 @@ newEval pfx t = do 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) }) @@ -200,7 +210,6 @@ 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] @@ -294,6 +303,21 @@ normTerm_ c ss (P.TFunctor "*" [t T.:~ st]) = 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 @@ -310,7 +334,7 @@ normTerm_ c ss (P.TFunctor f as) = 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 @@ -319,7 +343,7 @@ normTerm_ c ss (P.TFunctor f as) = do 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) @@ -344,9 +368,9 @@ data FRule = FRule { fr_functor :: DVar -- timv: rename type to FRule? 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 ------------------------------------------------------------------------}}} @@ -357,25 +381,25 @@ normRule (P.Rule h a es r T.:~ span) = uncurry ($) $ runNormalize $ do -- 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)) @@ -387,7 +411,12 @@ printANF (FRule h a s result span (AS {as_evals = evals, as_unifs = unifs})) = 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 ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/Aggregation.hs b/src/Dyna/Analysis/Aggregation.hs index 76e5d48..eb08144 100644 --- a/src/Dyna/Analysis/Aggregation.hs +++ b/src/Dyna/Analysis/Aggregation.hs @@ -27,8 +27,8 @@ type AggMap = M.Map DFunctAr DAgg -- 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" diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index a3c6c5e..2507571 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -91,7 +91,8 @@ ntvOfMNT (NTNumeric n) = NTNumeric n -- 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) @@ -99,19 +100,21 @@ data Crux v n = CFCall v [v] DFunct 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 {{{ @@ -156,7 +159,14 @@ detOfDop x = case x of 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. @@ -176,8 +186,8 @@ possible cr = case cr of (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. @@ -197,6 +207,12 @@ possible cr = case cr of (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 @@ -245,13 +261,15 @@ eval_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_evals -- 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 {{{ @@ -310,12 +328,13 @@ stepPartialPlan steps score p = ) ++ 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 @@ -347,6 +366,11 @@ plan_ st sc anf mi = } 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 @@ -394,20 +418,26 @@ ntMode _ (NTString _) = MBound 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 ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Backend/Python.hs b/src/Dyna/Backend/Python.hs index 928b583..ebc4101 100644 --- a/src/Dyna/Backend/Python.hs +++ b/src/Dyna/Backend/Python.hs @@ -33,21 +33,47 @@ import Dyna.Analysis.Aggregation 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 @@ -88,34 +114,25 @@ pf f vs = pretty f <> (tupled $ map pretty vs) ------------------------------------------------------------------------}}} -- 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 @@ -157,13 +174,6 @@ printPlan fh fa mu (r, cost, dope) = do -- display plan 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)) @@ -189,12 +199,10 @@ processFile_ fileName fh = do $ 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 $ "# ==============" @@ -206,8 +214,8 @@ processFile_ fileName fh = do 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) diff --git a/src/Dyna/XXX/DataUtils.hs b/src/Dyna/XXX/DataUtils.hs index d7483fb..008fed6 100644 --- a/src/Dyna/XXX/DataUtils.hs +++ b/src/Dyna/XXX/DataUtils.hs @@ -4,6 +4,8 @@ module Dyna.XXX.DataUtils ( mapExists, mapForall, -- ** Upsertion mapUpsert, + -- ** Insertion into a map of lists + mapInOrApp, -- * 'Data.Set' utilities -- ** Quantification setExists, setForall @@ -35,3 +37,10 @@ mapUpsert k v m = 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 -- 2.50.1