From: Nathaniel Wesley Filardo Date: Mon, 10 Dec 2012 09:12:57 +0000 (-0500) Subject: Tweak ANF, etc.; clone pdope in Backend.Python X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=596909fb468ace1b2a18ca45ec8206905b81d9f7;p=dyna2 Tweak ANF, etc.; clone pdope in Backend.Python This commit is known to break Dyna.Analysis.RuleModeTest; sorry. --- diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index f7bdf6c..2d43b66 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -131,6 +131,13 @@ data NT v = NTNumeric (Either Integer Double) | NTVar v deriving (Eq,Ord,Show) +instance (Pretty v) => 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 @@ -349,11 +356,6 @@ printANF ((FRule h a e result), AS {as_evals = evals, as_unifs = unifs}) = , 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 :: FDT -> Doc e pft (fn,args) = parens $ hsep $ (pretty fn : (map pretty args)) @@ -363,7 +365,7 @@ printANF ((FRule h a e result), AS {as_evals = evals, as_unifs = unifs}) = pevf (Right t) = pft t penf :: ENF -> Doc e - penf (Left n) = pnt n + penf (Left n) = pretty n penf (Right t) = pft t pev x = valign $ map (\(y,z)-> parens $ pretty y <+> pevf z) $ M.toList x diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index c979aca..a672da9 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -122,10 +122,10 @@ cruxVars cr = case cr of -- Opcode Out In Ancillary data DOpAMine = OPAssign DVar NTV -- -+ - | OPCheck DVar NTV -- ++ + | OPCheck DVar DVar -- ++ | OPGetArgsIf [DVar] DVar DFunct Int -- -+ - | OPBuild DVar [NTV] DFunct -- -+ + | OPBuild DVar [DVar] DFunct -- -+ | OPCall DVar [NTV] DFunct -- -+ | OPIter (ModedVar) [ModedVar] DFunct -- ?? @@ -172,7 +172,7 @@ possible cr = case cr of (Left _, MF _) -> [] (Right _, MB o') -> let chk = "_chk" in [[ OPAssign chk ni - , OPCheck chk (NTVar o')]] + , OPCheck chk o']] (Left i', MB o') -> [[OPAssign i' (NTVar o')]] (Right _, MF o') -> [[OPAssign o' ni]] @@ -182,12 +182,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 (NTVar . varOfMV) is) funct]] + then [[OPBuild 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 $ length is) - : map (\(c,x) -> (OPCheck c (NTVar x))) cis + : map (\(c,x) -> (OPCheck c x)) cis ] where mkChks _ (MF i) = (i, Nothing) @@ -206,7 +206,7 @@ possible cr = case cr of MF o' -> [[OPCall o' is' funct]] MB o' -> let cv = "_chk" in [[OPCall cv is' funct - ,OPCheck cv (NTVar o') + ,OPCheck cv o' ]] -- Otherwise, we assume it's an extensional table and ask to iterate @@ -255,19 +255,28 @@ unif_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_unifs 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 (PP { pp_score = osc }) act = - osc + sum (map stepCost act) +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 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 + OPAssign _ _ -> 1 + OPCheck _ _ -> 2 + OPGetArgsIf _ _ _ _ -> 1 + OPBuild _ _ _ -> 1 + OPCall _ _ _ -> 1 + OPIter o is _ -> 2 * (fromIntegral $ length $ filter isFree (o:is)) + OPIndirEval _ _ -> 100 + + loops = fromIntegral . length . filter isLoop + + isLoop :: DOpAMine -> Bool + isLoop = (== DetNon) . detOfDop ------------------------------------------------------------------------}}} -- Planning {{{ @@ -315,14 +324,14 @@ initialPlanForCrux hi v cr = case cr of -- -- 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 = +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 + -> [(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) @@ -330,9 +339,13 @@ plan st sc anf cr hi v = , pp_score = 0 , pp_plan = initialPlanForCrux hi v cr } - in case stepAgenda st sc [initPlan] of - [] -> Nothing - plans -> Just $ L.minimumBy (O.comparing fst) plans + in stepAgenda st sc [initPlan] + +plan st sc anf cr hi v = + (\x -> case x of + [] -> Nothing + plans -> Just $ L.minimumBy (O.comparing fst) plans) + $ plan_ st sc anf cr hi v planEachEval :: DVar -> DVar -> ANFState -> [(DFunctAr, Maybe (Cost,Action))] planEachEval hi v anf = @@ -380,14 +393,14 @@ main :: IO () main = mapM_ (\(c,msp) -> do putStrLn $ show c case msp of - Just (s,p) -> do - putStrLn $ "SCORE: " ++ show s - forM_ p (putStrLn . show) - Nothing -> putStrLn "NO PLAN" + Nothing -> putStrLn "NO PLAN" + Just sps -> forM_ [sps] $ \(s,p) -> do + putStrLn $ "SCORE: " ++ show s + forM_ p (putStrLn . show) putStrLn "") - $ testPlanRule + $ take 1 $ 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))." + "path(pair(Y,Z),V) min= path(pair(X,Y),1,U) + cost(X,Y,Z,U,V)." + -- "goal += f(&pair(Y,Y))." ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/RuleModeTest.hs b/src/Dyna/Analysis/RuleModeTest.hs index 1b10550..02418c1 100644 --- a/src/Dyna/Analysis/RuleModeTest.hs +++ b/src/Dyna/Analysis/RuleModeTest.hs @@ -25,37 +25,34 @@ unspan (LRule x :~ _) = x prettyPlans src = let rules = map (toANF.unspan) $ unsafeParse dlines src - plans = map (planEachEval.snd) $ rules + plans = map (planEachEval "_H" "_V" . snd) $ rules in show $ (vcat $ zipWith pp plans rules) - -- XXX perhaps "base cases" of the universe (constants) should be interned if -- they are going to be used in terms. Probably want to skip doubles; Interning -- integers seems silly but not bad; interning strings seems like a good idea. - pp p ((FRule h a e result), _) = valign $ map f p where emit = "emit" <+> tupled [pretty h, pretty result] - f (c@(CFCall f, ns, n), Just plan) = valign [ "def update_" <> pretty f <> "(id, value):" -- TODO: need unique variable names for id and value + f (c@(CFCall n ns f), Just plan) = valign [ "def update_" <> pretty f <> "(id, value):" -- TODO: need unique variable names for id and value , "#" <+> pcrux c - , (tupled $ map pnt ns) <+> "= load(update_id)" -- TODO: should be all vars - , pnt n <+> "= value" -- TODO: return shouldn't be pnt + , (tupled $ map pretty ns) <+> "= load(update_id)" -- TODO: should be all vars + , pretty n <+> "= value" -- TODO: return shouldn't be pnt , pplan plan , emit] f (crux, Nothing) = error $ "Did not find a plan for " ++ (show $ pcrux crux) pplan (_, action) = valign $ map pdope action - pcrux (CFCall f, ns, n) = pnt n <+> equals <+> pred f ns + pcrux (CFCall n ns f) = pretty n <+> equals <+> pred f ns pdope (OPIndirEval _ _) = error "indirect evaluation not implemented" - pdope (OPAssign v val) = pretty v <+> equals <+> pnt val - pdope (OPCheck v val) = hsep ["assert", pretty v, "==", pnt val] + pdope (OPAssign v val) = pretty v <+> equals <+> pretty val + pdope (OPCheck v val) = hsep ["assert", pretty v, "==", pretty val] - pdope (OPGetArgs vs id) = tupled (map pretty vs) <+> equals <+> "peel" <> (parens $ pretty id) - pdope (OPCheckFunctor v f a) = "check" <+> pretty f <> tupled [text $ show a, pretty v] + pdope (OPGetArgsIf vs id f a) = "gaif" <+> tupled (map pretty vs) <+> equals <+> "peel" <> parens (pretty f <> "/" <> pretty a) <> (parens $ pretty id) pdope (OPBuild v vs f) = pretty v <+> equals <+> "build" <+> pred f vs pdope (OPCall v vs f) = pretty v <+> equals <+> "call" <+> pred f vs @@ -65,17 +62,11 @@ pp p ((FRule h a e result), _) = valign $ map f p "for" <+> (tupled $ filterBound mo) <+> "in" <+> pretty f <> slice mo - slice = brackets . sepBy "," . map (\x -> case x of (MF v) -> ":" ; (MB v) -> pnt v) + slice = brackets . sepBy "," . map (\x -> case x of (MF v) -> ":" ; (MB v) -> pretty v) filterBound = map (\(MF v) -> pretty v) . filter (not.isBound) - pred f vs = pretty f <> (tupled $ map pnt vs) - - pnt (NTNumeric (Left x)) = pretty x - pnt (NTNumeric (Right x)) = pretty x - pnt (NTString s) = dquotes (pretty s) - pnt (NTVar v) = pretty v - + pred f vs = pretty f <> (tupled $ map pretty vs) writePlans file = do contents <- B.readFile file diff --git a/src/Dyna/Backend/Python.hs b/src/Dyna/Backend/Python.hs index a693991..ac83dc4 100644 --- a/src/Dyna/Backend/Python.hs +++ b/src/Dyna/Backend/Python.hs @@ -12,7 +12,7 @@ module Dyna.Backend.Python where -import Control.Arrow +import qualified Control.Arrow as A import Control.Exception import Control.Monad import qualified Data.ByteString as B @@ -33,6 +33,7 @@ import Dyna.Term.TTerm import qualified Dyna.ParserHS.Parser as P import Dyna.XXX.PPrint import Dyna.XXX.TrifectaTest +import System.IO import Text.PrettyPrint.Free import qualified Text.Trifecta as T @@ -48,6 +49,35 @@ data TopLevelException = TLEAggPlan String instance Exception TopLevelException +------------------------------------------------------------------------}}} +-- DOpAMine Printout {{{ + +-- XXX This is ripped out of Dyna.Analysis.RuleModeTest and ported over. +-- Sorry, Tim. + +pdope :: DOpAMine -> Doc e +pdope (OPIndirEval _ _) = error "indirect evaluation not implemented" +pdope (OPAssign v val) = pretty v <+> equals <+> pretty val +pdope (OPCheck v val) = hsep ["assert", pretty v, "==", pretty val] +pdope (OPGetArgsIf vs id f a) = + tupled (map pretty vs) + <+> equals + <+> "peel" <> parens (pretty f <> "/" <> pretty a) + <> (parens $ pretty id) +pdope (OPBuild v vs f) = pretty v <+> equals <+> "build" <+> pf f vs +pdope (OPCall v vs f) = pretty v <+> equals <+> "call" <+> pf f vs +pdope (OPIter o m f) = + let mo = m ++ [o] in + "for" <+> (tupled $ filterBound mo) + <+> "in" <+> pretty f <> pslice mo + +pslice = brackets . sepBy "," + . map (\x -> case x of (MF v) -> ":" ; (MB v) -> pretty v) + +filterBound = map (\(MF v) -> pretty v) . filter (not.isBound) + +pf f vs = pretty f <> (tupled $ map pretty vs) + ------------------------------------------------------------------------}}} -- Experimental Detritus {{{ @@ -55,18 +85,18 @@ instance Exception TopLevelException -- -- XXX This guy wants span information. combinePlans :: [(FDR,[(DFunctAr, Maybe (Cost,Action))])] -> - Either String (M.Map DFunctAr [Action]) + Either String (M.Map DFunctAr [(Cost,Action)]) combinePlans = go (M.empty) where go m [] = Right m go m ((fr,cmca):xs) = go' xs fr cmca m go' xs _ [] m = go m xs - go' xs fr ((c,mca):ys) m = + go' xs fr ((fa,mca):ys) m = case mca of - Nothing -> Left $ "No plan for " ++ (show c) + Nothing -> Left $ "No plan for " ++ (show fa) ++ " in " ++ (show fr) - Just (_,a) -> go' xs fr ys $ iora c a m + Just ca -> go' xs fr ys $ iora fa ca m -- Insert OR Append iora :: (Ord k) => k -> v -> M.Map k [v] -> M.Map k [v] @@ -87,19 +117,24 @@ processFile fileName = do Left e -> throw $ TLEAggPlan e Right a -> return a cPlans <- case combinePlans - $ map (second $ planEachEval headVar valVar) + $ map (A.second $ planEachEval headVar valVar) franfs of Left e -> throw $ TLEUpdPlan e Right a -> return a forM_ (M.toList cPlans) $ \(c,ps) -> do print c - forM_ ps $ \p -> do - print ps + forM_ ps $ \(c,p) -> do + putStrLn $ "# Cost: " ++ (show c) + displayIO stdout $ renderPretty 1.0 100 $ vsep $ map pdope p putStrLn "" + putStrLn ";" + putStrLn "" where headVar = "_H" valVar = "_V" +-- TEST: processFile "examples/cky.dyna" + ------------------------------------------------------------------------}}} -- Experimental Residuals? {{{