@@ -44,7 +44,7 @@ import Booster.Definition.Base qualified as Definition (RewriteRule (..))
4444import Booster.LLVM as LLVM (API )
4545import Booster.Log
4646import Booster.Pattern.ApplyEquations qualified as ApplyEquations
47- import Booster.Pattern.Base (Pattern (.. ), Sort (SortApp ), Term , Variable )
47+ import Booster.Pattern.Base (Pattern (.. ), Sort (SortApp ))
4848import Booster.Pattern.Base qualified as Pattern
4949import Booster.Pattern.Implies (runImplies )
5050import Booster.Pattern.Pretty
@@ -55,12 +55,11 @@ import Booster.Pattern.Rewrite (
5555 RewriteTrace (.. ),
5656 performRewrite ,
5757 )
58+ import Booster.Pattern.Substitution qualified as Substitution
5859import Booster.Pattern.Util (
5960 freeVariables ,
6061 sortOfPattern ,
6162 sortOfTerm ,
62- substituteInPredicate ,
63- substituteInTerm ,
6463 )
6564import Booster.Prettyprinter (renderText )
6665import Booster.SMT.Interface qualified as SMT
@@ -69,6 +68,7 @@ import Booster.Syntax.Json.Externalise
6968import Booster.Syntax.Json.Internalise (
7069 InternalisedPredicates (.. ),
7170 TermOrPredicates (.. ),
71+ extractSubstitution ,
7272 internalisePattern ,
7373 internaliseTermOrPredicate ,
7474 logPatternError ,
@@ -131,12 +131,14 @@ respond stateVar request =
131131 [ req. logSuccessfulRewrites
132132 , req. logFailedRewrites
133133 ]
134- -- apply the given substitution before doing anything else
134+ -- apply the given substitution before doing anything else,
135+ -- as internalisePattern does not substitute
135136 let substPat =
136137 Pattern
137- { term = substituteInTerm substitution term
138- , constraints = Set. fromList $ map (substituteInPredicate substitution) preds
138+ { term = Substitution. substituteInTerm substitution term
139+ , constraints = Set. fromList $ map (Substitution. substituteInPredicate substitution) preds
139140 , ceilConditions = ceils
141+ , substitution
140142 }
141143 -- remember all variables used in the substitutions
142144 substVars =
@@ -166,7 +168,7 @@ respond stateVar request =
166168 result <-
167169 performRewrite rewriteConfig substPat
168170 SMT. finaliseSolver solver
169- pure $ execResponse req result substitution unsupported
171+ pure $ execResponse req result unsupported
170172 RpcTypes. AddModule RpcTypes. AddModuleRequest {_module, nameAsId = nameAsId'} -> Booster.Log. withContext CtxAddModule $ runExceptT $ do
171173 -- block other request executions while modifying the server state
172174 state <- liftIO $ takeMVar stateVar
@@ -244,20 +246,14 @@ respond stateVar request =
244246 RpcError. CouldNotVerifyPattern $
245247 map patternErrorToRpcError patternErrors
246248 -- term and predicate (pattern)
247- Right (TermAndPredicates pat substitution unsupported) -> do
249+ -- NOTE: the input substitution will have already been applied by internaliseTermOrPredicate
250+ Right (TermAndPredicates pat unsupported) -> do
248251 unless (null unsupported) $ do
249252 withKorePatternContext (KoreJson. KJAnd (externaliseSort $ sortOfPattern pat) unsupported) $ do
250253 logMessage (" ignoring unsupported predicate parts" :: Text )
251- -- apply the given substitution before doing anything else
252- let substPat =
253- Pattern
254- { term = substituteInTerm substitution pat. term
255- , constraints = Set. map (substituteInPredicate substitution) pat. constraints
256- , ceilConditions = pat. ceilConditions
257- }
258- ApplyEquations. evaluatePattern def mLlvmLibrary solver mempty substPat >>= \ case
254+ ApplyEquations. evaluatePattern def mLlvmLibrary solver mempty pat >>= \ case
259255 (Right newPattern, _) -> do
260- let (term, mbPredicate, mbSubstitution) = externalisePattern newPattern substitution
256+ let (term, mbPredicate, mbSubstitution) = externalisePattern newPattern
261257 tSort = externaliseSort (sortOfPattern newPattern)
262258 result = case catMaybes (mbPredicate : mbSubstitution : map Just unsupported) of
263259 [] -> term
@@ -281,23 +277,24 @@ respond stateVar request =
281277 withKorePatternContext (KoreJson. KJAnd (externaliseSort $ SortApp " SortBool" [] ) ps. unsupported) $ do
282278 logMessage (" ignoring unsupported predicate parts" :: Text )
283279 -- apply the given substitution before doing anything else
284- let predicates = map (substituteInPredicate ps. substitution) ps. boolPredicates
280+ let predicates = map (Substitution. substituteInPredicate ps. substitution) ps. boolPredicates
285281 withContext CtxConstraint $
286282 ApplyEquations. simplifyConstraints
287283 def
288284 mLlvmLibrary
289285 solver
290286 mempty
291- predicates
287+ ( predicates <> Substitution. asEquations ps . substitution)
292288 >>= \ case
293- (Right newPreds , _) -> do
289+ (Right simplified , _) -> do
294290 let predicateSort =
295291 fromMaybe (error " not a predicate" ) $
296292 sortOfJson req. state. term
293+ (simplifiedSubstitution, simplifiedPredicates) = extractSubstitution simplified
297294 result =
298- map (externalisePredicate predicateSort) newPreds
295+ map (externalisePredicate predicateSort) ( Set. toList simplifiedPredicates)
299296 <> map (externaliseCeil predicateSort) ps. ceilPredicates
300- <> map (uncurry $ externaliseSubstitution predicateSort) (Map. toList ps . substitution )
297+ <> map (uncurry $ externaliseSubstitution predicateSort) (Map. assocs simplifiedSubstitution )
301298 <> ps. unsupported
302299
303300 pure $ Right (addHeader $ Syntax. KJAnd predicateSort result)
@@ -332,7 +329,7 @@ respond stateVar request =
332329 -- term and predicates were sent. Only work on predicates
333330 (boolPs, suppliedSubst) <-
334331 case things of
335- TermAndPredicates pat substitution unsupported -> do
332+ TermAndPredicates pat unsupported -> do
336333 withContext CtxGetModel $
337334 logMessage' (" ignoring supplied terms and only checking predicates" :: Text )
338335
@@ -341,7 +338,7 @@ respond stateVar request =
341338 logMessage' (" ignoring unsupported predicates" :: Text )
342339 withContext CtxDetail $
343340 logMessage (Text. unwords $ map prettyPattern unsupported)
344- pure (Set. toList pat. constraints, substitution)
341+ pure (Set. toList pat. constraints, pat . substitution)
345342 Predicates ps -> do
346343 unless (null ps. ceilPredicates && null ps. unsupported) $ do
347344 withContext CtxGetModel $ do
@@ -472,21 +469,20 @@ execStateToKoreJson RpcTypes.ExecuteState{term = t, substitution, predicate} =
472469execResponse ::
473470 RpcTypes. ExecuteRequest ->
474471 (Natural , Seq (RewriteTrace () ), RewriteResult Pattern ) ->
475- Map Variable Term ->
476472 [Syntax. KorePattern ] ->
477473 Either ErrorObj (RpcTypes. API 'RpcTypes.Res )
478- execResponse req (d, traces, rr) originalSubstitution unsupported = case rr of
474+ execResponse req (d, traces, rr) unsupported = case rr of
479475 RewriteBranch p nexts ->
480476 Right $
481477 RpcTypes. Execute
482478 RpcTypes. ExecuteResult
483479 { reason = RpcTypes. Branching
484480 , depth
485481 , logs
486- , state = toExecState p originalSubstitution unsupported Nothing
482+ , state = toExecState p unsupported Nothing
487483 , nextStates =
488484 Just $
489- map (\ (_, muid, p') -> toExecState p' originalSubstitution unsupported (Just muid)) $
485+ map (\ (_, muid, p') -> toExecState p' unsupported (Just muid)) $
490486 toList nexts
491487 , rule = Nothing
492488 , unknownPredicate = Nothing
@@ -498,7 +494,7 @@ execResponse req (d, traces, rr) originalSubstitution unsupported = case rr of
498494 { reason = RpcTypes. Stuck
499495 , depth
500496 , logs
501- , state = toExecState p originalSubstitution unsupported Nothing
497+ , state = toExecState p unsupported Nothing
502498 , nextStates = Nothing
503499 , rule = Nothing
504500 , unknownPredicate = Nothing
@@ -510,7 +506,7 @@ execResponse req (d, traces, rr) originalSubstitution unsupported = case rr of
510506 { reason = RpcTypes. Vacuous
511507 , depth
512508 , logs
513- , state = toExecState p originalSubstitution unsupported Nothing
509+ , state = toExecState p unsupported Nothing
514510 , nextStates = Nothing
515511 , rule = Nothing
516512 , unknownPredicate = Nothing
@@ -522,8 +518,8 @@ execResponse req (d, traces, rr) originalSubstitution unsupported = case rr of
522518 { reason = RpcTypes. CutPointRule
523519 , depth
524520 , logs
525- , state = toExecState p originalSubstitution unsupported Nothing
526- , nextStates = Just [toExecState next originalSubstitution unsupported Nothing ]
521+ , state = toExecState p unsupported Nothing
522+ , nextStates = Just [toExecState next unsupported Nothing ]
527523 , rule = Just lbl
528524 , unknownPredicate = Nothing
529525 }
@@ -534,7 +530,7 @@ execResponse req (d, traces, rr) originalSubstitution unsupported = case rr of
534530 { reason = RpcTypes. TerminalRule
535531 , depth
536532 , logs
537- , state = toExecState p originalSubstitution unsupported Nothing
533+ , state = toExecState p unsupported Nothing
538534 , nextStates = Nothing
539535 , rule = Just lbl
540536 , unknownPredicate = Nothing
@@ -546,7 +542,7 @@ execResponse req (d, traces, rr) originalSubstitution unsupported = case rr of
546542 { reason = RpcTypes. DepthBound
547543 , depth
548544 , logs
549- , state = toExecState p originalSubstitution unsupported Nothing
545+ , state = toExecState p unsupported Nothing
550546 , nextStates = Nothing
551547 , rule = Nothing
552548 , unknownPredicate = Nothing
@@ -563,7 +559,7 @@ execResponse req (d, traces, rr) originalSubstitution unsupported = case rr of
563559 (logSuccessfulRewrites, logFailedRewrites)
564560 (RewriteStepFailed failure)
565561 in logs <|> abortRewriteLog
566- , state = toExecState p originalSubstitution unsupported Nothing
562+ , state = toExecState p unsupported Nothing
567563 , nextStates = Nothing
568564 , rule = Nothing
569565 , unknownPredicate = Nothing
@@ -586,8 +582,8 @@ execResponse req (d, traces, rr) originalSubstitution unsupported = case rr of
586582 xs@ (_ : _) -> Just xs
587583
588584toExecState ::
589- Pattern -> Map Variable Term -> [Syntax. KorePattern ] -> Maybe UniqueId -> RpcTypes. ExecuteState
590- toExecState pat sub unsupported muid =
585+ Pattern -> [Syntax. KorePattern ] -> Maybe UniqueId -> RpcTypes. ExecuteState
586+ toExecState pat unsupported muid =
591587 RpcTypes. ExecuteState
592588 { term = addHeader t
593589 , predicate = addHeader <$> addUnsupported p
@@ -597,7 +593,7 @@ toExecState pat sub unsupported muid =
597593 , ruleId = getUniqueId <$> muid
598594 }
599595 where
600- (t, p, s) = externalisePattern pat sub
596+ (t, p, s) = externalisePattern pat
601597 termSort = externaliseSort $ sortOfPattern pat
602598 allUnsupported = Syntax. KJAnd termSort unsupported
603599 addUnsupported
0 commit comments