@@ -10,6 +10,8 @@ License : BSD-3-Clause
1010module Booster.Pattern.ApplyEquations (
1111 evaluateTerm ,
1212 evaluatePattern ,
13+ pattern CheckConstraintsConsistent ,
14+ pattern NoCheckConstraintsConsistent ,
1315 Direction (.. ),
1416 EquationT (.. ),
1517 runEquationT ,
@@ -70,7 +72,7 @@ import Booster.Pattern.Util
7072import Booster.Prettyprinter (renderOneLineText )
7173import Booster.SMT.Interface qualified as SMT
7274import Booster.Syntax.Json.Externalise (externaliseTerm )
73- import Booster.Util (Bound (.. ))
75+ import Booster.Util (Bound (.. ), Flag ( .. ) )
7476import Kore.JsonRpc.Types.ContextLog (CLContext (CLWithId ), IdContext (CtxCached ))
7577import Kore.Util (showHashHex )
7678
@@ -443,6 +445,12 @@ evaluateTerm' ::
443445 EquationT io Term
444446evaluateTerm' direction = iterateEquations direction PreferFunctions
445447
448+ pattern CheckConstraintsConsistent :: Flag " CheckConstraintsConsistent"
449+ pattern CheckConstraintsConsistent = Flag True
450+
451+ pattern NoCheckConstraintsConsistent :: Flag " CheckConstraintsConsistent"
452+ pattern NoCheckConstraintsConsistent = Flag False
453+
446454{- | Simplify a Pattern, processing its constraints independently.
447455 Returns either the first failure or the new pattern if no failure was encountered
448456-}
@@ -452,39 +460,42 @@ evaluatePattern ::
452460 Maybe LLVM. API ->
453461 SMT. SMTContext ->
454462 SimplifierCache ->
463+ Flag " CheckConstraintsConsistent" ->
455464 Pattern ->
456465 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
459468
460469-- version for internal nested evaluation
461470evaluatePattern' ::
462471 LoggerMIO io =>
472+ Flag " CheckConstraintsConsistent" ->
463473 Pattern ->
464474 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 ()
488499
489500 newTerm <- withTermContext term $ evaluateTerm' BottomUp term `catch_` keepTopLevelResults
490501 -- after evaluating the term, evaluate all (existing and newly-acquired) constraints, once
0 commit comments