@@ -38,7 +38,7 @@ import Data.List.NonEmpty (NonEmpty (..), toList)
38
38
import Data.List.NonEmpty qualified as NE
39
39
import Data.Map qualified as Map
40
40
import Data.Maybe (catMaybes , fromMaybe )
41
- import Data.Sequence (Seq , (|>) )
41
+ import Data.Sequence as Seq (Seq , fromList , (|>) )
42
42
import Data.Set qualified as Set
43
43
import Data.Text as Text (Text , pack )
44
44
import Numeric.Natural
@@ -55,9 +55,12 @@ import Booster.LLVM as LLVM (API)
55
55
import Booster.Log
56
56
import Booster.Pattern.ApplyEquations (
57
57
CacheTag (Equations ),
58
+ Direction (.. ),
58
59
EquationFailure (.. ),
59
60
SimplifierCache (.. ),
61
+ evaluateConstraints ,
60
62
evaluatePattern ,
63
+ evaluateTerm ,
61
64
simplifyConstraint ,
62
65
)
63
66
import Booster.Pattern.Base
@@ -516,9 +519,16 @@ applyRule pat@Pattern{ceilConditions} rule =
516
519
, rulePredicate = Just rulePredicate
517
520
}
518
521
where
519
- filterOutKnownConstraints :: Set. Set Predicate -> [Predicate ] -> RewriteT io [Predicate ]
520
- filterOutKnownConstraints priorKnowledge constraitns = do
521
- let (knownTrue, toCheck) = partition (`Set.member` priorKnowledge) constraitns
522
+ -- These predicates are known (and do not change) during the
523
+ -- entire rewrite step. The simplifier cache cannot be retained
524
+ -- when additional predicates are used (see 'checkConstraint').
525
+ knownPatternPredicates =
526
+ pat. constraints <> (Set. fromList . asEquations $ pat. substitution)
527
+
528
+ filterOutKnownConstraints :: [Predicate ] -> RewriteT io [Predicate ]
529
+ filterOutKnownConstraints constraints = do
530
+ let (knownTrue, toCheck) =
531
+ partition (`Set.member` knownPatternPredicates) constraints
522
532
unless (null knownTrue) $
523
533
getPrettyModifiers >>= \ case
524
534
ModifiersRep (_ :: FromModifiersT mods => Proxy mods ) ->
@@ -537,14 +547,16 @@ applyRule pat@Pattern{ceilConditions} rule =
537
547
Set. Set Predicate ->
538
548
Predicate ->
539
549
RewriteRuleAppT (RewriteT io ) (Maybe a )
540
- checkConstraint onUnclear onBottom knownPredicates p = do
550
+ checkConstraint onUnclear onBottom extraPredicates p = do
541
551
RewriteConfig {definition, llvmApi, smtSolver} <- lift $ RewriteT ask
542
- RewriteState {cache = oldCache} <- lift . RewriteT . lift $ get
543
- (simplified, cache) <-
552
+ RewriteState {cache} <- lift . RewriteT . lift $ get
553
+ let knownPredicates = knownPatternPredicates <> extraPredicates
554
+ (simplified, newCache) <-
544
555
withContext CtxConstraint $
545
- simplifyConstraint definition llvmApi smtSolver oldCache knownPredicates p
546
- -- update cache
547
- lift $ updateRewriterCache cache
556
+ simplifyConstraint definition llvmApi smtSolver cache knownPredicates p
557
+ -- Important: only retain new cache if no extraPredicates were supplied!
558
+ when (Set. null extraPredicates) $
559
+ lift (updateRewriterCache newCache)
548
560
case simplified of
549
561
Right (Predicate FalseBool ) -> onBottom
550
562
Right (Predicate TrueBool ) -> pure Nothing
@@ -559,14 +571,9 @@ applyRule pat@Pattern{ceilConditions} rule =
559
571
-- apply substitution to rule requires
560
572
let ruleRequires =
561
573
concatMap (splitBoolPredicates . substituteInPredicate matchingSubst) rule. requires
562
- knownConstraints = pat. constraints <> (Set. fromList . asEquations $ pat. substitution)
563
574
564
575
-- filter out any predicates known to be _syntactically_ present in the known prior
565
- toCheck <-
566
- lift $
567
- filterOutKnownConstraints
568
- knownConstraints
569
- ruleRequires
576
+ toCheck <- lift $ filterOutKnownConstraints ruleRequires
570
577
571
578
-- simplify the constraints (one by one in isolation). Stop if false, abort rewrite if indeterminate.
572
579
unclearRequires <-
@@ -575,17 +582,13 @@ applyRule pat@Pattern{ceilConditions} rule =
575
582
( checkConstraint
576
583
id
577
584
returnNotApplied
578
- knownConstraints
585
+ mempty -- checkConstraint already considers knownConstraints
579
586
)
580
587
toCheck
581
588
582
589
-- unclear conditions may have been simplified and
583
590
-- could now be syntactically present in the path constraints, filter again
584
- stillUnclear <-
585
- lift $
586
- filterOutKnownConstraints
587
- knownConstraints
588
- unclearRequires
591
+ stillUnclear <- lift $ filterOutKnownConstraints unclearRequires
589
592
590
593
-- check unclear requires-clauses in the context of known constraints (priorKnowledge)
591
594
solver <- lift $ RewriteT $ (. smtSolver) <$> ask
@@ -614,17 +617,14 @@ applyRule pat@Pattern{ceilConditions} rule =
614
617
-- apply substitution to rule ensures
615
618
let ruleEnsures =
616
619
concatMap (splitBoolPredicates . coerce . substituteInTerm matchingSubst . coerce) rule. ensures
617
- knownConstraints =
618
- pat. constraints
619
- <> (Set. fromList . asEquations $ pat. substitution)
620
- <> Set. fromList unclearRequiresAfterSmt
621
620
newConstraints <-
622
621
catMaybes
623
622
<$> mapM
624
623
( checkConstraint
625
624
id
626
625
returnTrivial
627
- knownConstraints
626
+ -- supply required path conditions as extra constraints
627
+ (Set. fromList unclearRequiresAfterSmt)
628
628
)
629
629
ruleEnsures
630
630
@@ -672,7 +672,7 @@ applyRule pat@Pattern{ceilConditions} rule =
672
672
let ruleRequires =
673
673
concatMap (splitBoolPredicates . coerce . substituteInTerm matchingSubst . coerce) rule. requires
674
674
collapseAndBools . catMaybes
675
- <$> mapM (checkConstraint id returnNotApplied pat . constraints ) ruleRequires
675
+ <$> mapM (checkConstraint id returnNotApplied mempty ) ruleRequires
676
676
677
677
ruleGroupPriority :: [RewriteRule a ] -> Maybe Priority
678
678
ruleGroupPriority = \ case
@@ -1001,9 +1001,16 @@ performRewrite ::
1001
1001
Pattern ->
1002
1002
io (Natural , Seq (RewriteTrace () ), RewriteResult Pattern )
1003
1003
performRewrite rewriteConfig pat = do
1004
- (rr, RewriteStepsState {counter, traces}) <-
1005
- flip runStateT rewriteStart $ doSteps False pat
1006
- pure (counter, traces, rr)
1004
+ simplifiedConstraints <-
1005
+ withContext CtxSimplify $ evaluateConstraints definition llvmApi smtSolver pat. constraints
1006
+ case simplifiedConstraints of
1007
+ Right constraints ->
1008
+ (flip runStateT rewriteStart $ doSteps False pat{constraints})
1009
+ >>= \ (rr, RewriteStepsState {counter, traces}) -> pure (counter, traces, rr)
1010
+ Left r@ (SideConditionFalse {}) ->
1011
+ pure (0 , fromList [RewriteSimplified (Just r)], error " Just return #Bottom here" )
1012
+ Left err ->
1013
+ error (show err)
1007
1014
where
1008
1015
RewriteConfig
1009
1016
{ definition
@@ -1034,6 +1041,27 @@ performRewrite rewriteConfig pat = do
1034
1041
1035
1042
updateCache simplifierCache = modify $ \ rss -> (rss :: RewriteStepsState ){simplifierCache}
1036
1043
1044
+ -- only simplifies the _term_ of the pattern
1045
+ simplifyT :: Pattern -> StateT RewriteStepsState io (Maybe Pattern )
1046
+ simplifyT p = withContext CtxSimplify $ do
1047
+ cache <- simplifierCache <$> get
1048
+ evaluateTerm BottomUp definition llvmApi smtSolver cache p. constraints p. term >>= \ (res, newCache) -> do
1049
+ updateCache newCache
1050
+ case res of
1051
+ Right newTerm -> do
1052
+ emitRewriteTrace $ RewriteSimplified Nothing
1053
+ pure $ Just p{term = newTerm}
1054
+ Left r@ SideConditionFalse {} -> do
1055
+ emitRewriteTrace $ RewriteSimplified (Just r)
1056
+ pure Nothing
1057
+ Left r@ UndefinedTerm {} -> do
1058
+ emitRewriteTrace $ RewriteSimplified (Just r)
1059
+ pure Nothing
1060
+ Left other -> do
1061
+ emitRewriteTrace $ RewriteSimplified (Just other)
1062
+ pure $ Just p
1063
+
1064
+ -- simplifies term and constraints of the pattern
1037
1065
simplifyP :: Pattern -> StateT RewriteStepsState io (Maybe Pattern )
1038
1066
simplifyP p = withContext CtxSimplify $ do
1039
1067
st <- get
@@ -1228,7 +1256,7 @@ performRewrite rewriteConfig pat = do
1228
1256
else withSimplified pat' msg (pure . RewriteAborted failure)
1229
1257
where
1230
1258
withSimplified p msg cont = do
1231
- (withPatternContext p $ simplifyP p) >>= \ case
1259
+ (withPatternContext p $ simplifyT p) >>= \ case
1232
1260
Nothing -> do
1233
1261
logMessage (" Rewrite stuck after simplification." :: Text )
1234
1262
pure $ RewriteStuck p
0 commit comments