SelfDispos(..), ArgDispos(..), ECSrc(..), EvalCtx,
-- * Placeholders
- findHeadFA,
+ evalCruxFA, findHeadFA, r_cruxes,
) where
import Control.Lens
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
------------------------------------------------------------------------}}}
-- 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
| 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
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
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)]
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
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
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)
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):)
, 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) =
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 {{{
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
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
]
) <> line
where
- (evals, unifs) = E.partitionEithers (S.elems cruxes)
-
pft :: FDT -> Doc e
pft (fn,args) = hsep $ (pretty fn : (map pretty args))
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)
------------------------------------------------------------------------}}}
) 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
------------------------------------------------------------------------}}}
-- 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)
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
-- 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)
(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
-- 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] )
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,
-- 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
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
--
-- 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)
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 "
<+> "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 {{{
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
-- 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
projects / dyna2 / commitdiff