SelfDispos(..), ArgDispos(..), EvalMarks,
-- * Placeholders
- evalCruxFA, findHeadFA, r_cruxes,
+ evalCruxFA, findHeadFA, r_cruxes, extractHeadVars
) where
import Control.Lens
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
+
------------------------------------------------------------------------}}}
deriving Show
$(makeLenses ''QMode)
+unpackModeInputs :: QMode n -> (n, [n])
+unpackModeInputs qm = ( fst $ _qmode_result qm
+ , map fst $ _qmode_args qm)
+
-- XXX Update Modes
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
-- | 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
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"
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
-- 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))
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
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 {{{
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)
) []
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)
-- 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
-> ((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')
--
-- 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,
-- 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
$ 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
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 {{{
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 {{{
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
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 ()
, be_driver = driver
}
-driver _ _ {-_-} _ _ fh = hPutStrLn fh "No backend selected; stopping."
+driver _ _ _ _ _ _ fh = hPutStrLn fh "No backend selected; stopping."
------------------------------------------------------------------------}}}
-- Primitive operations {{{
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
-- 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
-- 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
)
-- 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
<+> 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)
-- 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
]
-- | 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')
, "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
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 {{{
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
<+> (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 {{{
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)
(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 $
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
TR.Failure td -> dynacUserANSIErr $ PPA.align ("Parser error" PPA.<$> td)
TR.Success rs -> return rs
+
------------------------------------------------------------------------}}}
-- Main {{{
, 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
, _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
, _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
-- | 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
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
postProcess (rs,pcs) = return $
PDP (catMaybes rs)
(pcs ^. pcs_iagg_map)
+ (pcs ^. pcs_gbc_set)
(pragmasFromPCS pcs)
------------------------------------------------------------------------}}}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
module Dyna.ParserHS.Parser (
------------------------------------------------------------------------}}}
-- 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
, 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)
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)
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
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)
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)
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
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
projects / dyna2 / commitdiff