@@ -10,6 +10,8 @@ License : BSD-3-Clause
10
10
module Booster.Pattern.ApplyEquations (
11
11
evaluateTerm ,
12
12
evaluatePattern ,
13
+ pattern CheckConstraintsConsistent ,
14
+ pattern NoCheckConstraintsConsistent ,
13
15
Direction (.. ),
14
16
EquationT (.. ),
15
17
runEquationT ,
@@ -70,7 +72,7 @@ import Booster.Pattern.Util
70
72
import Booster.Prettyprinter (renderOneLineText )
71
73
import Booster.SMT.Interface qualified as SMT
72
74
import Booster.Syntax.Json.Externalise (externaliseTerm )
73
- import Booster.Util (Bound (.. ))
75
+ import Booster.Util (Bound (.. ), Flag ( .. ) )
74
76
import Kore.JsonRpc.Types.ContextLog (CLContext (CLWithId ), IdContext (CtxCached ))
75
77
import Kore.Util (showHashHex )
76
78
@@ -443,6 +445,12 @@ evaluateTerm' ::
443
445
EquationT io Term
444
446
evaluateTerm' direction = iterateEquations direction PreferFunctions
445
447
448
+ pattern CheckConstraintsConsistent :: Flag " CheckConstraintsConsistent"
449
+ pattern CheckConstraintsConsistent = Flag True
450
+
451
+ pattern NoCheckConstraintsConsistent :: Flag " CheckConstraintsConsistent"
452
+ pattern NoCheckConstraintsConsistent = Flag False
453
+
446
454
{- | Simplify a Pattern, processing its constraints independently.
447
455
Returns either the first failure or the new pattern if no failure was encountered
448
456
-}
@@ -452,39 +460,42 @@ evaluatePattern ::
452
460
Maybe LLVM. API ->
453
461
SMT. SMTContext ->
454
462
SimplifierCache ->
463
+ Flag " CheckConstraintsConsistent" ->
455
464
Pattern ->
456
465
io (Either EquationFailure Pattern , SimplifierCache )
457
- evaluatePattern def mLlvmLibrary smtSolver cache pat =
458
- runEquationT def mLlvmLibrary smtSolver cache pat. constraints . evaluatePattern' $ pat
466
+ evaluatePattern def mLlvmLibrary smtSolver cache doCheck pat =
467
+ runEquationT def mLlvmLibrary smtSolver cache pat. constraints . evaluatePattern' doCheck $ pat
459
468
460
469
-- version for internal nested evaluation
461
470
evaluatePattern' ::
462
471
LoggerMIO io =>
472
+ Flag " CheckConstraintsConsistent" ->
463
473
Pattern ->
464
474
EquationT io Pattern
465
- evaluatePattern' pat@ Pattern {term, constraints, ceilConditions} = withPatternContext pat $ do
466
- solver <- (. smtSolver) <$> getConfig
467
- -- check the pattern's constraints for satisfiability to ensure they are consistent
468
- consistent <-
469
- withContext CtxConstraint $ do
470
- withContext CtxDetail . withTermContext (coerce $ collapseAndBools constraints) $ pure ()
471
- consistent <- SMT. isSat solver (Set. toList constraints)
472
- logMessage $
473
- " Constraints consistency check returns: " <> show consistent
474
- pure consistent
475
- case consistent of
476
- SMT. IsUnsat -> do
477
- -- the constraints are unsatisfiable, which means that the patten is Bottom
478
- throw . SideConditionFalse . collapseAndBools $ constraints
479
- SMT. IsUnknown {} -> do
480
- -- unlikely case of an Unknown response to a consistency check.
481
- -- continue to preserve the old behaviour.
482
- withContext CtxConstraint . logWarn . Text. pack $
483
- " Constraints consistency UNKNOWN: " <> show consistent
484
- pure ()
485
- SMT. IsSat {} ->
486
- -- constraints are consistent, continue
487
- pure ()
475
+ evaluatePattern' doCheck pat@ Pattern {term, constraints, ceilConditions} = withPatternContext pat $ do
476
+ when (coerce doCheck) $ do
477
+ solver <- (. smtSolver) <$> getConfig
478
+ -- check the pattern's constraints for satisfiability to ensure they are consistent
479
+ consistent <-
480
+ withContext CtxConstraint $ do
481
+ withContext CtxDetail . withTermContext (coerce $ collapseAndBools constraints) $ pure ()
482
+ consistent <- SMT. isSat solver (Set. toList constraints)
483
+ logMessage $
484
+ " Constraints consistency check returns: " <> show consistent
485
+ pure consistent
486
+ case consistent of
487
+ SMT. IsUnsat -> do
488
+ -- the constraints are unsatisfiable, which means that the patten is Bottom
489
+ throw . SideConditionFalse . collapseAndBools $ constraints
490
+ SMT. IsUnknown {} -> do
491
+ -- unlikely case of an Unknown response to a consistency check.
492
+ -- continue to preserve the old behaviour.
493
+ withContext CtxConstraint . logWarn . Text. pack $
494
+ " Constraints consistency UNKNOWN: " <> show consistent
495
+ pure ()
496
+ SMT. IsSat {} ->
497
+ -- constraints are consistent, continue
498
+ pure ()
488
499
489
500
newTerm <- withTermContext term $ evaluateTerm' BottomUp term `catch_` keepTopLevelResults
490
501
-- after evaluating the term, evaluate all (existing and newly-acquired) constraints, once
0 commit comments