From f33933934ff74e7b2c531d75bcb2cb343e8d8788 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Mon, 10 Dec 2012 02:59:32 -0500 Subject: [PATCH] Yet another stab at ANF --- src/Dyna/Analysis/ANF.hs | 52 +++-- src/Dyna/Analysis/Aggregation.hs | 7 +- src/Dyna/Analysis/RuleMode.hs | 358 ++++++++++++++++++------------- src/Dyna/Backend/Python.hs | 66 +++++- 4 files changed, 298 insertions(+), 185 deletions(-) diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 65fb413..f7bdf6c 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -37,6 +37,9 @@ -- 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. @@ -62,7 +65,7 @@ {-# LANGUAGE OverloadedStrings #-} module Dyna.Analysis.ANF ( - ANFState(..), NT(..), FDT, NTV, EVF, FDR(..), + ANFState(..), NT(..), FDT, NTV, ENF, EVF, FDR(..), normTerm, normRule, runNormalize, printANF ) where @@ -131,17 +134,19 @@ data NT v = NTNumeric (Either Integer Double) -- | 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])] } @@ -160,16 +165,17 @@ newEval pfx t = do 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) }) @@ -284,6 +290,8 @@ 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 + selfdispos <- asks $ flip ($) (f,length as) . ad_self_dispos let dispos = mergeDispositions selfdispos c @@ -291,8 +299,8 @@ normTerm_ c ss (P.TFunctor f as) = do 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? @@ -341,24 +349,24 @@ 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 (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 ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/Aggregation.hs b/src/Dyna/Analysis/Aggregation.hs index e52049a..3eb4ffb 100644 --- a/src/Dyna/Analysis/Aggregation.hs +++ b/src/Dyna/Analysis/Aggregation.hs @@ -21,7 +21,7 @@ import Dyna.XXX.DataUtils type AggMap = M.Map DFunctAr DAgg ------------------------------------------------------------------------}}} --- Processing {{{ +-- Associate each item with an aggregator {{{ -- XXX These functions really would like to have span information, so they -- could report which line of the source caused an error. @@ -31,9 +31,8 @@ procANF (FRule h a _ _, AS { as_unifs = us }) = case M.lookup h us of Nothing -> Left $ "I can't process head-variables" Just t -> case t of - TString _ -> Left $ "Malformed rule with string head" - TNumeric _ -> Left $ "Malformed rule with numeric head" - TFunctor f as -> Right ((f,length as),a) + Left _ -> Left "Malformed head" + Right (f,as) -> Right ((f,length as),a) buildAggMap :: [(FDR, ANFState)] -> Either String AggMap buildAggMap = go (M.empty) diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index 0ce62a4..c979aca 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -11,7 +11,15 @@ {-# 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 @@ -26,15 +34,6 @@ import Dyna.Term.TTerm 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 {{{ @@ -43,53 +42,76 @@ data Mode = MBound | MFree deriving (Eq,Ord,Show) -- | 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 {{{ @@ -98,76 +120,75 @@ cruxMode (f,is,o) c = (f, map (mode c) is, mode c o) -- -- 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) @@ -176,27 +197,25 @@ possible (f,is,o) = case f of (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) @@ -207,21 +226,59 @@ possible (f,is,o) = case f of 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] @@ -230,11 +287,11 @@ stepPartialPlan steps score p = 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 @@ -248,75 +305,76 @@ stepAgenda st sc = go 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 @@ -328,8 +386,8 @@ 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))." ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Backend/Python.hs b/src/Dyna/Backend/Python.hs index 746a6c9..a693991 100644 --- a/src/Dyna/Backend/Python.hs +++ b/src/Dyna/Backend/Python.hs @@ -5,12 +5,16 @@ -- XXX This is terrible. Just terrible. -- Header material {{{ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Dyna.Backend.Python where +import Control.Arrow +import Control.Exception +import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Char @@ -20,6 +24,7 @@ import qualified Data.Map as M import qualified Data.Maybe as MA import qualified Data.Ord as O import qualified Data.Set as S +import qualified Data.Typeable as DT import qualified Debug.Trace as XT import Dyna.Analysis.ANF import Dyna.Analysis.Aggregation @@ -32,25 +37,68 @@ import Text.PrettyPrint.Free import qualified Text.Trifecta as T ------------------------------------------------------------------------}}} --- Preliminaries {{{ +-- 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) + +instance Exception TopLevelException ------------------------------------------------------------------------}}} -- Experimental Detritus {{{ +-- XXX This belongs elsewhere. +-- +-- XXX This guy wants span information. +combinePlans :: [(FDR,[(DFunctAr, Maybe (Cost,Action))])] -> + Either String (M.Map DFunctAr [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 = + case mca of + Nothing -> Left $ "No plan for " ++ (show c) + ++ " in " ++ (show fr) + Just (_,a) -> go' xs fr ys $ iora 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 + processFile fileName = do pr <- T.parseFromFileEx (P.dlines) fileName case pr of T.Failure td -> T.display td T.Success rs -> let urs = map (\(P.LRule x T.:~ _) -> x) rs - anfs = map (runNormalize . normRule) urs - eaggm = buildAggMap anfs - in -- Ensure that we have an aggregator plan - case eaggm of - Left e -> print e >> putStrLn "while building aggregator map." - Right aggm -> print "Got an agg plan..." - -- XXX now, build an update plan for each rule - + franfs = map (runNormalize . normRule) urs + in do + aggm <- case buildAggMap franfs of + Left e -> throw $ TLEAggPlan e + Right a -> return a + cPlans <- case combinePlans + $ map (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 + putStrLn "" + where + headVar = "_H" + valVar = "_V" ------------------------------------------------------------------------}}} -- Experimental Residuals? {{{ -- 2.50.1