import Dyna.Main.Exception
import Dyna.XXX.DataUtils(argmin,mapInOrCons,mapMinRepView)
import Dyna.XXX.MonadContext
-import Dyna.XXX.Trifecta (prettySpanLoc)
-- import Dyna.XXX.TrifectaTest
import Text.PrettyPrint.Free
pp_liveVars p = allCruxVars (pp_cruxes p)
-- XXX This certainly belongs elsewhere
+renderPartialPlan :: (Actions t -> Doc e) -> PartialPlan t -> Doc e
renderPartialPlan rd (PP crs bs c pl) =
vcat [ text "cost=" <> pretty c
, text "pendingCruxes:" <//> indent 2 (renderCruxes crs)
tf = nHide IFree
-------------------------------------------------------------------------}}}
--- Update plan combination {{{
-
-type UpdateEvalMap fbs = M.Map (Maybe DFunctAr)
- [(Rule, Int, Cost, DVar, DVar, Actions fbs)]
-
--- | Return all plans for each functor/arity
---
--- XXX This may still belong elsewhere.
---
--- XXX This guy wants span information; he's got it now use it.
---
--- timv: might want to fuse these into one circuit
---
-combineUpdatePlans :: [(Rule,[( Int,
- Either a (Cost, DVar, DVar, Actions fbs))])]
- -> UpdateEvalMap fbs
-combineUpdatePlans = go (M.empty)
- where
- go m [] = m
- go m ((fr,cmca):xs) = go' xs fr cmca m
-
- go' xs _ [] m = go m xs
- go' xs fr ((n,mca):ys) m =
- case mca of
- Left _ -> dynacUserErr
- $ "No update plan for"
- <+> maybe "indirection"
- (\(f,a) -> pretty f <> char '/' <> pretty a)
- fa
- <+> "in rule at"
- <> line <> indent 2 (prettySpanLoc $ r_span fr)
- Right (c,v1,v2,a) -> go' xs fr ys $ mapInOrCons fa (fr,n,c,v1,v2,a) m
- where
- fa = evalCruxFA ev
- ev = maybe (dynacPanic $ "Eval index without eval crux in rule:"
- <//> (renderANF fr))
- id
- (IM.lookup n (r_ecruxes fr))
------------------------------------------------------------------------}}}
-- Adorned Queries {{{
import Dyna.Analysis.Aggregation (AggMap)
import Dyna.Analysis.ANF (Rule)
import Dyna.Analysis.DOpAMine (BackendRenderDopIter)
-import Dyna.Analysis.RuleMode (
- Actions, BackendPossible, Cost,
- UpdateEvalMap {-, QueryEvalMap -})
+import Dyna.Analysis.RuleMode (Actions, BackendPossible, Cost)
import Dyna.Term.TTerm (DFunctAr,DVar)
import System.IO (Handle)
import qualified Text.PrettyPrint.Free as PP
-- plans, but that's not really how we should be doing it. The right
-- answer, of course, is to use update mode information, once we have it.
-type BackendDriver bs = AggMap -- ^ Aggregation
- -> UpdateEvalMap bs -- ^ Rule update
+type BackendDriver bs = AggMap -- ^ Aggregation
+ -> [(Rule,[(Int,Maybe DFunctAr -- ^ Rule update
+ , Cost, DVar, DVar, Actions bs)])]
-> [(Rule,Cost,Actions bs)] -- ^ Initializers
-> S.Set DFunctAr -- ^ Ground backchains
-> [(DFunctAr,Rule,([DVar],(Cost,Actions bs)))] -- ^ GBC plans
-- Driver {{{
driver :: BackendDriver PyDopeBS
-driver am um is bc qp pr fh = do
+driver am ups is bc qp pr fh = do
hPutStrLn fh "from __future__ import division"
hPutStrLn fh "from stdlib import *"
hPutStrLn fh ""
hPutStrLn fh $ "# ==Updates=="
- -- plans aggregated by functor/arity
- forM_ (M.toList um) $ \(fa, ps) -> do
+ forM_ ups $ \(r,rps) -> do
hPutStrLn fh ""
- hPutStrLn fh $ "# " ++ show fa
- forM_ ps $ \(r,n,c,vi,vo,act) -> do
+ hPutStrLn fh $ "# rix=" ++ (show $ r_index r)
+ forM_ rps $ \(n,fa,c,vi,vo,act) -> do
+ hPutStrLn fh $ "# " ++ show fa
printUpdate fh bc r c n fa (vi,vo) act
hPutStrLn fh ""
import qualified Data.ByteString.UTF8 as BU
import Data.Either
import qualified Data.Map as M
+import qualified Data.IntMap as IM
import qualified Data.Maybe as MA
import qualified Data.Set as S
import Data.String
renderDop :: BackendRenderDopIter bs e -> Actions bs -> Doc e
renderDop ddi dop = vsep $ map (renderDOpAMine ddi) dop
-renderDopUpds :: BackendRenderDopIter bs e -> UpdateEvalMap bs -> Doc e
-renderDopUpds ddi um = vsep $ flip map (M.toList um) $ \(fa,ps) ->
- vsep $ flip map ps $ \(r,n,c,vi,vo,act) ->
+renderDopUpds :: BackendRenderDopIter bs e
+ -> [(Rule,[(Int,Maybe DFunctAr,Cost,DVar,DVar,Actions bs)])]
+ -> Doc e
+renderDopUpds ddi us = vsep $ flip map us $ \(r,ps) ->
+ vsep $ flip map ps $ \(n,fa,c,vi,vo,act) ->
planHeader r fa n c (vi,vo) `above` indent 2 (renderDop ddi act)
where
planHeader r (fa :: Maybe DFunctAr) n c (vi,vo) =
uPlans = map (\x -> (x, planEachEval be_b gbcs be_c x)) fcrules
- cuPlans = combineUpdatePlans uPlans
-
qPlans = map (\(fa@(f,a),r) -> (fa,r,
planBackchain be_b gbcs (f,mkqm a) r))
bcrules
where
check (f,r,Right p) = (f,r,p)
check (_,r,Left _) = dynacUserErr $
- "Unable to plan backchaining for rule"
- <//> (prettySpanLoc (r_span r))
- <> dot
+ "Unable to plan backchaining for rule"
+ <//> (prettySpanLoc (r_span r))
+ <> dot
in do
- -- Do this before forcing cInitializers, cuPlans, etc.,
+ -- Do this before forcing cInitializers, uPlans, etc.,
-- as those will panic and stop the pipeline.
dump DumpFailedPlans $
let rend = renderDop be_ddi
-- 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
+ cInitializers' <- mapM evaluate cInitializers
+ uPlans' <- evaluate (forceUpdatePlans uPlans)
let noInitErrGbcs = filter (\(r,_) ->
maybe True
map (prettySpanLoc . r_span . fst) xs)
dump DumpDopIni (renderDopInis be_ddi cInitializers')
- dump DumpDopUpd (renderDopUpds be_ddi cuPlans')
+ dump DumpDopUpd (renderDopUpds be_ddi uPlans')
-- Invoke the backend code generator
- be_d aggm cuPlans' cInitializers' gbcs cqPlans pp out
+ be_d aggm uPlans' cInitializers' gbcs cqPlans pp out
parse aggs = do
pr <- T.parseFromFileEx (P.oneshotDynaParser aggs <* T.eof) fileName
TR.Failure td -> dynacParseErr $ PPA.align td
TR.Success rs -> return rs
+ forceUpdatePlans :: [(Rule,[(Int,
+ Either a (Cost, DVar, DVar, Actions fbs))])]
+ -> [(Rule,[(Int,
+ Maybe DFunctAr, Cost, DVar, DVar, Actions fbs)])]
+
+ forceUpdatePlans = map goRule
+ where
+ goRule (r,l) = let mps = map (goEvalix r) l in mps `seq` (r,mps)
+
+ goEvalix r (i,efp) = fa `seq` c `seq` (i,fa,c,ii,iv,p)
+ where
+ (c,ii,iv,p) = case efp of
+ Left _ -> dynacUserErr
+ $ "No update plan for"
+ <+> maybe "indirection"
+ (\(f,a) -> pretty f <> char '/' <> pretty a)
+ fa
+ <+> "in rule at"
+ <> line <> indent 2 (prettySpanLoc $ r_span r)
+ Right x -> x
+
+ fa = evalCruxFA ev
+ ev = maybe (dynacPanic $ "Eval index without eval crux in rule:"
+ <//> (renderANF r))
+ id
+ (IM.lookup i (r_ecruxes r))
------------------------------------------------------------------------}}}
-- Main {{{
projects / dyna2 / commitdiff