From c950e88c34ef31d158fd8414edd79ceb13b3a1d1 Mon Sep 17 00:00:00 2001 From: Laurent Date: Wed, 23 Feb 2022 16:53:14 -0500 Subject: [PATCH 1/6] Add strictness annotations --- core/src/Language/Avaleryar/Semantics.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/core/src/Language/Avaleryar/Semantics.hs b/core/src/Language/Avaleryar/Semantics.hs index 7a0b24b..ae5e98a 100644 --- a/core/src/Language/Avaleryar/Semantics.hs +++ b/core/src/Language/Avaleryar/Semantics.hs @@ -86,8 +86,8 @@ import Language.Avaleryar.Syntax -- | A native predicate carries not just its evaluation function, but also its signature, so it may -- be consulted when new assertions are submitted in order to mode-check them. data NativePred = NativePred - { nativePred :: Lit EVar -> Avaleryar () - , nativeSig :: ModedLit + { nativePred :: !(Lit EVar -> Avaleryar ()) + , nativeSig :: !ModedLit } deriving Generic instance NFData NativePred @@ -109,8 +109,8 @@ instance NFData NativeDb -- TODO: newtype harder (newtype RuleAssertion c = ..., newtype NativeAssertion c = ...) data Db = Db - { rulesDb :: RulesDb - , nativeDb :: NativeDb + { rulesDb :: !RulesDb + , nativeDb :: !NativeDb } deriving (Generic) instance Semigroup Db where @@ -135,9 +135,9 @@ loadNative n p = getsRT (unNativeDb . nativeDb . db) >>= alookup n >>= alookup p -- | Runtime state for 'Avaleryar' computations. data RT = RT - { env :: Env -- ^ The accumulated substitution - , epoch :: Epoch -- ^ A counter for generating fresh variables - , db :: Db -- ^ The database of compiled predicates + { env :: !Env -- ^ The accumulated substitution + , epoch :: !Epoch -- ^ A counter for generating fresh variables + , db :: !Db -- ^ The database of compiled predicates } deriving (Generic) -- | Allegedly more-detailed results from an 'Avaleryar' computation. A more ergonomic type is From b937e0cb187c910d6c79253cd6953693dc716436 Mon Sep 17 00:00:00 2001 From: Laurent Date: Wed, 23 Feb 2022 16:59:00 -0500 Subject: [PATCH 2/6] Optimize case where rules are all facts --- core/package.yaml | 1 + core/src/Language/Avaleryar/Semantics.hs | 59 +++++++++++++++++++++--- 2 files changed, 53 insertions(+), 7 deletions(-) diff --git a/core/package.yaml b/core/package.yaml index b29def6..74729a6 100644 --- a/core/package.yaml +++ b/core/package.yaml @@ -15,6 +15,7 @@ library: - qq-literals - template-haskell - text + - unordered-containers - wl-pprint-text tests: diff --git a/core/src/Language/Avaleryar/Semantics.hs b/core/src/Language/Avaleryar/Semantics.hs index ae5e98a..907643e 100644 --- a/core/src/Language/Avaleryar/Semantics.hs +++ b/core/src/Language/Avaleryar/Semantics.hs @@ -70,8 +70,10 @@ import Control.DeepSeq (NFData) import Control.Monad.Except import Control.Monad.State import Data.Foldable +import qualified Data.HashSet as HashSet import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe import Data.String import Data.Text (Text, pack) import Data.Void (vacuous) @@ -261,11 +263,8 @@ unifyArgs [] [] = pure () unifyArgs (x:xs) (y:ys) = unifyTerm x y >> unifyArgs xs ys unifyArgs _ _ = empty --- | NB: 'compilePred' doesn't look at the 'Pred' for any of the given rules, it assumes it was --- given a query that applies, and that the rules it was handed are all for the same predicate. --- This is not the function you want. FIXME: Suck less -compilePred :: [Rule TextVar] -> Lit EVar -> Avaleryar () -compilePred rules (Lit _ qas) = do +compilePredDefault :: [Rule TextVar] -> Lit EVar -> Avaleryar () +compilePredDefault rules (Lit _ qas) = do rt@RT {..} <- getRT putRT rt {epoch = succ epoch} let rules' = fmap (EVar epoch) <$> rules @@ -274,14 +273,60 @@ compilePred rules (Lit _ qas) = do traverse_ resolve body msum $ go <$> rules' +-- | NB: 'compilePred' doesn't look at the 'Pred' for any of the given rules, it assumes it was +-- given a query that applies, and that the rules it was handed are all for the same predicate. +-- This is not the function you want. +compilePred :: [Rule TextVar] -> Lit EVar -> Avaleryar () +compilePred rules = + -- If the rules are all facts, we can efficiently check + if (all isFact rules) + then + let setOfVals = HashSet.fromList $ fmap (mapMaybe termVal . litTerms . ruleLit) rules + in \arg@(Lit _ qas) -> do + qas <- traverse subst qas + if HashSet.member (mapMaybe termVal qas) setOfVals + then pure () + else + -- Maybe `qas` in not in the set of values because the terms are don't yet have values. + -- In that case, we revert to the default behavior. + -- Because we stop evaluating when we reach the first solution, that is only evaluated if necessary. + -- TODO: This can probably be optimized, but I can't think of a better and simplier way than that. + compilePredDefault rules arg + else compilePredDefault rules + where + + -- A fact is a rule that has no body and matches directly on values + isFact :: Rule a -> Bool + isFact rule = null (ruleBody rule) && all (not . termIsVar) (litTerms $ ruleLit rule) + + ruleBody :: Rule a -> [BodyLit a] + ruleBody (Rule _lit body) = body + + ruleLit :: Rule a -> Lit a + ruleLit (Rule lit _body) = lit + + litTerms :: Lit a -> [Term a] + litTerms (Lit _pred terms) = terms + + ruleTerms :: Rule a -> [Term a] + ruleTerms = litTerms . ruleLit + + termVal :: Term a -> Maybe Value + termVal (Val v) = Just v + termVal (Var _) = Nothing + + termIsVar :: Term a -> Bool + termIsVar (Var _) = True + termIsVar _ = False + -- | Turn a list of 'Rule's into a map from their names to code that executes them. -- -- Substitutes the given assertion for references to 'ARCurrent' in the bodies of the rules. This -- is somewhat gross, and needs to be reexamined in the fullness of time. compileRules :: Text -> [Rule TextVar] -> Map Pred (Lit EVar -> Avaleryar ()) compileRules assn rules = - fmap compilePred $ Map.fromListWith (++) [(p, [emplaceCurrentAssertion assn r]) - | r@(Rule (Lit p _) _) <- rules] + fmap compilePred $ Map.fromListWith (++) [ (p, [emplaceCurrentAssertion assn r]) + | r@(Rule (Lit p _) _) <- rules ] emplaceCurrentAssertion :: Text -> Rule v -> Rule v emplaceCurrentAssertion assn (Rule l b) = Rule l (go <$> b) From 4d998cca4f95fb89753109ca6b709ac9ae10d422 Mon Sep 17 00:00:00 2001 From: Laurent Date: Wed, 23 Feb 2022 18:41:11 -0500 Subject: [PATCH 3/6] Only fallback to default behavior when necessary --- core/src/Language/Avaleryar/Semantics.hs | 41 +++++++++++++----------- 1 file changed, 23 insertions(+), 18 deletions(-) diff --git a/core/src/Language/Avaleryar/Semantics.hs b/core/src/Language/Avaleryar/Semantics.hs index 907643e..6b1e3b5 100644 --- a/core/src/Language/Avaleryar/Semantics.hs +++ b/core/src/Language/Avaleryar/Semantics.hs @@ -273,31 +273,36 @@ compilePredDefault rules (Lit _ qas) = do traverse_ resolve body msum $ go <$> rules' --- | NB: 'compilePred' doesn't look at the 'Pred' for any of the given rules, it assumes it was --- given a query that applies, and that the rules it was handed are all for the same predicate. --- This is not the function you want. +-- | NB: 'compilePred' assumes it was given a query that applies, and that the +-- rules it was handed are all for the same predicate. This is not the function +-- you want. compilePred :: [Rule TextVar] -> Lit EVar -> Avaleryar () compilePred rules = - -- If the rules are all facts, we can efficiently check - if (all isFact rules) + -- If the rules are all facts, unification may be done using a set in some common cases. + if all isFact rules then + -- We precompute the set let setOfVals = HashSet.fromList $ fmap (mapMaybe termVal . litTerms . ruleLit) rules in \arg@(Lit _ qas) -> do qas <- traverse subst qas - if HashSet.member (mapMaybe termVal qas) setOfVals - then pure () - else - -- Maybe `qas` in not in the set of values because the terms are don't yet have values. - -- In that case, we revert to the default behavior. - -- Because we stop evaluating when we reach the first solution, that is only evaluated if necessary. - -- TODO: This can probably be optimized, but I can't think of a better and simplier way than that. - compilePredDefault rules arg + let f term (allVals, vals) = case term of + Val v -> (allVals, v:vals) + Var _ -> (False, vals) + let (allVals, vals) = foldr f (True, []) qas + -- This only works if the unification is being done between only values. + -- In that case, if the values of qas are in the set, the predicate succeeds. + -- Otherwise, it fails. + if allVals + then guard (HashSet.member vals setOfVals) + -- If qas aren't all values, we can't use the set and must fallback to the default behavior. + -- This is because in this case the variables will be unified with the values, so it's not just + -- a guard. + else compilePredDefault rules arg else compilePredDefault rules where - -- A fact is a rule that has no body and matches directly on values isFact :: Rule a -> Bool - isFact rule = null (ruleBody rule) && all (not . termIsVar) (litTerms $ ruleLit rule) + isFact rule = null (ruleBody rule) && all termIsVal (litTerms $ ruleLit rule) ruleBody :: Rule a -> [BodyLit a] ruleBody (Rule _lit body) = body @@ -315,9 +320,9 @@ compilePred rules = termVal (Val v) = Just v termVal (Var _) = Nothing - termIsVar :: Term a -> Bool - termIsVar (Var _) = True - termIsVar _ = False + termIsVal :: Term a -> Bool + termIsVal (Val _) = True + termIsVal (Var _) = False -- | Turn a list of 'Rule's into a map from their names to code that executes them. -- From aa272f4effc078b572b909d78a9f3ce470e7e2fe Mon Sep 17 00:00:00 2001 From: Laurent Date: Fri, 25 Feb 2022 10:28:52 -0500 Subject: [PATCH 4/6] Replace HashSet with Vector --- core/package.yaml | 1 + core/src/Language/Avaleryar/Semantics.hs | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/package.yaml b/core/package.yaml index 74729a6..0e8975f 100644 --- a/core/package.yaml +++ b/core/package.yaml @@ -16,6 +16,7 @@ library: - template-haskell - text - unordered-containers + - vector - wl-pprint-text tests: diff --git a/core/src/Language/Avaleryar/Semantics.hs b/core/src/Language/Avaleryar/Semantics.hs index 6b1e3b5..acd089d 100644 --- a/core/src/Language/Avaleryar/Semantics.hs +++ b/core/src/Language/Avaleryar/Semantics.hs @@ -70,11 +70,12 @@ import Control.DeepSeq (NFData) import Control.Monad.Except import Control.Monad.State import Data.Foldable -import qualified Data.HashSet as HashSet import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.String +import Data.Vector (Vector) +import qualified Data.Vector as Vector import Data.Text (Text, pack) import Data.Void (vacuous) import GHC.Clock (getMonotonicTime) @@ -282,7 +283,7 @@ compilePred rules = if all isFact rules then -- We precompute the set - let setOfVals = HashSet.fromList $ fmap (mapMaybe termVal . litTerms . ruleLit) rules + let setOfVals = Vector.fromList $ fmap (mapMaybe termVal . litTerms . ruleLit) rules in \arg@(Lit _ qas) -> do qas <- traverse subst qas let f term (allVals, vals) = case term of @@ -293,7 +294,7 @@ compilePred rules = -- In that case, if the values of qas are in the set, the predicate succeeds. -- Otherwise, it fails. if allVals - then guard (HashSet.member vals setOfVals) + then guard (Vector.elem vals setOfVals) -- If qas aren't all values, we can't use the set and must fallback to the default behavior. -- This is because in this case the variables will be unified with the values, so it's not just -- a guard. From 3329f4a7ba6d39bfc033cf2118a1b47f031e97f7 Mon Sep 17 00:00:00 2001 From: Laurent Date: Fri, 25 Feb 2022 13:36:27 -0500 Subject: [PATCH 5/6] Remove unordered-containers dependency --- core/package.yaml | 1 - core/src/Language/Avaleryar/Semantics.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/core/package.yaml b/core/package.yaml index 0e8975f..f7e7ca3 100644 --- a/core/package.yaml +++ b/core/package.yaml @@ -15,7 +15,6 @@ library: - qq-literals - template-haskell - text - - unordered-containers - vector - wl-pprint-text diff --git a/core/src/Language/Avaleryar/Semantics.hs b/core/src/Language/Avaleryar/Semantics.hs index acd089d..d9a2cb2 100644 --- a/core/src/Language/Avaleryar/Semantics.hs +++ b/core/src/Language/Avaleryar/Semantics.hs @@ -72,7 +72,7 @@ import Control.Monad.State import Data.Foldable import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe +import Data.Maybe (mapMaybe) import Data.String import Data.Vector (Vector) import qualified Data.Vector as Vector From 4fbf8d1107e00b959016eade4f3f158b13e0b8c2 Mon Sep 17 00:00:00 2001 From: Laurent Date: Fri, 25 Feb 2022 13:41:28 -0500 Subject: [PATCH 6/6] Update cabal file --- core/avaleryar.cabal | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/core/avaleryar.cabal b/core/avaleryar.cabal index 4f79895..8cf0585 100644 --- a/core/avaleryar.cabal +++ b/core/avaleryar.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 30fac0c3b148d219353f8644d0c0934b9b681991e4892964c8bbf9aba9738fc7 +-- hash: f8cb069a0604c1962ead2433e06e9d15fe5c8b4130dd40019dfb22f3cd57183e name: avaleryar version: 0.0.1.1 @@ -39,6 +39,7 @@ library , qq-literals , template-haskell , text + , vector , wl-pprint-text default-language: Haskell2010