From: Nathaniel Wesley Filardo Date: Tue, 18 Jun 2013 23:19:43 +0000 (-0400) Subject: Preliminary changes for ground backchaining X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=6c7b6844b3fe96c50866ed2844dd950f3e625459;p=dyna2 Preliminary changes for ground backchaining --- diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 96c2a7d..8a9ec42 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -62,7 +62,7 @@ module Dyna.Analysis.ANF ( SelfDispos(..), ArgDispos(..), EvalMarks, -- * Placeholders - evalCruxFA, findHeadFA, r_cruxes, + evalCruxFA, findHeadFA, r_cruxes, extractHeadVars ) where import Control.Lens @@ -472,4 +472,19 @@ findHeadFA h crs = MA.listToMaybe m (CStruct o is f) | o == h = Just (f,length is) m _ = Nothing +-- XXX There ought to be something better we could do here, possibly +-- involving unification. This is not very robust to changes. +extractHeadVars :: Rule -> Maybe (DFunct,[DVar]) +extractHeadVars (Rule { r_head = h + , r_ucruxes = us }) = + let hbuilds = MA.mapMaybe hs $ S.toList us + in case hbuilds of + [] -> Nothing + y:_ -> Just y + where + hs (CStruct v vs f) = if h == v then Just (f,vs) else Nothing + hs (CAssign _ _ ) = Nothing + hs (CEquals _ _ ) = Nothing + hs (CNotEqu _ _ ) = Nothing + ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/Mode/Mode.hs b/src/Dyna/Analysis/Mode/Mode.hs index c2a8fec..873f129 100644 --- a/src/Dyna/Analysis/Mode/Mode.hs +++ b/src/Dyna/Analysis/Mode/Mode.hs @@ -34,4 +34,8 @@ data QMode n = QMode deriving Show $(makeLenses ''QMode) +unpackModeInputs :: QMode n -> (n, [n]) +unpackModeInputs qm = ( fst $ _qmode_result qm + , map fst $ _qmode_args qm) + -- XXX Update Modes diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index 43a4258..e3f14a8 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -43,7 +43,7 @@ import Control.Monad.Identity import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.IntMap as IM --- import qualified Data.List as L +import qualified Data.List as L import qualified Data.Map as M import qualified Data.Maybe as MA import qualified Data.Set as S @@ -101,7 +101,7 @@ data BackendAction fbs = BAct -- | Builtin support hook for mode planning. Options are -- to return --- +-- -- * @Left False@ -- This functor is not built in -- -- * @Left True@ -- There is no plan for this mode @@ -139,7 +139,7 @@ fgn :: forall a m k . MCVT m DVar ~ VR DFunct (NIX DFunct) k, MCR m DVar) => DVar -> m a -> m a -> m a -> m a fgn v cf cg cn = do - ff <- v `subVN` (nHide IFree) + ff <- liftM (iIsFree . nExpose) $ expandV v gf <- v `subVN` (nHide $ IUniv UShared) case (ff,gf) of (True ,True ) -> dynacPanicStr "Variable is both free and ground" @@ -149,9 +149,12 @@ fgn v cf cg cn = do possible :: (Monad m) => BackendPossible fbs + -> (S.Set DFunctAr) + -> Bool + -> (DVar -> Bool) -> Crux DVar TBase -> SIMCT m DFunct (Actions fbs) -possible fp cr = +possible fp bcs co lf cr = case cr of -- XXX This is going to be such a pile. We really, really should have -- unification crank out a series of DOpAMine opcodes for us, but for @@ -166,17 +169,17 @@ possible fp cr = -- Assign or check Right (CAssign o i) -> - fgn o (runReaderT (unifyVU o) (UnifParams True False) + fgn o (runReaderT (unifyVU o) (UnifParams (lf o) False) >> return [ OPAsgn o (NTBase i) ]) (let chk = "_chk" in return [ OPAsgn chk (NTBase i), OPCheq chk o]) (throwError UFExDomain) Right (CEquals o i) -> fgn o (fgn i (throwError UFExDomain) - (runReaderT (unifyVV i o) (UnifParams True False) + (runReaderT (unifyVV i o) (UnifParams (lf o || lf i) False) >> return [ OPAsgn o (NTVar i) ]) (throwError UFExDomain)) - (fgn i (runReaderT (unifyVV i o) (UnifParams True False) + (fgn i (runReaderT (unifyVV i o) (UnifParams (lf o || lf i) False) >> return [ OPAsgn i (NTVar o) ]) (return [ OPCheq o i ]) (throwError UFExDomain)) @@ -218,20 +221,39 @@ possible fp cr = is <- mapM mkMV vis o <- mkMV vo case fp (funct,is,o) of - -- XXX Not a built-in, so we assume that it can be - -- iterated in full. - Left False -> do mapM_ bind (vo:vis) - return [OPIter o is funct DetNon Nothing] + Left False -> + if (funct,length is) `S.member` bcs + -- If this is a back-chained definition, check that it is all + -- ground and then go. + -- + -- XXX This should really be "check that it ascribes to one of + -- the declared modes" but we don't have those yet. + then do + mapM_ ensureBound vis + fgn vo (bind vo >> return [OPIter o is funct DetSemi Nothing]) + (let chk = "_chk" in return + [OPIter (MV chk mf mo) is funct DetSemi Nothing, + OPCheq chk vo]) + (throwError UFExDomain) + + -- XXX Not a built-in and not back-chained, so we assume + -- that it can be iterated in full. This is permitted only + -- when we're not restricted to constants only! + else if co + then throwError UFExDomain + else do mapM_ bind (vo:vis) + return [OPIter o is funct DetNon Nothing] -- Builtin called in improper mode; bail on this plan Left True -> throwError UFExDomain -- Builtin called in accessible mode; apply bindings and return - Right (BAct a m) -> do runReaderT - (mapM_ (uncurry $ flip unifyUnaliasedNV) m) - (UnifParams True True) -- XXX Live? + Right (BAct a m) -> do forM_ m $ \(v,vn) -> + runReaderT (unifyUnaliasedNV vn v) + (UnifParams (lf v) True) return a where + mf = nHide IFree mo = nHide (IUniv UShared) unifyVU v = unifyUnaliasedNV mo v mkMV v = do @@ -241,7 +263,7 @@ possible fp cr = ensureBound v = fgn v (throwError UFExDomain) (return ()) (throwError UFExDomain) - bind x = runReaderT (unifyVU x) (UnifParams False False) + bind x = runReaderT (unifyVU x) (UnifParams (lf x) False) ------------------------------------------------------------------------}}} -- Costing Plans {{{ @@ -340,7 +362,9 @@ stepPartialPlan poss score p = where step = S.fold (\crux ps -> let pl = pp_plan p - plan = runIdentity $ runSIMCT (poss crux) (pp_binds p) + plan = runIdentity $ flip runSIMCT (pp_binds p) + $ poss crux + rc' = S.delete crux (pp_cruxes p) in either (const ps) (\(act,bc') -> PP rc' bc' (score p act) (pl ++ act) @@ -349,10 +373,14 @@ stepPartialPlan poss score p = ) [] planner_ :: forall fbs . - (Crux DVar TBase -> SIMCT Identity DFunct (Actions fbs)) + ( (DVar -> Bool) + -> Crux DVar TBase + -> SIMCT Identity DFunct (Actions fbs)) -- ^ Available steps -> (PartialPlan fbs -> Actions fbs -> Cost) -- ^ Scoring function + -> (S.Set (Crux DVar TBase) -> DVar -> Bool) + -- ^ Hook for live variables -> S.Set (Crux DVar TBase) -- ^ Cruxes to be planned over -> Maybe (EvalCrux DVar, DVar, DVar) @@ -364,7 +392,7 @@ planner_ :: forall fbs . -- in the given cruxes) -> Either [PartialPlan fbs] [(Cost, Actions fbs)] -- ^ Plans and their costs -planner_ st sc cr mic ictx = runAgenda +planner_ st sc lf cr mic ictx = runAgenda $ PP { pp_cruxes = cr , pp_binds = ctx' , pp_score = 0 @@ -393,7 +421,7 @@ planner_ st sc cr mic ictx = runAgenda -> ((Cost,Actions fbs) -> M.Map Cost [PartialPlan fbs] -> x) -> (PartialPlan fbs, M.Map Cost [PartialPlan fbs]) -> x - go' kf ks (p, pq') = case stepPartialPlan st sc p of + go' kf ks (p, pq') = case stepPartialPlan (st (lf cr)) sc p of Right [] -> kf (Just p) pq' Left df -> ks df pq' Right ps' -> kf Nothing (foldr mioaPlan pq' ps') @@ -439,20 +467,23 @@ finalizePlan r d = d ++ [OPEmit (r_head r) (r_result r) (r_index r) -- -- XXX This has no idea what to do about non-range-restricted rules. planUpdate :: BackendPossible fbs + -> S.Set DFunctAr -> Rule -> (PartialPlan fbs -> Actions fbs -> Cost) -> S.Set (Crux DVar TBase) -- ^ Normal form -> (EvalCrux DVar, DVar, DVar) -> SIMCtx DVar -> Either [PartialPlan fbs] (Cost, Actions fbs) -planUpdate bp r sc anf mi ictx = fmap (second (finalizePlan r)) $ - bestPlan $ planner_ (possible bp) sc anf (Just mi) ictx +planUpdate bp bc r sc anf mi ictx = fmap (second (finalizePlan r)) $ + bestPlan $ planner_ (possible bp bc False) sc (\cs v -> v `S.member` allCruxVars cs) anf (Just mi) ictx -planInitializer :: BackendPossible fbs -> Rule +planInitializer :: BackendPossible fbs + -> S.Set DFunctAr + -> Rule -> Either [PartialPlan fbs] (Cost, Actions fbs) -planInitializer bp r = fmap (second (finalizePlan r)) $ +planInitializer bp bc r = fmap (second (finalizePlan r)) $ let cruxes = r_cruxes r in - bestPlan $ planner_ (possible bp) simpleCost cruxes Nothing + bestPlan $ planner_ (possible bp bc False) simpleCost (\cs v -> v `S.member` allCruxVars cs) cruxes Nothing (allFreeSIMCtx $ S.toList $ allCruxVars cruxes) -- | Given a particular crux and the remaining evaluation cruxes in a rule, @@ -515,10 +546,11 @@ handleDoubles vc e r = S.fold (go e) S.empty r -- feeds that to the planner. The former will also be useful in dumping -- more accurate ANF. planEachEval :: BackendPossible fbs -- ^ The backend's primitive support + -> S.Set DFunctAr -> (DFunctAr -> Bool) -- ^ Indicator for constant function -> Rule -> [(Int, Either [PartialPlan fbs] (Cost, DVar, DVar, Actions fbs))] -planEachEval bp cs r = +planEachEval bp bc cs r = map (\(n,cr) -> let -- pending eval cruxes @@ -541,15 +573,17 @@ planEachEval bp cs r = $ allCruxVars $ S.insert (Left cr) cruxes' - in (n, varify $ planUpdate bp r simpleCost cruxes' (mic $ snd cr) ictx)) + in (n, varify $ planUpdate bp bc r simpleCost cruxes' (mic $ snd cr) ictx)) -- Filter out non-constant evaluations -- -- XXX This instead should look at the update modes of each evaluation $ MA.mapMaybe (\ec -> case ec of - (n, CCall _ is f) | not (cs (f,length is)) - -> Just (n, ec) - (_, CCall _ _ _) -> Nothing - (n, CEval _ _ ) -> Just (n,ec)) + (n, CCall _ is f) -> let fa = (f,length is) + in if not (cs fa) + && not (fa `S.member` bc) + then Just (n, ec) + else Nothing + (n, CEval _ _ ) -> Just (n,ec)) -- Grab all evaluations $ ecs @@ -567,22 +601,42 @@ planEachEval bp cs r = varHead = "__i" varVal = "__v" -{- -planGroundBackchain :: BackendPossible fbs - -> Rule - -> Maybe (Cost, DVar, Action fbs) -planGroundBackchain bp (Rule { r_anf = anf, r_head = h }) = - varify - $ bestPlan - $ anfPlanner_ (possible bp) simpleCost anf Nothing (S.singleton h) +data PBCError fbs = PBCWrongFunctor DFunct + | PBCWrongArity Int + | PBCNoPlan [PartialPlan fbs] + | PBCBadRule + +planBackchain :: BackendPossible fbs + -> S.Set DFunctAr + -> (DFunct, QMode (NIX DFunct)) + -> Rule + -> Either (PBCError fbs) ([DVar],(Cost, Actions fbs)) +planBackchain bp bc (f,qm) r = + case extractHeadVars r of + Nothing -> Left PBCBadRule + Just (f',hvs) -> if f /= f' + then Left $ PBCWrongFunctor f' + else let (mri,mais) = unpackModeInputs qm + in if length mais /= length hvs + then Left $ PBCWrongArity (length hvs) + else go $ zip (r_result r:hvs) (mri:mais) where - varify = fmap $ \(c,a) -> (c,h,a) - -planBackchains :: BackendPossible fbs - -> Rule - -> M.Map [Mode] (Cost, [DVar], Action fbs) -planBackchains bp (Rule { r_anf = anf, r_head = h }) --} + go l = let + (lf,lb) = L.partition (iIsFree . nExpose . snd) l + + ctx1 = ctxFromBindings $ + (map (\x -> (x,tf)) $ S.toList $ allCruxVars $ r_cruxes r) + ++ lf ++ lb + in either (Left . PBCNoPlan) + (Right . (\x -> (map fst lb,x)) + . fmap (finalizePlan r)) $ + bestPlan $ planner_ (possible bp bc True) simpleCost + (\cs v -> (v == r_head r) + || (v == r_result r) + || (v `S.member` allCruxVars cs)) + (r_cruxes r) Nothing ctx1 + + tf = nHide IFree ------------------------------------------------------------------------}}} -- Update plan combination {{{ @@ -624,39 +678,6 @@ combineUpdatePlans = go (M.empty) id (IM.lookup n (r_ecruxes fr)) -------------------------------------------------------------------------}}} --- Backward chaining plan combination {{{ - -{- -type QueryEvalMap fbs = M.Map (Maybe DFunctAr) - [(Rule, Cost, DVar, Action fbs)] - -combineQueryPlans :: [(Rule, Maybe (Cost, DVar, Action fbs))] - -> QueryEvalMap fbs -combineQueryPlans = go (M.empty) - where - go m [] = m - go m ((fr,mcva):xs) = go' xs fr mcva m - - go' _ fr Nothing _ = dynacUserErr - $ "No query plan for rule at" - <+> (prettySpanLoc $ r_span fr) - go' xs fr (Just (c,v,a)) m = go (mapInOrCons (findHeadFA fr) - (fr,c,v,a) - m) - xs - - -- XXX This is unforunate and wrong, but our ANF is not quite right to - -- let us do this right. See also Dyna.Backend.Python's use of this - -- function. - findHeadFA (Rule _ 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)) -> Just (f, length a) --} - - ------------------------------------------------------------------------}}} -- Adorned Queries {{{ diff --git a/src/Dyna/Backend/BackendDefn.hs b/src/Dyna/Backend/BackendDefn.hs index ff3c11d..1e82a02 100644 --- a/src/Dyna/Backend/BackendDefn.hs +++ b/src/Dyna/Backend/BackendDefn.hs @@ -14,7 +14,7 @@ import Dyna.Analysis.DOpAMine (BackendRenderDopIter) import Dyna.Analysis.RuleMode ( Actions, BackendPossible, Cost, UpdateEvalMap {-, QueryEvalMap -}) -import Dyna.Term.TTerm (DFunctAr) +import Dyna.Term.TTerm (DFunctAr,DVar) import System.IO (Handle) import qualified Text.PrettyPrint.Free as PP @@ -25,8 +25,9 @@ import qualified Text.PrettyPrint.Free as PP type BackendDriver bs = AggMap -- ^ Aggregation -> UpdateEvalMap bs -- ^ Rule update - -- -> QueryEvalMap bs -- ^ Rule query -> [(Rule,Cost,Actions bs)] -- ^ Initializers + -> S.Set DFunctAr -- ^ Ground backchains + -> [(DFunctAr,Rule,([DVar],(Cost,Actions bs)))] -- ^ GBC plans -> (forall e . PP.Doc e) -- ^ Parser persistence -> Handle -- ^ Output -> IO () diff --git a/src/Dyna/Backend/NoBackend.hs b/src/Dyna/Backend/NoBackend.hs index 7a1e81f..a3ce115 100644 --- a/src/Dyna/Backend/NoBackend.hs +++ b/src/Dyna/Backend/NoBackend.hs @@ -45,7 +45,7 @@ noBackend = Backend , be_driver = driver } -driver _ _ {-_-} _ _ fh = hPutStrLn fh "No backend selected; stopping." +driver _ _ _ _ _ _ fh = hPutStrLn fh "No backend selected; stopping." ------------------------------------------------------------------------}}} -- Primitive operations {{{ @@ -58,7 +58,7 @@ data PrimOp = PO primOps :: DFunctAr -> Maybe [QMode (NIX DFunct)] -- XXX ,UMode primOps = go where - go ("-" ,1) = Just [miaod 1 Det ] + go ("-" ,1) = Just $ [miaod 1 Det ] ++ opinvd 1 Det go ("^" ,2) = Just [miaod 2 Det ] go ("|" ,2) = Just [miaod 2 Det ] go ("-" ,2) = Just $ [miaod 2 Det ] ++ opinvd 2 Det diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs index 6c7139c..63cbe8f 100644 --- a/src/Dyna/Backend/Python/Backend.hs +++ b/src/Dyna/Backend/Python/Backend.hs @@ -13,7 +13,7 @@ module Dyna.Backend.Python.Backend (pythonBackend) where -- import Control.Applicative ((<*)) -- import qualified Control.Arrow as A --- import Control.Exception +import Control.Exception (assert) import Control.Lens ((^.)) import Control.Monad import Control.Monad.State @@ -219,14 +219,14 @@ piterate vs = if length vs == 0 then "_" -- filterGround = map (^.mv_var) . filter (not.nGround.(^.mv_mi)) -- | Render a single dopamine opcode or its surrogate -pdope_ :: DOpAMine PyDopeBS -> State Int (Doc e) -pdope_ (OPIndr _ _) = dynacSorry "indirect evaluation not implemented" -pdope_ (OPAsgn v val) = return $ pretty v <+> equals <+> pretty val -pdope_ (OPCheq v val) = return $ "if" <+> pretty v <+> "!=" +pdope_ :: S.Set DFunctAr -> DOpAMine PyDopeBS -> State Int (Doc e) +pdope_ _ (OPIndr _ _) = dynacSorry "indirect evaluation not implemented" +pdope_ _ (OPAsgn v val) = return $ pretty v <+> equals <+> pretty val +pdope_ _ (OPCheq v val) = return $ "if" <+> pretty v <+> "!=" <+> pretty val <> ": continue" -pdope_ (OPCkne v val) = return $ "if" <+> pretty v <+> "==" +pdope_ _ (OPCkne v val) = return $ "if" <+> pretty v <+> "==" <+> pretty val <> ": continue" -pdope_ (OPPeel vs i f _) = return $ +pdope_ _ (OPPeel vs i f _) = return $ "try:" `above` (indent 4 $ tupledOrUnderscore vs <+> equals @@ -234,17 +234,17 @@ pdope_ (OPPeel vs i f _) = return $ ) -- you'll get a "TypeError: 'NoneType' is not iterable." `above` "except (TypeError, AssertionError): continue" -pdope_ (OPWrap v vs f) = return $ pretty v +pdope_ _ (OPWrap v vs f) = return $ pretty v <+> equals <+> "build" <> (parens $ pfas f vs <> comma <> (sepBy "," $ map pretty vs)) -pdope_ (OPIter v vs _ Det (Just (PDBS c))) = return $ pretty (v^.mv_var) +pdope_ _ (OPIter v vs _ Det (Just (PDBS c))) = return $ pretty (v^.mv_var) <+> equals <+> c v vs -pdope_ (OPIter v vs f d (Just (PDBS c))) = dynacPanic $ +pdope_ _ (OPIter v vs f d (Just (PDBS c))) = dynacPanic $ "Unexpected determinism flag (at python code gen):" <+> pretty v <+> pretty vs @@ -252,7 +252,21 @@ pdope_ (OPIter v vs f d (Just (PDBS c))) = dynacPanic $ <+> text (show d) <+> parens (pretty $ c v vs) -pdope_ (OPIter o m f _ Nothing) = do +-- XXX This works only for the special case at hand (thus the asserts) +pdope_ bc (OPIter o m f DetSemi Nothing) | (f,length m) `S.member` bc = + return $ + assert (iIsFree $ nExpose $ o^.mv_mi) $ + assert (all (not . iIsFree . nExpose . _mv_mi) m) $ + vcat + [ pretty (o^.mv_var) + <+> equals + <+> "gbc" <> brackets (pfas f m) + <> tupled (map (pretty . _mv_var) m) + , "if" <+> pretty (o^.mv_var) <+> "is not None" <> colon + ] + +pdope_ bc (OPIter o m f _ Nothing) = + assert (not $ (f,length m) `S.member` bc) $ do i <- incState return $ let mo = m ++ [o] in "for" <+> "d" <> pretty i <> "," <> piterate m <> comma <> (ground2underscore o) @@ -261,7 +275,7 @@ pdope_ (OPIter o m f _ Nothing) = do -- XXX Ought to make i and vs conditional on... doing debugging or the -- aggregator for this head caring. The latter is a good bit more -- advanced than we are right now. -pdope_ (OPEmit h r i vs) = do +pdope_ _ (OPEmit h r i vs) = do ds <- get -- A python map of variable name to value @@ -276,14 +290,14 @@ pdope_ (OPEmit h r i vs) = do ] -- | Render a dopamine sequence's checks and loops above a (indended) core. -pdope :: Actions PyDopeBS -> Doc e -pdope _d = (indent 4 $ "for _ in [None]:") - `above` (indent 8 $ evalState (go _d) 0) +pdope :: S.Set DFunctAr -> Actions PyDopeBS -> Doc e +pdope bc _d = (indent 4 $ "for _ in [None]:") + `above` (indent 8 $ evalState (go _d) 0) where go [] = return empty go (x:xs) = let indents = case x of OPIter _ _ _ d _ -> d /= Det ; _ -> False in do - x' <- pdope_ x + x' <- pdope_ bc x xs' <- go xs return $ x' `above` ((if indents then indent 4 else id) xs') @@ -297,40 +311,68 @@ printPlanHeader r c mn = do , "Cost: " <+> (pretty c) , "'''"] -printInitializer :: Handle -> Rule -> Cost -> Actions PyDopeBS -> IO () -printInitializer fh rule cost dope = do +printInitializer :: Handle -> S.Set DFunctAr + -> Rule -> Cost -> Actions PyDopeBS -> IO () +printInitializer fh bc rule cost dope = do displayIO fh $ renderPretty 1.0 100 $ "def" <+> char '_' <> tupled ["emit"] <> colon `above` (indent 4 $ printPlanHeader rule cost Nothing) - `above` pdope dope + `above` pdope bc dope <> line <> "initializers.append((" <> (pretty $ r_index rule) <> ", _" <> "))" <> line <> line <> line -printUpdate :: Handle -> Rule -> Cost -> Int -> Maybe DFunctAr -> (DVar, DVar) +printUpdate :: Handle + -> S.Set DFunctAr + -> Rule -> Cost -> Int -> Maybe DFunctAr -> (DVar, DVar) -> Actions PyDopeBS -> IO () -- XXX INDIR EVAL -printUpdate _ _ _ _ Nothing _ _ = +printUpdate _ _ _ _ _ Nothing _ _ = dynacPanic "Python backend does not know how to do indirect evaluations" -printUpdate fh rule cost evalix (Just (f,a)) (hv,v) dope = do +printUpdate fh bc rule cost evalix (Just (f,a)) (hv,v) dope = do displayIO fh $ renderPretty 1.0 100 $ "#" <+> (pfa f a) `above` "def" <+> char '_' <> tupled (map pretty [hv,v,"emit"]) <> colon `above` (indent 4 $ printPlanHeader rule cost (Just evalix)) - `above` pdope dope + `above` pdope bc dope <> line - <> "updaters.append((" <> (pfa f a) <> "," <> (pretty $ r_index rule) <> ",_))" + <> "updaters.append" + <> parens (tupled [pfa f a, pretty $ r_index rule, "_"]) <> line <> line <> line +printQuery :: Handle + -> S.Set DFunctAr + -> DFunctAr + -> Rule + -> [DVar] + -> Cost + -> Actions PyDopeBS + -> IO () +printQuery fh bc (f,a) rule vs cost dope = do + displayIO fh $ renderPretty 1.0 100 + $ "#" <+> (pfa f a) + `above` "def" <+> char '_' + <> tupled (map pretty vs ++ ["emit"]) + <> colon + `above` (indent 4 $ printPlanHeader rule cost Nothing) + `above` pdope bc dope + <> line + <> "queries.append" + <> parens (tupled [pfa f a, pretty $ r_index rule, "_"]) + <> line + <> line + <> line + + ------------------------------------------------------------------------}}} -- Driver {{{ driver :: BackendDriver PyDopeBS -driver am um {-qm-} is pr fh = do +driver am um is bc qp pr fh = do -- Parser resume state hPutStrLn fh "parser_state = \"\"\"" hPutStrLn fh $ show pr @@ -359,25 +401,16 @@ driver am um {-qm-} is pr fh = do hPutStrLn fh "" hPutStrLn fh $ "# " ++ show fa forM_ ps $ \(r,n,c,vi,vo,act) -> do - printUpdate fh r c n fa (vi,vo) act + printUpdate fh bc r c n fa (vi,vo) act hPutStrLn fh "" hPutStrLn fh $ "# ==Initializers==" forM_ is $ \(r,c,a) -> do - printInitializer fh r c a + printInitializer fh bc r c a -{- hPutStrLn fh $ "# ==Queries==" - forM_ (M.toList qm) $ \(fa, ps) -> do - hPutStrLn fh $ "# " ++ show fa - forM_ ps $ \(r,c,qv,a) -> do - printPlanHeader fh r c - hPutStrLn fh $ "# " ++ show qv - -- XXX - -- displayIO fh $ renderPretty 1.0 100 $ pdope a "XXX" - hPutStrLn fh "" --} + forM_ qp $ \(fa,r,(vs,(c,a))) -> printQuery fh bc fa r vs c a ------------------------------------------------------------------------}}} -- Export {{{ diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index 345dbe0..a80c9dd 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -20,12 +20,17 @@ import qualified Data.ByteString.UTF8 as BU import Data.Either import qualified Data.Map as M import qualified Data.Maybe as MA --- import qualified Data.Set as S +import qualified Data.Set as S import Data.String import Dyna.Analysis.Aggregation import Dyna.Analysis.ANF import Dyna.Analysis.ANFPretty import Dyna.Analysis.DOpAMine +import Dyna.Analysis.Mode.Det +import Dyna.Analysis.Mode.Execution.NamedInst +import Dyna.Analysis.Mode.Inst +import Dyna.Analysis.Mode.Mode +import Dyna.Analysis.Mode.Uniq import Dyna.Analysis.RuleMode import Dyna.Backend.BackendDefn import Dyna.Backend.Backends @@ -292,6 +297,16 @@ renderFailedUpdate rd (r,i,ps) = <+> (text "evalix=" <> pretty i) indent 2 (vsep $ map (renderPartialPlan rd) ps) +renderFailedQuery rd (r,pbce) = + text ";; failed query attempts for" + (prettySpanLoc $ r_span r) + + case pbce of + PBCWrongFunctor f -> "wrong functor" <+> squotes (pretty f) + PBCWrongArity n -> "wrong arity" <+> squotes (pretty n) + PBCBadRule -> "bad rule" + PBCNoPlan ps -> "no plan:" + indent 2 (vsep $ map (renderPartialPlan rd) ps) ------------------------------------------------------------------------}}} -- Warnings {{{ @@ -313,7 +328,7 @@ processFile fileName = bracket openOut hClose go maybeWarnANF xs = Just $ vcat $ map (uncurry renderSpannedWarn) xs go out = do - P.PDP rs iaggmap pp <- parse (be_aggregators $ dcfg_backend ?dcfg) + P.PDP rs iaggmap gbcs pp <- parse (be_aggregators $ dcfg_backend ?dcfg) dump DumpParsed $ (vcat $ map (\(i,_,r) -> text $ show (i,r)) rs) @@ -331,49 +346,80 @@ processFile fileName = bracket openOut hClose go (pretty f <+> colon <+> pretty a)) empty aggm) + case dcfg_backend ?dcfg of Backend _ be_b be_c be_ddi be_d -> let initializers = map (\(f,mca) -> either (\e -> Left (f,e)) (\(c,a) -> Right (f,c,a)) mca) - $ map (\x -> (x, planInitializer be_b x)) frs + $ map (\x -> (x, planInitializer be_b gbcs x)) frs cInitializers = rights initializers - uPlans = map (\x -> (x, planEachEval be_b be_c x)) - frs + uPlans = map (\x -> (x, planEachEval be_b gbcs be_c x)) frs cuPlans = combineUpdatePlans uPlans -{- - qPlans = combineQueryPlans - $ map (\x -> (x, planGroundBackchain be_b x)) - frs --} + bcrules = MA.mapMaybe (\r -> maybe (p r) + (\fa -> if fa `S.member` gbcs + then Just (fa,r) + else Nothing) + $ findHeadFA (r_head r) (r_ucruxes r)) + $ frs + where + p r = (dynacPanic $ "Can't check rule" + <+> (prettySpanLoc (r_span r)) + <+> "for backchaining: no head") + + + qPlans = map (\(fa@(f,a),r) -> (fa,r, + planBackchain be_b gbcs (f,mkqm a) r)) + bcrules + where + mkqm a = QMode (replicate a (tus,tus)) (tf,tus) DetSemi + + tus = nHide $ IUniv UShared + tf = nHide IFree + + cqPlans = map (\(fa,r,e) -> (fa,r,check e)) qPlans + where + check (Right p) = p + check (Left _) = dynacPanic $ "Backchaining planner failed" in do -- Do this before forcing cInitializers, cuPlans, etc., -- as those will panic and stop the pipeline. dump DumpFailedPlans $ - vcat [ vcat $ map (renderFailedInit (renderDop be_ddi)) - $ lefts initializers - , let - shuffle (r,ips) = map sgo ips - where - sgo (i,Left e) = Left (r,i,e) - sgo (_,Right _) = Right () - in vcat $ map (renderFailedUpdate (renderDop be_ddi)) - $ lefts - $ concat - $ map shuffle uPlans - ] + let rend = renderDop be_ddi + in vcat [ vcat $ map (renderFailedInit rend) + $ lefts initializers + , let + shuffle (r,ips) = map sgo ips + where + sgo (i,Left e) = Left (r,i,e) + sgo (_,Right _) = Right () + in vcat $ map (renderFailedUpdate rend) + $ lefts + $ concat + $ map shuffle uPlans + , let + shuffle (_,r,Right _) = Nothing + shuffle (_,r,Left e) = Just (r,e) + in vcat $ map (renderFailedQuery rend) + $ MA.catMaybes $ map shuffle qPlans + ] -- Force evaluation of a lot of the work of the compiler, -- even if the backend and dump flags won't do it for us. cInitializers' <- evaluate $ cInitializers cuPlans' <- evaluate $ cuPlans - case lefts initializers of + let noInitErrGbcs = filter (\(r,_) -> + maybe True + (\fa -> not $ fa `S.member` gbcs) + $ findHeadFA (r_head r) (r_ucruxes r)) + + case noInitErrGbcs $ lefts initializers of [] -> return () xs -> dynacUserErr $ "Unable to plan initializers for rule(s):" (indent 2 $ vcat $ @@ -383,7 +429,7 @@ processFile fileName = bracket openOut hClose go dump DumpDopUpd (renderDopUpds be_ddi cuPlans') -- Invoke the backend code generator - be_d aggm cuPlans' {- qPlans -} cInitializers' pp out + be_d aggm cuPlans' cInitializers' gbcs cqPlans pp out parse aggs = do pr <- T.parseFromFileEx (P.oneshotDynaParser aggs <* T.eof) fileName @@ -391,6 +437,7 @@ processFile fileName = bracket openOut hClose go TR.Failure td -> dynacUserANSIErr $ PPA.align ("Parser error" PPA.<$> td) TR.Success rs -> return rs + ------------------------------------------------------------------------}}} -- Main {{{ diff --git a/src/Dyna/ParserHS/OneshotDriver.hs b/src/Dyna/ParserHS/OneshotDriver.hs index b1b4cdd..79347bc 100644 --- a/src/Dyna/ParserHS/OneshotDriver.hs +++ b/src/Dyna/ParserHS/OneshotDriver.hs @@ -45,6 +45,8 @@ data ParsedDynaProgram = PDP , pdp_aggrs :: M.Map DFunctAr DAgg + , pdp_gbc :: S.Set DFunctAr + -- | A rather ugly hack for resumable parsing: this records the set of -- pragmas to restore the current PCS. , pdp_parser_resume :: forall e . PP.Doc e @@ -59,6 +61,9 @@ data PCS = PCS , _pcs_dt_over :: DisposTabOver , _pcs_dt_cache :: DisposTab -- ^ Cache the disposition table + + , _pcs_gbc_set :: S.Set DFunctAr + , _pcs_iagg_map :: M.Map DFunctAr DAgg , _pcs_instmap :: M.Map B.ByteString ([DVar] ,ParsedInst @@ -116,6 +121,8 @@ defPCS = PCS { _pcs_dt_mk = "dyna" , _pcs_dt_cache = dtmk (defPCS ^. pcs_dt_mk) (defPCS ^. pcs_dt_over) + , _pcs_gbc_set = S.empty + , _pcs_iagg_map = M.empty , _pcs_instmap = mempty -- XXX @@ -130,6 +137,9 @@ defPCS = PCS { _pcs_dt_mk = "dyna" -- | Update the PCS to reflect a new pragma pcsProcPragma :: (Parsing m, MonadState PCS m) => Spanned Pragma -> m () +pcsProcPragma (PBackchain fa :~ _) = do + pcs_gbc_set %= S.insert fa + pcsProcPragma (PDispos s f as :~ _) = do pcs_dt_over %= dtoMerge (f,length as) (s,as) update_pcs_dt @@ -173,12 +183,14 @@ sorryPragma p s = dynacSorry $ "Cannot handle pragma" pragmasFromPCS :: PCS -> PP.Doc e pragmasFromPCS (PCS dt_mk dt_over _ + gbcs _ im mm _ _ rix) = PP.vcat $ map renderPragma $ - (map (\((k,_),(s,as)) -> PDispos s k as) + (map PBackchain $ S.toList gbcs) + ++ (map (\((k,_),(s,as)) -> PDispos s k as) $ M.toList dt_over) ++ [PDisposDefl dt_mk] -- XXX leaving out the item agg map, because that gets refined during @@ -217,6 +229,7 @@ oneshotDynaParser aggs = (postProcess =<<) postProcess (rs,pcs) = return $ PDP (catMaybes rs) (pcs ^. pcs_iagg_map) + (pcs ^. pcs_gbc_set) (pragmasFromPCS pcs) ------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index f8c4e63..f10376b 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -34,6 +34,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Dyna.ParserHS.Parser ( @@ -493,11 +494,13 @@ parseUniq = choice [ symbol "clobbered" *> pure UClobbered ------------------------------------------------------------------------}}} -- Parsing pragma bodies {{{ -pragmaBody :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) +pragmaBody :: forall m . + (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) => m Pragma pragmaBody = token $ choice [ - symbol "dispos_def" *> parseDisposDefl -- set default dispositions + symbol "backchain" *> parseBackchain + , symbol "dispos_def" *> parseDisposDefl -- set default dispositions , symbol "dispos" *> parseDisposition -- in-place dispositions , symbol "iaggr" *> parseIAggr -- alternate syntax for aggr , symbol "inst" *> parseInstDecl -- instance delcarations @@ -506,6 +509,17 @@ pragmaBody = token $ choice , symbol "ruleix" *> (PRuleIx <$> decimal) ] where + parseArity :: m Int + parseArity = do + n <- token decimal + when (n > fromIntegral (maxBound :: Int)) $ unexpected "huge number" + return (fromIntegral n) + + parseBackchain = PBackchain <$> ( (,) + <$> parseFunctor + <* char '/' + <*> parseArity) + parseDisposition = PDispos <$> selfdis <*> parseFunctor <*> (parens (argdis `sepBy` comma) @@ -528,8 +542,7 @@ pragmaBody = token $ choice parseIAggr = do f <- parseFunctor _ <- char '/' - n <- token decimal - when (n > fromIntegral (maxBound :: Int)) $ unexpected "huge number" + n <- parseArity a <- join $ asks dlc_aggrs return (PIAggr f (fromIntegral n) a) @@ -602,6 +615,10 @@ renderPNWA :: NameWithArgs -> PP.Doc e renderPNWA (PNWA n as) = PP.pretty n PP.<> PP.tupled (map PP.pretty as) renderPragma_ :: Pragma -> PP.Doc e +renderPragma_ (PBackchain (f,a)) = "backchain" PP.<+> renderFunctor f + PP.<> PP.char '/' + PP.<> PP.pretty a + renderPragma_ (PDisposDefl s) = "dispos_def" PP.<+> PP.text s renderPragma_ (PDispos s f as) = "dispos" PP.<+> rs s diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index 55e6fb1..cfbbda4 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -228,7 +228,7 @@ progrules = unsafeParse (whiteSpace *> many (spanned (testRule defDLC)) <* eof) oneshotRules :: ByteString -> [(RuleIx, Spanned Rule)] oneshotRules = xlate . unsafeParse (oneshotDynaParser Nothing) where - xlate (PDP rs _ _) = map (\(i,_,sr) -> (i,sr)) rs + xlate (PDP rs _ _ _) = map (\(i,_,sr) -> (i,sr)) rs case_ruleFact :: Assertion case_ruleFact = e @=? (progrule sr) @@ -455,7 +455,8 @@ case_rule_with_unknown_operator = arbPragma :: Gen Pragma arbPragma = oneof - [ PDispos <$> arbSD <*> arbAtom <*> listOf arbAD + [ PBackchain <$> ((,) <$> arbAtom <*> (getPositive <$> arbitrary)) + , PDispos <$> arbSD <*> arbAtom <*> listOf arbAD , PDisposDefl <$> elements ["dyna", "prologish"] , PIAggr <$> arbAtom <*> (getPositive <$> arbitrary) <*> (elements okAggrs) , PRuleIx <$> (getPositive <$> arbitrary) diff --git a/src/Dyna/ParserHS/Types.hs b/src/Dyna/ParserHS/Types.hs index 8ad129c..76c0cbe 100644 --- a/src/Dyna/ParserHS/Types.hs +++ b/src/Dyna/ParserHS/Types.hs @@ -23,7 +23,7 @@ import qualified Data.Data as D import Dyna.Analysis.Mode.Inst import Dyna.Main.Defns import Dyna.Term.TTerm (Annotation(..), TBase(..), - DFunct) + DFunct, DFunctAr) import Dyna.Term.SurfaceSyntax import Text.Trifecta @@ -49,7 +49,11 @@ data NameWithArgs = PNWA B.ByteString [B.ByteString] deriving (Eq,Show) -- | Pragmas that are recognized by the parser -data Pragma = PDispos SelfDispos B.ByteString [ArgDispos] +data Pragma = PBackchain DFunctAr + -- ^ A given functor should be planned for ground + -- backchaining. + + | PDispos SelfDispos B.ByteString [ArgDispos] -- ^ Assert the evaluation disposition of a functor | PDisposDefl String