-module Dyna.Analysis.ANFPretty (printANF) where
+module Dyna.Analysis.ANFPretty (renderANF, renderCruxes) where
+import Data.Either
import qualified Data.IntMap as IM
import qualified Data.Set as S
import Dyna.Analysis.ANF
import Dyna.Term.Normalized
+import Dyna.Term.TTerm
import Dyna.XXX.PPrint (valign)
import Text.PrettyPrint.Free
import Dyna.XXX.Trifecta (prettySpanLoc)
------------------------------------------------------------------------}}}
--- Pretty Printer {{{
+-- Pretty Printers {{{
-printANF :: Rule -> Doc e
-printANF (Rule rix h a result sp _ unifs evals) =
+renderANF :: Rule -> Doc e
+renderANF (Rule rix h a result sp _ unifs evals) =
text ";;" <+> prettySpanLoc sp
`above`
text ";; index" <+> pretty rix
`above`
( parens $ (pretty a)
<+> valign [ (pretty h)
- , parens $ text "evals" <+> pevs
- , parens $ text "unifs" <+> puns
+ , parens $ text "evals" <+> pevs (IM.toAscList evals)
+ , parens $ text "unifs" <+> puns (S.toList unifs)
, parens $ text "result" <+> (pretty result)
]
) <> line
- where
- pft :: FDT -> Doc e
- pft (fn,args) = hsep $ (pretty fn : (map pretty args))
- pnft :: (Int,FDT) -> Doc e
- pnft (n,(f,args)) = parens $ hsep $ ( pretty f <> char '@' <> pretty n
- : (map pretty args))
+renderCruxes :: S.Set (Crux DVar TBase) -> Doc e
+renderCruxes cs =
+ let (es, us) = partitionEithers (S.toList cs)
+ in valign
+ [ text "evals" <//> indent 2 (pevs es)
+ , text "unifs" <//> indent 2 (puns us)
+ ]
- pev n (CEval o i) = parens (pretty o <+> pretty i <> char '@' <> pretty n)
- pev n (CCall o is f) = parens (pretty o <+> pnft (n,(f,is)))
+------------------------------------------------------------------------}}}
+-- Internals {{{
+
+pft :: FDT -> Doc e
+pft (fn,args) = hsep $ (pretty fn : (map pretty args))
+
+pnft :: (Int,FDT) -> Doc e
+pnft (n,(f,args)) = parens $ hsep $ ( pretty f <> char '@' <> pretty n
+ : (map pretty args))
+
+pev :: Int -> EvalCrux DVar -> Doc e
+pev n (CEval o i) = parens (pretty o <+> pretty i <> char '@' <> pretty n)
+pev n (CCall o is f) = parens (pretty o <+> pnft (n,(f,is)))
+
+pevs :: [(Int, EvalCrux DVar)] -> Doc e
+pevs = valign . map (uncurry pev)
- pun (CStruct o is f) = parens (pretty o <+> parens (char '&' <+> pft (f,is)))
- pun (CAssign o v ) = parens (pretty o <+> parens (equals <+> pretty v))
- pun (CEquals v1 v2 ) = parens (pretty v1 <+> parens (equals <+> pretty v2))
- pun (CNotEqu v1 v2 ) = parens (pretty v1 <+> parens (char '!' <+> pretty v2))
+pun :: (Pretty a) => UnifCrux DVar a -> Doc e
+pun (CStruct o is f) = parens (pretty o <+> parens (char '&' <+> pft (f,is)))
+pun (CAssign o v ) = parens (pretty o <+> parens (equals <+> pretty v))
+pun (CEquals v1 v2 ) = parens (pretty v1 <+> parens (equals <+> pretty v2))
+pun (CNotEqu v1 v2 ) = parens (pretty v1 <+> parens (char '!' <+> pretty v2))
- pevs = valign $ map (uncurry pev) (IM.toAscList evals)
- puns = valign $ map pun (S.toList unifs)
+puns :: (Pretty a) => [UnifCrux DVar a] -> Doc e
+puns = valign . map pun
------------------------------------------------------------------------}}}
-- unification crank out a series of DOpAMine opcodes for us, but for
-- the moment, since everything we do is either IFree or IUniv, just use
-- iEq everywhere.
+ --
+ -- XXX Rescue the new planner from plan-nonground, when convenient.
-- XXX Actually, this is all worse than it should be. The unification
-- should be done before any case analysis. Note that we also don't do
------------------------------------------------------------------------}}}
-- Planning {{{
-
data PartialPlan fbs = PP { pp_cruxes :: S.Set (Crux DVar TBase)
, pp_binds :: BindChart
, pp_score :: Cost
pp_liveVars :: PartialPlan fbs -> S.Set DVar
pp_liveVars p = allCruxVars (pp_cruxes p)
+-- XXX This certainly belongs elsewhere
+renderPartialPlan rd (PP crs bs c pl) =
+ vcat [ text "cost=" <> pretty c
+ , text "pendingCruxes:" <//> indent 2 (renderCruxes crs)
+ , text "context:" <//> indent 2 (pretty bs)
+ , text "actions:" <//> indent 2 (rd pl)
+ ]
+
-- XXX This does not have a way to signal UFNotReached back to its caller.
-- That is particularly disappointing since any unification producing that
-- means that there's certainly no plan for the whole rule.
plan
) []
-planner_ :: (Crux DVar TBase -> SIMCT Identity DFunct (Actions fbs))
+planner_ :: forall fbs .
+ (Crux DVar TBase -> SIMCT Identity DFunct (Actions fbs))
-- ^ Available steps
-> (PartialPlan fbs -> Actions fbs -> Cost)
-- ^ Scoring function
-> SIMCtx DVar
-- ^ Initial context (which must cover all the variables
-- in the given cruxes)
- -> [(Cost, Actions fbs)]
+ -> Either [PartialPlan fbs] [(Cost, Actions fbs)]
-- ^ Plans and their costs
planner_ st sc cr mic ictx = runAgenda
$ PP { pp_cruxes = cr
, pp_plan = ip
}
where
- runAgenda = go . (flip mioaPlan M.empty)
+ runAgenda = goMF [] . (flip mioaPlan M.empty)
where
mioaPlan :: PartialPlan fbs
-> M.Map Cost [PartialPlan fbs]
-> M.Map Cost [PartialPlan fbs]
mioaPlan p@(PP{pp_score=psc}) = mapInOrCons psc p
- go pq = maybe [] go' $ mapMinRepView pq
+ goMF fs pq = maybe (Left fs) (go' goMFkf (\df pq' -> Right (df:go pq')))
+ $ mapMinRepView pq
where
- go' (p, pq') = case stepPartialPlan st sc p of
- Left df -> df : (go pq')
- Right ps' -> go (foldr mioaPlan pq' ps')
+ goMFkf Nothing = goMF fs
+ goMFkf (Just p) = goMF (p:fs)
+
+ go :: M.Map Cost [PartialPlan fbs]
+ -> [(Cost, Actions fbs)]
+ go pq = maybe [] (go' (\_ -> go) (\df -> (df :) . go))
+ $ mapMinRepView pq
+
+ go' :: (Maybe (PartialPlan fbs) -> M.Map Cost [PartialPlan fbs] -> x)
+ -> ((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
+ Right [] -> kf (Just p) pq'
+ Left df -> ks df pq'
+ Right ps' -> kf Nothing (foldr mioaPlan pq' ps')
ctx' = either (const $ dynacPanicStr "Unable to bind input variable")
snd
-- considering at most a constant number of plans.
--
-- XXX This is probably not the right idea
-bestPlan :: [(Cost, a)] -> Maybe (Cost, a)
-bestPlan [] = Nothing
-bestPlan plans = Just $ argmin fst (take 1000 plans)
+bestPlan :: Either e [(Cost, a)] -> Either e (Cost, a)
+bestPlan = fmap go
+ where
+ go [] = dynacPanic "Planner claimed success with no plans!"
+ go plans@(_:_) = argmin fst (take 1000 plans)
-- | Add the last Emit verb to a string of actions from the planner.
--
-> S.Set (Crux DVar TBase) -- ^ Normal form
-> (EvalCrux DVar, DVar, DVar)
-> SIMCtx DVar
- -> Maybe (Cost, Actions fbs)
+ -> 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
-planInitializer :: BackendPossible fbs -> Rule -> Maybe (Cost, Actions fbs)
+planInitializer :: BackendPossible fbs -> Rule
+ -> Either [PartialPlan fbs] (Cost, Actions fbs)
planInitializer bp r = fmap (second (finalizePlan r)) $
let cruxes = r_cruxes r in
bestPlan $ planner_ (possible bp) simpleCost cruxes Nothing
planEachEval :: BackendPossible fbs -- ^ The backend's primitive support
-> (DFunctAr -> Bool) -- ^ Indicator for constant function
-> Rule
- -> [(Int, Maybe (Cost, DVar, DVar, Actions fbs))]
--- planEachEval _ _ _ = []
+ -> [(Int, Either [PartialPlan fbs] (Cost, DVar, DVar, Actions fbs))]
planEachEval bp cs r =
map (\(n,cr) ->
let
-- timv: might want to fuse these into one circuit
--
combineUpdatePlans :: [(Rule,[( Int,
- Maybe (Cost, DVar, DVar, Actions fbs))])]
+ Either a (Cost, DVar, DVar, Actions fbs))])]
-> UpdateEvalMap fbs
combineUpdatePlans = go (M.empty)
where
go' xs _ [] m = go m xs
go' xs fr ((n,mca):ys) m =
case mca of
- Nothing -> dynacUserErr
+ 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)
- Just (c,v1,v2,a) -> go' xs fr ys $ mapInOrCons fa (fr,n,c,v1,v2,a) m
+ 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 "
- <+> (printANF fr))
+ ev = maybe (dynacPanic $ "Eval index without eval crux in rule:"
+ <//> (renderANF fr))
id
(IM.lookup n (r_ecruxes fr))
import Control.Exception
-- import Control.Monad
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
| DumpANF
| DumpDopIni
| DumpDopUpd
+ | DumpFailedPlans
| DumpParsed
deriving (Eq,Ord,Show)
++ mkDumpOpt "anf" DumpANF "Administrative Normal Form"
++ mkDumpOpt "dopini" DumpDopIni "DOpAMine planning results: initializers"
++ mkDumpOpt "dopupd" DumpDopUpd "DOpAMine planning results: updates"
+ ++ mkDumpOpt "failed-plans" DumpFailedPlans "Planner failures"
++ mkDumpOpt "parse" DumpParsed "Parser output"
where
mkDumpOpt arg fl hm =
++ "There are known inefficiencies and less-than-ideal code.\n"
++ "We hope that you enjoy using it despite these woes! :)"
- h = "\nUsage: dyna -B backend -o FILE.out FILE.dyna\n\nOption summary:"
+ h = "\nUsage: dyna -B backend [-o FILE.out] FILE.dyna\n\nOption summary:"
quickExit QEHelpBackend = do
qeBanner "Backend information"
putDoc backendHelp
<+> text "head=" <> pretty (r_head r)
<+> text "res=" <> pretty (r_result r)
+renderFailedInit rd (r,ps) =
+ text ";; failed initialization attempts for"
+ <//> (prettySpanLoc $ r_span r)
+ <//> indent 2 (vsep $ map (renderPartialPlan rd) ps)
+
+renderFailedUpdate rd (r,i,ps) =
+ text ";; failed update plans for"
+ <//> (prettySpanLoc $ r_span r)
+ <+> (text "evalix=" <> pretty i)
+ <//> indent 2 (vsep $ map (renderPartialPlan rd) ps)
+
+
------------------------------------------------------------------------}}}
-- Warnings {{{
let (frs, anfWarns) = unzip $ map normRule rs
- dump DumpANF (vcat $ map printANF frs)
+ dump DumpANF (vcat $ map renderANF frs)
hPutDoc stderr $ vcat $ MA.mapMaybe maybeWarnANF anfWarns
case dcfg_backend ?dcfg of
Backend _ be_b be_c be_ddi be_d ->
- let initializers = MA.mapMaybe
- (\(f,mca) -> (\(c,a) -> (f,c,a)) `fmap` mca)
- $ map (\x -> (x, planInitializer be_b x)) frs
-
+ 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
+
+ cInitializers = rights initializers
- uPlans = combineUpdatePlans
- $ map (\x -> (x, planEachEval be_b be_c x))
- frs
+ uPlans = map (\x -> (x, planEachEval be_b be_c x))
+ frs
+
+ cuPlans = combineUpdatePlans uPlans
{-
qPlans = combineQueryPlans
-}
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
+ ]
+
-- Force evaluation of a lot of the work of the compiler,
-- even if the backend and dump flags won't do it for us.
- initializers' <- evaluate $ initializers
- uPlans' <- evaluate $ uPlans
+ cInitializers' <- evaluate $ cInitializers
+ cuPlans' <- evaluate $ cuPlans
+
+ case lefts initializers of
+ [] -> return ()
+ xs -> dynacUserErr $ "Unable to plan initializers for rule(s):"
+ <//> (indent 2 $ vcat $
+ map (prettySpanLoc . r_span . fst) xs)
- dump DumpDopIni (renderDopInis be_ddi initializers')
- dump DumpDopUpd (renderDopUpds be_ddi uPlans')
+ dump DumpDopIni (renderDopInis be_ddi cInitializers')
+ dump DumpDopUpd (renderDopUpds be_ddi cuPlans')
-- Invoke the backend code generator
- be_d aggm uPlans' {- qPlans -} initializers' pp out
+ be_d aggm cuPlans' {- qPlans -} cInitializers' pp out
parse aggs = do
pr <- T.parseFromFileEx (P.oneshotDynaParser aggs <* T.eof) fileName
projects / dyna2 / commitdiff