From: Nathaniel Wesley Filardo Date: Wed, 15 May 2013 05:15:04 +0000 (-0400) Subject: Another change to ANF X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=d3aed807c4d470ed0595cc4fa66b7e54ae268d0f;p=dyna2 Another change to ANF Now that we are indexing evals by an unique Int, we may as well enforce that with an IntMap, rather than just a Set. This is in preparation for displaying each update's ANF after double-counting prevention cruxes have been added. --- diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 3b66b68..42fb6da 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -81,7 +81,7 @@ module Dyna.Analysis.ANF ( SelfDispos(..), ArgDispos(..), ECSrc(..), EvalCtx, -- * Placeholders - findHeadFA, + evalCruxFA, findHeadFA, r_cruxes, ) where import Control.Lens @@ -92,10 +92,9 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.UTF8 as BU import qualified Data.ByteString as B -- import qualified Data.Char as C -import qualified Data.Either as E import qualified Data.Map as M import qualified Data.Maybe as MA --- import qualified Data.IntMap as IM +import qualified Data.IntMap as IM import qualified Data.Set as S -- import qualified Debug.Trace as XT import qualified Dyna.ParserHS.Parser as P @@ -145,8 +144,8 @@ mergeDispositions = md ------------------------------------------------------------------------}}} -- Cruxes {{{ -data EvalCrux v = CCall Int v [v] DFunct - | CEval Int v v +data EvalCrux v = CCall v [v] DFunct + | CEval v v deriving (Eq,Ord,Show) data UnifCrux v n = CStruct v [v] DFunct -- Known structure building @@ -155,7 +154,7 @@ data UnifCrux v n = CStruct v [v] DFunct -- Known structure building | CNotEqu v v -- Disequality constraint deriving (Eq,Ord,Show) -type Crux v n = Either (EvalCrux v) (UnifCrux v n) +type Crux v n = Either (Int,EvalCrux v) (UnifCrux v n) cruxIsEval :: Crux v n -> Bool cruxIsEval (Left _) = True @@ -164,9 +163,9 @@ cruxIsEval (Right _) = False cruxVars :: Crux DVar TBase -> S.Set DVar cruxVars = either evalVars unifVars where - evalVars cr = case cr of - CCall _ o is _ -> S.fromList (o:is) - CEval _ o i -> S.fromList [o,i] + evalVars (_,cr) = case cr of + CCall o is _ -> S.fromList (o:is) + CEval o i -> S.fromList [o,i] unifVars cr = case cr of CStruct o is _ -> S.fromList (o:is) CAssign o _ -> S.singleton o @@ -180,7 +179,8 @@ cruxVars = either evalVars unifVars data ANFState = AS { _as_next_var :: !Int , _as_next_eval :: !Int - , _as_cruxes :: S.Set (Crux DVar TBase) + , _as_ucruxes :: S.Set (UnifCrux DVar TBase) + , _as_ecruxes :: IM.IntMap (EvalCrux DVar) -- , as_evals :: IM.IntMap (DVar,EVF) -- , as_assgn :: M.Map DVar EBF -- , as_unifs :: [(DVar,DVar)] @@ -190,8 +190,8 @@ data ANFState = AS deriving (Show) $(makeLenses ''ANFState) -addCrux :: (MonadState ANFState m) => Crux DVar TBase -> m () -addCrux c = as_cruxes %= (S.insert c) +addUCrux :: (MonadState ANFState m) => UnifCrux DVar TBase -> m () +addUCrux c = as_ucruxes %= (S.insert c) nextVar :: (MonadState ANFState m) => String -> m DVar nextVar pfx = do @@ -202,7 +202,8 @@ newEval :: (MonadState ANFState m) => String -> EVF -> m DVar newEval pfx t = do n <- nextVar pfx ne <- as_next_eval <<%= (+1) - addCrux (Left $ either (CEval ne n) (uncurry (flip (CCall ne n))) t) + as_ecruxes %= IM.insert ne (either (CEval n) + (uncurry (flip (CCall n))) t) return n newAssign :: (MonadState ANFState m) => String -> ENF -> m DVar @@ -214,7 +215,7 @@ newAssign pfx t = where go u = do n <- nextVar pfx - addCrux (Right $ either (CAssign n) (uncurry (flip (CStruct n))) u) + addUCrux (either (CAssign n) (uncurry (flip (CStruct n))) u) return n newAnnot :: (MonadState ANFState m) @@ -230,7 +231,7 @@ newAssignNT pfx x = newAssign pfx $ Left x doUnif :: (MonadState ANFState m) => DVar -> DVar -> m () doUnif v w = if v == w then return () - else addCrux (Right $ CEquals v w) + else addUCrux (CEquals v w) newWarn :: (MonadState ANFState m) => B.ByteString -> [T.Span] -> m () newWarn msg loc = as_warns %= ((msg,loc):) @@ -392,10 +393,12 @@ data Rule = Rule { r_index :: Int , r_result :: DVar , r_span :: T.Span , r_annots :: ANFAnnots - , r_cruxes :: S.Set (Crux DVar TBase) + , r_ucruxes :: S.Set (UnifCrux DVar TBase) + , r_ecruxes :: IM.IntMap (EvalCrux DVar) } deriving (Show) + normRule :: T.Spanned P.Rule -- ^ Term to digest -> (Rule, ANFWarns) normRule (P.Rule i h a r dt T.:~ sp) = @@ -403,7 +406,7 @@ normRule (P.Rule i h a r dt T.:~ sp) = nh <- normTerm False h >>= newAssign "_h" . Left nr <- normTerm True r >>= newAssign "_r" . Left return $ Rule i nh a nr sp - in (ru (s^.as_annot) (s^.as_cruxes),s^.as_warns) + in (ru (s^.as_annot) (s^.as_ucruxes) (s^.as_ecruxes),s^.as_warns) ------------------------------------------------------------------------}}} -- Run the normalizer {{{ @@ -414,18 +417,26 @@ normRule (P.Rule i h a r dt T.:~ sp) = runNormalize :: DisposTab -> ReaderT ANFDict (State ANFState) a -> (a, ANFState) runNormalize dt = - flip runState (AS 0 0 S.empty M.empty []) . + flip runState (AS 0 0 S.empty IM.empty M.empty []) . flip runReaderT (AD dt) ------------------------------------------------------------------------}}} -- Placeholders XXX {{{ +r_cruxes :: Rule -> S.Set (Crux DVar TBase) +r_cruxes r = S.union (S.map Right $ r_ucruxes r) + (S.map Left $ S.fromList $ IM.assocs $ r_ecruxes r) + +evalCruxFA :: EvalCrux DVar -> Maybe DFunctAr +evalCruxFA (CEval _ _) = Nothing +evalCruxFA (CCall _ is f) = Just $ (f, length is) + -- XXX This is terrible and should be replaced with whatever type-checking -- work we do. -findHeadFA :: DVar -> S.Set (Crux DVar TBase) -> Maybe DFunctAr +findHeadFA :: DVar -> S.Set (UnifCrux DVar TBase) -> Maybe DFunctAr findHeadFA h crs = MA.listToMaybe $ MA.mapMaybe m - $ snd $ E.partitionEithers (S.toList crs) + $ S.toList crs where m (CStruct o is f) | o == h = Just (f,length is) m _ = Nothing diff --git a/src/Dyna/Analysis/ANFPretty.hs b/src/Dyna/Analysis/ANFPretty.hs index 7a54bbe..b2a7a2e 100644 --- a/src/Dyna/Analysis/ANFPretty.hs +++ b/src/Dyna/Analysis/ANFPretty.hs @@ -1,21 +1,20 @@ module Dyna.Analysis.ANFPretty (printANF) where -import qualified Data.Either as E +import qualified Data.IntMap as IM import qualified Data.Set as S import Dyna.Analysis.ANF import Dyna.Term.Normalized import Dyna.XXX.PPrint (valign) import Text.PrettyPrint.Free -import qualified Text.Trifecta as T import Dyna.XXX.Trifecta (prettySpanLoc) ------------------------------------------------------------------------}}} -- Pretty Printer {{{ printANF :: Rule -> Doc e -printANF (Rule rix h a result sp _ cruxes) = +printANF (Rule rix h a result sp _ unifs evals) = text ";;" <+> prettySpanLoc sp `above` text ";; index" <+> pretty rix @@ -28,8 +27,6 @@ printANF (Rule rix h a result sp _ cruxes) = ] ) <> line where - (evals, unifs) = E.partitionEithers (S.elems cruxes) - pft :: FDT -> Doc e pft (fn,args) = hsep $ (pretty fn : (map pretty args)) @@ -37,15 +34,15 @@ printANF (Rule rix h a result sp _ cruxes) = pnft (n,(f,args)) = parens $ hsep $ ( pretty f <> char '@' <> pretty n : (map pretty args)) - pev (CEval n o i) = parens (pretty o <+> pretty i <> char '@' <> pretty n) - pev (CCall n o is f) = parens (pretty o <+> pnft (n,(f,is))) + 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))) 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 pev evals - puns = valign $ map pun unifs + pevs = valign $ map (uncurry pev) (IM.toAscList evals) + puns = valign $ map pun (S.toList unifs) ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/Aggregation.hs b/src/Dyna/Analysis/Aggregation.hs index e41159f..8172cc8 100644 --- a/src/Dyna/Analysis/Aggregation.hs +++ b/src/Dyna/Analysis/Aggregation.hs @@ -12,9 +12,7 @@ module Dyna.Analysis.Aggregation ( ) where -- import qualified Data.ByteString as B -import qualified Data.Either as E import qualified Data.Map as M -import qualified Data.Set as S import Dyna.Analysis.ANF import Dyna.Main.Exception import Dyna.Term.TTerm @@ -30,19 +28,20 @@ type AggMap = M.Map DFunctAr DAgg ------------------------------------------------------------------------}}} -- Associate each item with an aggregator {{{ -procANF :: Rule -> (DFunctAr, DAgg) -procANF r@(Rule _ h a _ sp _ crs) = +procANF :: Rule -> DFunctAr +procANF (Rule _ h _ _ sp _ crs _) = + -- XXX findHeadFA is bad and I should feel bad case findHeadFA h crs of Nothing -> dynacSorry $ "The rule at" <+> (prettySpanLoc sp) <+> "is beyond my abilities." - Just t -> (t,a) + Just t -> t buildAggMap :: [Rule] -> AggMap buildAggMap = go (M.empty) where go m [] = m - go m (ar@(Rule _ _ a _ sp _ _):xs) = - let (d,a) = procANF ar + go m (ar@(Rule _ _ a _ sp _ _ _):xs) = + let d = procANF ar in case mapUpsert d a m of Left a' -> dynacUserErr $ "Conflicting aggregators; rule" <+> prettySpanLoc sp <+> "uses" <+> (pretty a) diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index 9747b1c..3d4460e 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -41,12 +41,14 @@ import Control.Monad.Identity import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.Either as E +import qualified Data.IntMap as IM -- import qualified Data.List as L import qualified Data.Map as M import qualified Data.Maybe as MA import qualified Data.Set as S -- import qualified Debug.Trace as XT import Dyna.Analysis.ANF +import Dyna.Analysis.ANFPretty import Dyna.Analysis.DOpAMine import Dyna.Analysis.Mode import Dyna.Analysis.Mode.Execution.NoAliasContext @@ -157,6 +159,10 @@ possible fp cr = -- the moment, since everything we do is either IFree or IUniv, just use -- iEq everywhere. + -- 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 + -- any liveness analysis correctly! + -- Assign or check Right (CAssign o i) -> fup o (runReaderT (unifyVU o) (UnifParams True False) @@ -196,10 +202,10 @@ possible fp cr = (return [ OPCkne o i ])) -- XXX Indirect evaluation is not yet supported - Left (CEval _ _ _) -> dynacSorry "Indir eval" + Left (_, CEval _ _) -> dynacSorry "Indir eval" -- Evaluation - Left (CCall _ vo vis funct) -> do + Left (_, CCall vo vis funct) -> do is <- mapM mkMV vis o <- mkMV vo case fp (funct,is,o) of @@ -456,10 +462,10 @@ planner_ st sc cr mic bv fv = runAgenda -- XREF:INITPLAN (ip,bi) = case mic of Nothing -> ([],S.empty) - Just (CCall _ o is f, hi, ho) -> ( [ OPPeel is hi f + Just (CCall o is f, hi, ho) -> ( [ OPPeel is hi f , OPAsgn o (NTVar ho)] , S.fromList $ o:is) - Just (CEval _ o i, hi, ho) -> ( [ OPAsgn i (NTVar hi) + Just (CEval o i, hi, ho) -> ( [ OPAsgn i (NTVar hi) , OPAsgn o (NTVar ho)] , S.fromList $ [o,i] ) @@ -495,7 +501,8 @@ planUpdate bp sc anf mi fv = bestPlan $ planner_ (possible bp) sc anf (Just mi) S.empty fv planInitializer :: BackendPossible fbs -> Rule -> Maybe (Cost, Actions fbs) -planInitializer bp (Rule { r_cruxes = cruxes }) = +planInitializer bp r = + let cruxes = r_cruxes r in bestPlan $ planner_ (possible bp) simpleCost cruxes Nothing S.empty (allCruxVars cruxes) -- | Given a particular crux and the remaining evaluation cruxes in a rule, @@ -505,22 +512,22 @@ planInitializer bp (Rule { r_cruxes = cruxes }) = -- See $dupcrux. handleDoubles :: (Ord a, Ord b) => (Int -> a -> a -> a) - -> EvalCrux a - -> S.Set (EvalCrux a) + -> (Int,EvalCrux a) + -> S.Set (Int, EvalCrux a) -> S.Set (UnifCrux a b) handleDoubles vc e r = S.fold (go e) S.empty r where - go (CEval en _ ei) (CEval qn _ qi) s = + go (en, CEval _ ei) (qn, CEval _ qi) s = if en > qn then s else S.insert (CNotEqu ei qi) s - go (CCall en eo eis ef) (CEval qn qo qi) s = + go (en, CCall eo eis ef) (qn, CEval qo qi) s = if en > qn then s else let cv = vc 0 eo qo in S.insert (CStruct cv eis ef) $ S.insert (CNotEqu cv qi) s - go (CEval en eo ei) (CCall qn qo qis qf) s = + go (en, CEval eo ei) (qn, CCall qo qis qf) s = if en > qn then s else let cv = vc 0 eo qo in S.insert (CStruct cv qis qf) $ S.insert (CNotEqu cv ei) s - go (CCall en eo eis ef) (CCall qn qo qis qf) s = + go (en, CCall eo eis ef) (qn, CCall qo qis qf) s = if en > qn || ef /= qf || length eis /= length qis then s else let ecv = vc 0 eo qo @@ -532,29 +539,31 @@ handleDoubles vc e r = S.fold (go e) S.empty r planEachEval :: BackendPossible fbs -- ^ The backend's primitive support -> (DFunctAr -> Bool) -- ^ Indicator for constant function -> Rule - -> [(Maybe DFunctAr, Int, Maybe (Cost, DVar, DVar, Actions fbs))] + -> [(Int, Maybe (Cost, DVar, DVar, Actions fbs))] -- planEachEval _ _ _ = [] -planEachEval bp cs (Rule { r_cruxes = cruxes }) = - map (\(mfa,n,cr) -> +planEachEval bp cs r = + map (\(n,cr) -> let cruxes' = S.union cruxes (S.map Right $ handleDoubles mkvar cr (S.delete cr $ S.fromList ecs)) - in (mfa,n, varify $ planUpdate bp simpleCost + in (n, varify $ planUpdate bp simpleCost cruxes' - (mic cr) + (mic $ snd cr) (allCruxVars cruxes'))) -- Filter out non-constant evaluations -- -- XXX This instead should look at the update modes of each evaluation $ MA.mapMaybe (\ec -> case ec of - CCall n _ is f | not (cs (f,length is)) - -> Just (Just (f,length is), n, ec) - CCall _ _ _ _ -> Nothing - CEval n _ _ -> Just (Nothing,n,ec)) + (n, CCall _ is f) | not (cs (f,length is)) + -> Just (n, ec) + (_, CCall _ _ _) -> Nothing + (n, CEval _ _ ) -> Just (n,ec)) -- Grab all evaluations $ ecs where + cruxes = r_cruxes r + mkvar n v1 v2 = B.concat ["chk",v1,"_",v2,"_",BC.pack $ show n] ecs = fst $ E.partitionEithers $ S.toList cruxes @@ -599,7 +608,7 @@ type UpdateEvalMap fbs = M.Map (Maybe DFunctAr) -- -- timv: might want to fuse these into one circuit -- -combineUpdatePlans :: [(Rule,[( Maybe DFunctAr, Int, +combineUpdatePlans :: [(Rule,[( Int, Maybe (Cost, DVar, DVar, Actions fbs))])] -> UpdateEvalMap fbs combineUpdatePlans = go (M.empty) @@ -608,7 +617,7 @@ combineUpdatePlans = go (M.empty) go m ((fr,cmca):xs) = go' xs fr cmca m go' xs _ [] m = go m xs - go' xs fr ((fa,n,mca):ys) m = + go' xs fr ((n,mca):ys) m = case mca of Nothing -> dynacUserErr $ "No update plan for " @@ -616,6 +625,12 @@ combineUpdatePlans = go (M.empty) <+> "in rule at" <+> (prettySpanLoc $ r_span fr) Just (c,v1,v2,a) -> go' xs fr ys $ mapInOrApp fa (fr,n,c,v1,v2,a) m + where + fa = evalCruxFA ev + ev = maybe (dynacPanic $ "Eval index without eval crux in rule " + <+> (printANF fr)) + id + (IM.lookup n (r_ecruxes fr)) ------------------------------------------------------------------------}}} -- Backward chaining plan combination {{{ diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs index c5bdee3..34571eb 100644 --- a/src/Dyna/Backend/Python/Backend.hs +++ b/src/Dyna/Backend/Python/Backend.hs @@ -220,9 +220,9 @@ printPlanHeader h r c mn = do hPutStrLn h $ "# Cost: " ++ (show c) printInitializer :: Handle -> Rule -> Actions PyDopeBS -> IO () -printInitializer fh rule@(Rule _ h _ r _ _ cruxes) dope = do +printInitializer fh rule@(Rule _ h _ r _ _ ucruxes _) dope = do displayIO fh $ renderPretty 1.0 100 - $ "@initializer" <> parens (uncurry pfa $ MA.fromJust $ findHeadFA h cruxes) + $ "@initializer" <> parens (uncurry pfa $ MA.fromJust $ findHeadFA h ucruxes) `above` "def" <+> char '_' <> tupled [] <+> colon `above` pdope dope emit <> line @@ -231,7 +231,7 @@ printInitializer fh rule@(Rule _ h _ r _ _ cruxes) dope = do -- XXX INDIR EVAL printUpdate :: Handle -> Rule -> Maybe DFunctAr -> (DVar, DVar) -> Actions PyDopeBS -> IO () -printUpdate fh rule@(Rule _ h _ r _ _ _) (Just (f,a)) (hv,v) dope = do +printUpdate fh rule@(Rule _ h _ r _ _ _ _) (Just (f,a)) (hv,v) dope = do displayIO fh $ renderPretty 1.0 100 $ "@register" <> parens (pfa f a) `above` "def" <+> char '_' <> tupled (map pretty [hv,v]) <+> colon