From 5e41515d75f198cc378a2a71cd02cd1c014ae5ff Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 20 Jul 2016 17:36:04 -0700 Subject: [PATCH 01/70] Extend two term utilities. The CHECK-USER-TERM and CHECK-USER-LAMBDA-EXPR term utilities now return, if successful, not only the translated term or lambda expression, but also the output stobjs of the term or (body of the) lambda expression. Tests have been added for this new feature. Additional tests for malformed lambda expressions have also been added. --- books/kestrel/system/terms-tests.lisp | 128 +++++++++++++++++++------- books/kestrel/system/terms.lisp | 80 +++++++++++----- 2 files changed, 152 insertions(+), 56 deletions(-) diff --git a/books/kestrel/system/terms-tests.lisp b/books/kestrel/system/terms-tests.lisp index a16261f6ecc..afbf02de877 100644 --- a/books/kestrel/system/terms-tests.lisp +++ b/books/kestrel/system/terms-tests.lisp @@ -161,59 +161,121 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (equal (check-user-term 3 (w state)) - ''3)) +(assert-event (equal (mv-list 2 (check-user-term 3 (w state))) + '('3 (nil)))) -(assert-event (equal (check-user-term 'x (w state)) - 'x)) +(assert-event (equal (mv-list 2 (check-user-term 'x (w state))) + '(x (nil)))) -(assert-event (equal (check-user-term '(len x) (w state)) - '(len x))) +(assert-event (equal (mv-list 2 (check-user-term '(len x) (w state))) + '((len x) (nil)))) + +(assert-event (equal (mv-list 2 (check-user-term '(mv x y z) (w state))) + '((cons x (cons y (cons z 'nil))) (nil nil nil)))) + +(assert-event (equal (mv-list 2 (check-user-term 'state (w state))) + '(state (state)))) + +(assert-event (equal (mv-list 2 (check-user-term '(mv state 1) (w state))) + '((cons state (cons '1 'nil)) (state nil)))) + +(must-succeed* + (defstobj s) + (assert-event (equal (mv-list 2 (check-user-term '(mv s 0 state) (w state))) + '((cons s (cons '0 (cons state 'nil))) (s nil state))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (check-user-term '(+ x y) (w state)) - '(binary-+ x y)))) + (value (equal (mv-list 2 (check-user-term '(+ x y) (w state))) + '((binary-+ x y) (nil))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (check-user-term '(+ (len x) 55) (w state)) - '(binary-+ (len x) '55)))) + (value (equal (mv-list 2 (check-user-term '(+ (len x) 55) (w state))) + '((binary-+ (len x) '55) (nil))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (check-user-term '(let ((x 4)) (+ x (len y))) (w state)) - '((lambda (x y) (binary-+ x (len y))) - '4 - y)))) + (value + (equal (mv-list 2 (check-user-term '(let ((x 4)) (+ x (len y))) (w state))) + '(((lambda (x y) (binary-+ x (len y))) '4 y) (nil))))) -(assert-event (msgp (check-user-term '(f x) (w state)))) +(assert-event (msgp (nth 0 (mv-list 2 (check-user-term '(f x) (w state)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (equal (check-user-lambda-expr '(lambda (x) 3) (w state)) - '(lambda (x) '3))) +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + "(lambda (x) x)" (w state)))))) + +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + '(lambda (x) x . more) (w state)))))) + +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + '(lambda (x) x y) (w state)))))) -(assert-event (equal (check-user-lambda-expr '(lambda (x) x) (w state)) - '(lambda (x) x))) +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + '(lambda (x)) (w state)))))) -(assert-event (equal (check-user-lambda-expr '(lambda (y) (len x)) (w state)) - '(lambda (y) (len x)))) +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + '(lambdaa (x) x) (w state)))))) + +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + '(lambda "x" x) (w state)))))) + +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + '(lambda (x x) x) (w state)))))) + +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + '(lambda (x "y") x) (w state)))))) + +(assert-event + (equal (mv-list 2 (check-user-lambda-expr '(lambda (x) 3) (w state))) + '((lambda (x) '3) (nil)))) + +(assert-event + (equal (mv-list 2 (check-user-lambda-expr '(lambda (x) x) (w state))) + '((lambda (x) x) (nil)))) + +(assert-event + (equal (mv-list 2 (check-user-lambda-expr '(lambda (y) (len x)) (w state))) + '((lambda (y) (len x)) (nil)))) + +(assert-event + (equal (mv-list 2 (check-user-lambda-expr + '(lambda (x y) (mv x y z)) (w state))) + '((lambda (x y) (cons x (cons y (cons z 'nil)))) (nil nil nil)))) + +(assert-event + (equal (mv-list 2 (check-user-lambda-expr '(lambda (state) state) (w state))) + '((lambda (state) state) (state)))) + +(assert-event + (equal (mv-list 2 (check-user-lambda-expr + '(lambda (state) (mv state 1)) (w state))) + '((lambda (state) (cons state (cons '1 'nil))) (state nil)))) + +(must-succeed* + (defstobj s) + (assert-event (equal (mv-list 2 (check-user-lambda-expr + '(lambda (state s) (mv s 0 state)) (w state))) + '((lambda (state s) (cons s (cons '0 (cons state 'nil)))) + (s nil state))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (check-user-lambda-expr '(lambda (x y) (+ x y)) (w state)) - '(lambda (x y) (binary-+ x y))))) + (value (equal (mv-list 2 (check-user-lambda-expr + '(lambda (x y) (+ x y)) (w state))) + '((lambda (x y) (binary-+ x y)) (nil))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (check-user-lambda-expr '(lambda (z) (+ (len x) 55)) (w state)) - '(lambda (z) (binary-+ (len x) '55))))) + (value (equal (mv-list 2 (check-user-lambda-expr + '(lambda (z) (+ (len x) 55)) (w state))) + '((lambda (z) (binary-+ (len x) '55)) (nil))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (check-user-lambda-expr '(lambda (u) (let ((x 4)) (+ x (len y)))) - (w state)) - '(lambda (u) - ((lambda (x y) (binary-+ x (len y))) - '4 - y))))) - -(assert-event (msgp (check-user-lambda-expr '(lambda (x) (f x)) (w state)))) + (value (equal (mv-list 2 (check-user-lambda-expr + '(lambda (u) (let ((x 4)) (+ x (len y)))) (w state))) + '((lambda (u) ((lambda (x y) (binary-+ x (len y))) '4 y)) + (nil))))) + +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr + '(lambda (x) (f x)) (w state)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/system/terms.lisp b/books/kestrel/system/terms.lisp index 33ee20d010d..dee273a8115 100644 --- a/books/kestrel/system/terms.lisp +++ b/books/kestrel/system/terms.lisp @@ -258,24 +258,38 @@ (second x)))) (define check-user-term (x (wrld plist-worldp)) - :returns (term/message (or (pseudo-termp term/message) - (msgp term/message))) + :returns (mv (term/message (or (pseudo-termp term/message) + (msgp term/message))) + (stobjs-out symbol-listp)) :prepwork ((program)) :short "Check whether @('x') is an untranslated term that is valid for evaluation." :long "

- An untranslated term is a term as entered by the user. + An untranslated @(see term) is a term as entered by the user. This function checks @('x') by attempting to translate it. - If the translation succeeds, the translated term is returned. - Otherwise, a structured error message is returned (printable with @('~@')). + If the translation succeeds, the translated term is returned, + along with the output @(see stobj)s of the term (see below for details). + Otherwise, a structured error message is returned (printable with @('~@')), + along with @('nil') as output stobjs. These two possible outcomes can be distinguished by the fact that the former is a pseudo-term while the latter is not.

+ The ‘output stobjs’ of a term are the analogous + of the @(tsee stobjs-out) property of a function, + namely a list of symbols that is like a “mask’ for the result. + A @('nil') in the list means that + the corresponding result is a non-stobj value, + while the name of a stobj in the list means that + the corresponding result is the named stobj. + The list is a singleton, unless the term returns + multiple values. +

+

The @(':stobjs-out') and @('((:stobjs-out . :stobjs-out))') arguments - passed to @('translate1-cmp') + passed to @('translate1-cmp') as bindings mean that the term is checked to be valid for evaluation. This is stricter than checking the term to be valid for use in a theorem, and weaker than checking the term to be valid @@ -288,7 +302,12 @@ should coincide.

- This function does not terminate + If @('translate1-cmp') is successful, + it should return updated bindings that associate @(':stobjs-out') + to the output stobjs of the term. +

+

+ The @(tsee check-user-term) function does not terminate if the translation expands an ill-behaved macro that does not terminate.

" (mv-let (ctx term/message bindings) @@ -299,19 +318,23 @@ __function__ wrld (default-state-vars nil)) - (declare (ignore ctx bindings)) - term/message)) + (declare (ignore ctx)) + (if (pseudo-termp term/message) + (mv term/message + (cdr (assoc :stobjs-out bindings))) + (mv term/message nil)))) (define check-user-lambda-expr (x (wrld plist-worldp)) - :returns (lambd/message (or (pseudo-lambda-expr-p lambd/message) - (msgp lambd/message))) + :returns (mv (lambd/message (or (pseudo-lambda-expr-p lambd/message) + (msgp lambd/message))) + (stobjs-out symbol-listp)) :prepwork ((program)) :short "Check whether @('x') is an untranslated lambda expression that is valid for evaluation." :long "

- An untranslated lambda expression is + An untranslated @(see lambda) expression is a lambda expression as entered by the user. This function checks whether @('x')is a @('nil')-terminated list of exactly three elements, @@ -320,25 +343,33 @@ and whose third element is an untranslated term that is valid for evaluation.

- If the check succeeds, the translated lambda expression is returned. + If the check succeeds, the translated lambda expression is returned, + along with the output @(see stobj)s of the body of the lambda expression + (see @(tsee check-user-term) for an explanation + of the output stobjs of a term). Otherwise, a possibly structured error message is returned - (printable with @('~@')). + (printable with @('~@')), + along with @('nil') as output stobjs.

- This function does not terminate + The @(tsee check-user-lambda-expr) function does not terminate if @(tsee check-user-term) does not terminate.

" (b* (((unless (true-listp x)) - `("~x0 is not a NIL-terminated list." (#\0 . ,x))) + (mv `("~x0 is not a NIL-terminated list." (#\0 . ,x)) + nil)) ((unless (eql (len x) 3)) - `("~x0 does not consist of exactly three elements." (#\0 . ,x))) + (mv `("~x0 does not consist of exactly three elements." (#\0 . ,x)) + nil)) ((unless (eq (first x) 'lambda)) - `("~x0 does not start with LAMBDA." (#\0 . ,x))) + (mv `("~x0 does not start with LAMBDA." (#\0 . ,x)) + nil)) ((unless (arglistp (second x))) - `("~x0 does not have valid formal parameters." (#\0 . ,x))) - (term/message (check-user-term (third x) wrld)) - ((when (msgp term/message)) term/message)) - `(lambda ,(second x) ,term/message))) + (mv `("~x0 does not have valid formal parameters." (#\0 . ,x)) + nil)) + ((mv term/message stobjs-out) (check-user-term (third x) wrld)) + ((when (msgp term/message)) (mv term/message nil))) + (mv `(lambda ,(second x) ,term/message) stobjs-out))) (define trans-macro ((mac (macro-namep mac wrld)) (wrld plist-worldp)) :returns (term pseudo-termp) @@ -366,7 +397,10 @@ calls with argument that are not the required formal arguments may yield different terms.

" - (check-user-term (cons mac (macro-required-args mac wrld)) wrld)) + (mv-let (term stobjs-out) + (check-user-term (cons mac (macro-required-args mac wrld)) wrld) + (declare (ignore stobjs-out)) + term)) (define term-guard-obligation ((term pseudo-termp) state) :returns (obligation pseudo-termp) From 539d0ed59287296dc62f0489473ab7b15b5524a9 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 20 Jul 2016 18:27:57 -0700 Subject: [PATCH 02/70] Minor fixes to documentation. --- books/kestrel/system/terms.lisp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/books/kestrel/system/terms.lisp b/books/kestrel/system/terms.lisp index dee273a8115..c3a4a41e829 100644 --- a/books/kestrel/system/terms.lisp +++ b/books/kestrel/system/terms.lisp @@ -273,13 +273,13 @@ Otherwise, a structured error message is returned (printable with @('~@')), along with @('nil') as output stobjs. These two possible outcomes can be distinguished by the fact that - the former is a pseudo-term - while the latter is not. + the former yields a pseudo-term + while the latter does not.

The ‘output stobjs’ of a term are the analogous of the @(tsee stobjs-out) property of a function, - namely a list of symbols that is like a “mask’ for the result. + namely a list of symbols that is like a “mask” for the result. A @('nil') in the list means that the corresponding result is a non-stobj value, while the name of a stobj in the list means that @@ -303,7 +303,7 @@

If @('translate1-cmp') is successful, - it should return updated bindings that associate @(':stobjs-out') + it returns updated bindings that associate @(':stobjs-out') to the output stobjs of the term.

From ea7137ee5766cd03eab5786bfe2a25822fb7aee2 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 20 Jul 2016 23:02:16 -0700 Subject: [PATCH 03/70] Improve applicability condition utilities. When an applicability condition fails to prove, instead of stopping execution with a hard error, we return a structured error message (a MSGP). This provides more flexibility, e.g. to programmatically attempt several applicability conditions, some of which may fail. --- .../applicability-conditions-tests.lisp | 130 ++++++++---------- .../system/applicability-conditions.lisp | 70 +++++----- 2 files changed, 93 insertions(+), 107 deletions(-) diff --git a/books/kestrel/system/applicability-conditions-tests.lisp b/books/kestrel/system/applicability-conditions-tests.lisp index 3edf1dc0d22..59e1466d591 100644 --- a/books/kestrel/system/applicability-conditions-tests.lisp +++ b/books/kestrel/system/applicability-conditions-tests.lisp @@ -39,128 +39,121 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(must-fail (make-event (applicability-condition-fail 'context "error"))) - -(must-fail (make-event (applicability-condition-fail - 'context "error ~x0 and ~x1" #\a "bb"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(must-eval-to-t + (mv-let (t/msg state) + (prove-applicability-condition (make-applicability-condition + :name 'false + :formula '(equal x y) + :hints nil) + nil ; verbose + state) + (value (msgp t/msg)))) -(must-fail-local - (make-event (prove-applicability-condition (make-applicability-condition - :name 'false - :formula '(equal x y) - :hints nil) - nil ; verbose - 'context - state))) - -(must-fail-local - (make-event (prove-applicability-condition (make-applicability-condition - :name 'false - :formula '(equal x y) - :hints nil) - t ; verbose - 'context - state))) +(must-eval-to-t + (mv-let (t/msg state) + (prove-applicability-condition (make-applicability-condition + :name 'false + :formula '(equal x y) + :hints nil) + t ; verbose + state) + (value (msgp t/msg)))) (must-succeed* (defund f (x) x) - (must-fail-local - (make-event (prove-applicability-condition (make-applicability-condition - :name 'need-hints - :formula '(equal (f x) x) - :hints nil) - nil ; verbose - 'context - state)))) + (must-eval-to-t + (mv-let (t/msg state) + (prove-applicability-condition (make-applicability-condition + :name 'need-hints + :formula '(equal (f x) x) + :hints nil) + nil ; verbose + state) + (value (msgp t/msg))))) (must-succeed* (defund f (x) x) - (must-fail-local - (make-event (prove-applicability-condition (make-applicability-condition - :name 'need-hints - :formula '(equal (f x) x) - :hints nil) - t ; verbose - 'context - state)))) + (must-eval-to-t + (mv-let (t/msg state) + (prove-applicability-condition (make-applicability-condition + :name 'need-hints + :formula '(equal (f x) x) + :hints nil) + t ; verbose + state) + (value (msgp t/msg))))) (must-eval-to-t - (mv-let (result state) + (mv-let (t/msg state) (prove-applicability-condition (make-applicability-condition :name 'true :formula '(equal x x) :hints nil) nil ; verbose - 'context state) - (value result))) + (value (eq t/msg t)))) (must-eval-to-t - (mv-let (result state) + (mv-let (t/msg state) (prove-applicability-condition (make-applicability-condition :name 'true :formula '(equal x x) :hints nil) t ; verbose - 'context state) - (value result))) + (value (eq t/msg t)))) (must-succeed* (defund f (x) x) (must-eval-to-t - (mv-let (result state) + (mv-let (t/msg state) (prove-applicability-condition (make-applicability-condition :name 'true :formula '(equal (f x) x) :hints '(("Goal" :in-theory (enable f)))) nil ; verbose - 'context state) - (value result)))) + (value (eq t/msg t))))) (must-succeed* (defund f (x) x) (must-eval-to-t - (mv-let (result state) + (mv-let (t/msg state) (prove-applicability-condition (make-applicability-condition :name 'true :formula '(equal (f x) x) :hints '(("Goal" :in-theory (enable f)))) t ; verbose - 'context state) - (value result)))) + (value (eq t/msg t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(must-fail-local - (make-event (prove-applicability-conditions (list (make-applicability-condition - :name 'true - :formula '(equal x x) - :hints nil) - (make-applicability-condition - :name 'false - :formula '(equal x y) - :hints nil)) - nil ; verbose - 'context - state))) +(must-eval-to-t + (mv-let (t/msg state) + (prove-applicability-conditions (list (make-applicability-condition + :name 'true + :formula '(equal x x) + :hints nil) + (make-applicability-condition + :name 'false + :formula '(equal x y) + :hints nil)) + nil ; verbose + state) + (value (msgp t/msg)))) (must-eval-to-t - (mv-let (result state) + (mv-let (t/msg state) (prove-applicability-conditions nil nil ; verbose - 'context state) - (value result))) + (value (eq t/msg t)))) (must-succeed* (defund f (x) x) (must-eval-to-t - (mv-let (result state) + (mv-let (t/msg state) (prove-applicability-conditions (list (make-applicability-condition :name 'true :formula '(equal x x) @@ -171,9 +164,8 @@ :hints '(("Goal" :in-theory (enable f))))) nil ; verbose - 'context state) - (value result)))) + (value (eq t/msg t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/system/applicability-conditions.lisp b/books/kestrel/system/applicability-conditions.lisp index bab49b59b3c..bf4fcdb80bc 100644 --- a/books/kestrel/system/applicability-conditions.lisp +++ b/books/kestrel/system/applicability-conditions.lisp @@ -52,21 +52,11 @@ :true-listp t :elementp-of-nil nil) -(defsection applicability-condition-fail - :short - "Stop with an error message, - due to a failure related to applicability conditions." - :long "@(def applicability-condition-fail)" - (defmacro applicability-condition-fail (context message &rest arguments) - (declare (xargs :guard (and (true-listp arguments) - (<= (len arguments) 10)))) - `(er hard? ,context ,message ,@arguments))) - (define prove-applicability-condition ((app-cond applicability-condition-p) (verbose booleanp) - (ctx "Context for errors.") state) - :returns (mv (yes/no booleanp) + :returns (mv (t/msg (or (eq t/msg t) + (msgp t/msg))) state) :prepwork ((program)) :short @@ -75,13 +65,13 @@ "

If successful, return @('t'). If unsuccessful or if an error occurs during the proof attempt, - stop with an error message. + return a structured error message (printable with @('~@')).

If the @('verbose') argument is @('t'), also print a progress message to indicate that the proof of the applicability condition is being attempted, - and then that it has been proved. + and then to indicate the outcome of the attempt.

Parentheses are printed around the progress message @@ -92,30 +82,32 @@ (hints (applicability-condition->hints app-cond)) ((run-when verbose) (cw "(Proving applicability condition ~x0:~%~x1~|" name formula)) - ((mv erp yes/no state) (prove$ formula :hints hints)) - ((when erp) - (applicability-condition-fail - ctx - "Prover error ~x0 when attempting to prove ~ - applicability condition ~x1:~%~x2~|." - erp name formula) - (mv nil state)) - ((unless yes/no) - (applicability-condition-fail - ctx - "The applicability condition ~x0 fails:~%~x1~|" - name formula) - (mv nil state)) - ((run-when verbose) - (cw "Done.)~%~%"))) - (mv t state))) + ((mv erp yes/no state) (prove$ formula :hints hints))) + (cond (erp (b* (((run-when verbose) + (cw "Prover error.)~%~%"))) + (mv `("Prover error ~x0 ~ + when attempting to prove ~ + the applicability condition ~x1:~%~x2~|" + (#\0 . ,erp) + (#\1 . ,name) + (#\2 . ,formula)) + state))) + (yes/no (b* (((run-when verbose) + (cw "Done.)~%~%"))) + (mv t state))) + (t (b* (((run-when verbose) + (cw "Failed.)~%~%"))) + (mv `("The applicability condition ~x0 fails:~%~x1~|" + (#\0 . ,name) + (#\1 . ,formula)) + state)))))) (define prove-applicability-conditions ((app-conds applicability-condition-listp) (verbose booleanp) - (ctx "Context for errors.") state) - :returns (mv (yes/no booleanp) + :returns (mv (t/msg (or (eq t/msg t) + (msgp t/msg))) state) :prepwork ((program)) :short "Try to prove a list of applicability conditions, one after the other." @@ -123,7 +115,7 @@ "

If successful, return @('t'). If unsuccessful or if an error occurs during a proof attempt, - stop with an error message. + return a structured error message (printable with @('~@')).

If the @('verbose') argument is @('t'), @@ -131,10 +123,12 @@

" (cond ((endp app-conds) (mv t state)) (t (b* ((app-cond (car app-conds)) - ((mv & state) - (prove-applicability-condition app-cond verbose ctx state))) - (prove-applicability-conditions - (cdr app-conds) verbose ctx state))))) + ((mv t/msg state) + (prove-applicability-condition app-cond verbose state))) + (if (eq t/msg t) + (prove-applicability-conditions + (cdr app-conds) verbose state) + (mv t/msg state)))))) (define applicability-condition-event ((app-cond applicability-condition-p) From a7dc7f6e20226ee84023641463bee1265fc86257 Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Thu, 21 Jul 2016 08:57:09 -0500 Subject: [PATCH 04/70] Tweaked :doc must-succeed. Added :doc proof-checker to point to proof-builder. Deleted obsolete :doc with-brr-ens. Thanks to Eric Smith for pointing out that (must-succeed (set-gag-mode 42)) isn't a sensible example, since set-gag-mode doesn't return an error triple. --- books/misc/eval.lisp | 7 ++-- books/system/doc/acl2-doc.lisp | 43 +++++------------------- doc.lisp | 60 ++++++++-------------------------- 3 files changed, 24 insertions(+), 86 deletions(-) diff --git a/books/misc/eval.lisp b/books/misc/eval.lisp index 8c8ad7b4327..2c81943b81b 100644 --- a/books/misc/eval.lisp +++ b/books/misc/eval.lisp @@ -84,7 +84,7 @@ theories, etc. to your books. Basic examples:

(defthm bad-theorem nil)) ;; (unless we can prove NIL!) (must-succeed ;; causes an error - (set-gag-mode 42)) ;; (because 42 isn't a gag mode) + (set-cbd 17)) ;; (because 17 isn't a string) })

See also @(see must-fail).

@@ -98,9 +98,8 @@ theories, etc. to your books. Basic examples:

) }) -

The @('form') should typically be a form that returns an @(see -error-triple), which is true for most top-level ACL2 events and other high -level commands.

+

The @('form') should evaluate to an @(see error-triple), which is true for +most top-level ACL2 events and other high level commands.

The @('form') is submitted in a @(see make-event), which has a number of consequences. Most importantly, when @('form') is an event like a @(see diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index f4a4ec145c1..1e62db0d87d 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -81820,6 +81820,14 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

") commands that can be given inside the interactive @(see proof-builder) loop that is entered using @(tsee verify).

") +(defxdoc proof-checker + :parents (proof-builder) + :short "Old name for @(see proof-builder)" + :long "

See @(see proof-builder). Historically, this tool was misnamed the + ``proof-checker'', but since the tool is used for building and exploring (what + could be called) proofs rather than for checking them, its name was changed to + ``proof-builder'' in 2016.

") + (defxdoc proof-of-well-foundedness :parents (ordinals) :short "A proof that @(tsee o<) is well-founded on @(tsee o-p)s" @@ -109251,41 +109259,6 @@ introduction-to-the-tau-system) for more information about Tau. out of the wormhole and to do @(':')@(tsee brr) @('nil') in the external state when the next opportunity arises.

") -(defxdoc with-brr-ens - :parents (break-rewrite brr-commands) - :short "Inside @(see break-rewrite), evaluate with respect to the theory - currently installed in the prover" - :long "@({ - Example Forms: - - (with-brr-ens (pe 'nth)) - (with-brr-ens (pl 'nth)) - (with-brr-ens (disabledp 'nth)) - - General Form: - - (with-brr-ens form) - }) - -

where @('form') is any form that evaluates either to a single value, - @('val'), or to an @(see error-triple), @('(mv erp val state)'). The return - value — which might be irrelevant if the form is evaluated for - side-effect, such as a call of a @(see history) command such as @(tsee pe) or - @(tsee pl) — is @('(mv nil val state)') in the first case and also, if - @('erp') is @('nil'), in the second case.

- -

At the @(':')@(see brr) prompt, evaluation of utilities such as - @(':')@(tsee pe) display whether or not a rule is globally @(see disable)d. - However, inside the @(see break-rewrite) loop one might wish to know instead - whether or not the rule is disabled at the current stage of the proof attempt - that is underway. The wrapper @('with-brr-ens') binds the so-called ``global - enabled structure'' to the corresponding structure that is currently installed - during the proof in progress, which will thus be used for @(see history) - queries such as @(tsee pe). In order to take advantage of this feature, you - must state the query as an ordinary expression, not as a keyword command (see - @(see keyword-commands)), for example as @('(with-brr-ens (pe 'nth))'), not as - @('(with-brr-ens :pe 'nth)').

") - (defxdoc with-fast-alist :parents (fast-alists acl2-built-ins) :short "@('(with-fast-alist name form)') causes @('name') to be a fast alist diff --git a/doc.lisp b/doc.lisp index aba74ca2d2e..cd51b0cfa62 100644 --- a/doc.lisp +++ b/doc.lisp @@ -12573,11 +12573,7 @@ Subtopics To stop monitoring a rule name [Why-brr] - An explanation of why ACL2 has an explicit [brr] mode - - [With-brr-ens] - Inside [break-rewrite], evaluate with respect to the theory - currently installed in the prover") + An explanation of why ACL2 has an explicit [brr] mode") (BREAKS (ERRORS) "Common Lisp breaks @@ -12853,14 +12849,7 @@ Subtopics does not apply, but instead, :poly-list shows the result of applying the linear lemma as a list of polynomials, implicitly conjoined. The leading term of each polynomial is enclosed in an - extra set of parentheses. - - -Subtopics - - [With-brr-ens] - Inside [break-rewrite], evaluate with respect to the theory - currently installed in the prover") + extra set of parentheses.") (BRR@ (BREAK-REWRITE) "To access context sensitive information within [break-rewrite] @@ -82202,6 +82191,9 @@ Subtopics [Proof-builder-commands] List of commands for the interactive proof-builder + [Proof-checker] + Old name for [proof-builder] + [Retrieve] Re-enter a (specified) [proof-builder] state @@ -82577,6 +82569,14 @@ Subtopics [ACL2-pc::x-dumb] (atomic macro) expand function call at the current subterm, without simplifying") + (PROOF-CHECKER + (PROOF-BUILDER) + "Old name for [proof-builder] + + See [proof-builder]. Historically, this tool was misnamed the + ``proof-checker'', but since the tool is used for building and + exploring (what could be called) proofs rather than for checking + them, its name was changed to ``proof-builder'' in 2016.") (PROOF-OF-WELL-FOUNDEDNESS (ORDINALS) "A proof that [o<] is well-founded on [o-p]s @@ -110132,40 +110132,6 @@ Subtopics user who has finally unmonitored all runes is therefore strongly advised to carry this information out of the wormhole and to do :[brr] nil in the external state when the next opportunity arises.") - (WITH-BRR-ENS - (BREAK-REWRITE BRR-COMMANDS) - "Inside [break-rewrite], evaluate with respect to the theory currently - installed in the prover - - Example Forms: - - (with-brr-ens (pe 'nth)) - (with-brr-ens (pl 'nth)) - (with-brr-ens (disabledp 'nth)) - - General Form: - - (with-brr-ens form) - - where form is any form that evaluates either to a single value, val, - or to an [error-triple], (mv erp val state). The return value --- - which might be irrelevant if the form is evaluated for side-effect, - such as a call of a [history] command such as [pe] or [pl] --- is - (mv nil val state) in the first case and also, if erp is nil, in - the second case. - - At the :[brr] prompt, evaluation of utilities such as :[pe] display - whether or not a rule is globally [disable]d. However, inside the - [break-rewrite] loop one might wish to know instead whether or not - the rule is disabled at the current stage of the proof attempt that - is underway. The wrapper with-brr-ens binds the so-called ``global - enabled structure'' to the corresponding structure that is - currently installed during the proof in progress, which will thus - be used for [history] queries such as [pe]. In order to take - advantage of this feature, you must state the query as an ordinary - expression, not as a keyword command (see [keyword-commands]), for - example as (with-brr-ens (pe 'nth)), not as (with-brr-ens :pe - 'nth).") (WITH-FAST-ALIST (FAST-ALISTS ACL2-BUILT-INS) "(with-fast-alist name form) causes name to be a fast alist for the From 8112a686337c6158cf8f8768b49fa118b09d11bb Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Thu, 21 Jul 2016 17:12:40 -0700 Subject: [PATCH 05/70] Add world query utility. NUMBER-OF-RESULTS returns the number of results of a function -- usually 1, unless the function uses MV (directly or by calling another function that does). The number of results of a function is the length of its STOBJS-OUT property. --- books/kestrel/system/world-queries-tests.lisp | 18 +++++++++++++++++ books/kestrel/system/world-queries.lisp | 20 +++++++++++++++++++ 2 files changed, 38 insertions(+) diff --git a/books/kestrel/system/world-queries-tests.lisp b/books/kestrel/system/world-queries-tests.lisp index f5f53012504..c37b9d8ba3c 100644 --- a/books/kestrel/system/world-queries-tests.lisp +++ b/books/kestrel/system/world-queries-tests.lisp @@ -183,6 +183,24 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(assert-event (eql (number-of-results 'cons (w state)) + 1)) + +(assert-event (eql (number-of-results 'len (w state)) + 1)) + +(must-succeed* + (defun f (x) (mv x (list x))) + (assert-event (eql (number-of-results 'f (w state)) + 2))) + +(must-succeed* + (defun f (x) (mv x (list x) (list x x))) + (assert-event (eql (number-of-results 'f (w state)) + 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (assert-event (no-stobjs-p 'cons (w state))) (assert-event (no-stobjs-p 'len (w state))) diff --git a/books/kestrel/system/world-queries.lisp b/books/kestrel/system/world-queries.lisp index 69a7d1e1eee..eb2f1c46bb6 100644 --- a/books/kestrel/system/world-queries.lisp +++ b/books/kestrel/system/world-queries.lisp @@ -150,6 +150,26 @@ (raise "The body ~x0 of the non-executable function ~x1 ~ does not have the expected wrapper." body fn)))) +(define number-of-results ((fn (function-namep fn wrld)) + (wrld plist-worldp)) + :guard (not (member-eq fn *stobjs-out-invalid*)) + ;; :returns (n posp) + :short "Number of values returned by a function." + :long + "

+ This is 1, unless the function uses @(tsee mv) + (directly, or indirectly by calling another function that does) + to return multiple values. +

+

+ The number of results of the function + is the length of its output @(see stobj) list. + But the function must not be in @('*stobjs-out-invalid*'), + because in that case the number of its results depends on how it is called. +

" + (len (stobjs-out fn wrld)) + :guard-hints (("Goal" :in-theory (enable function-namep)))) + (define no-stobjs-p ((fn (function-namep fn wrld)) (wrld plist-worldp)) :guard (not (member-eq fn *stobjs-out-invalid*)) :returns (yes/no booleanp) From f5b999c07e6a2d02868d9f3f84f8fb613927bb9e Mon Sep 17 00:00:00 2001 From: Shilpi Goel Date: Thu, 21 Jul 2016 19:18:59 -0500 Subject: [PATCH 06/70] x86isa: Removed normalizing theorems about rm*/wm* functions (in the system-level mode). Now, rm*/wm* functions look like the following: (mbe :logic (rb/wb ...) :exec (if (programmer-level-mode x86) (rvm* ... x86) (b* (((mv flg p-addrs x86) (las-to-pas ... x86)) (bytes (read/write-from-physical-memory p-addrs x86))) (mv flg bytes x86)))) Previously, these functions looked like: (if (programmer-level-mode x86) (mbe :logic (rb/wb ...) :exec (rvm* ... x86)) (b* (((mv flg p-addrs x86) (las-to-pas ... x86)) (bytes (read/write-from-physical-memory p-addrs x86))) (mv flg bytes x86))) and there were normalizing theorems that wrote rm*/wm* to rb/wb in the system-level mode. Some application-level proofs are still broken. --- .../x86isa/machine/guard-helpers.lisp | 156 +- .../x86isa/machine/x86-environment.lisp | 30 +- .../x86isa/machine/x86-top-level-memory.lisp | 1102 +-- .../factorial/fact-inductive-assertions.lisp | 67 +- .../factorial/fact-wormhole-abstraction.lisp | 58 +- .../utilities/general-memory-utils.lisp | 166 +- .../programmer-level-memory-utils.lisp | 61 +- .../common-system-level-utils.lisp | 144 +- .../system-level-mode/gl-lemmas.lisp | 35 - .../physical-memory-utils.lisp | 3 +- .../proofs/wordCount/{wc.acl2 => cert.acl2} | 0 .../projects/x86isa/proofs/wordCount/wc.lisp | 118 +- .../zeroCopy/marking-mode/zeroCopy-init.lisp | 2 +- .../zeroCopy/marking-mode/zeroCopy.lisp | 7602 +++++++++-------- .../zeroCopy/non-marking-mode/zeroCopy.lisp | 33 +- 15 files changed, 4949 insertions(+), 4628 deletions(-) rename books/projects/x86isa/proofs/wordCount/{wc.acl2 => cert.acl2} (100%) diff --git a/books/projects/x86isa/machine/guard-helpers.lisp b/books/projects/x86isa/machine/guard-helpers.lisp index f1bf3a61ae2..88c86ad17e9 100644 --- a/books/projects/x86isa/machine/guard-helpers.lisp +++ b/books/projects/x86isa/machine/guard-helpers.lisp @@ -13,6 +13,144 @@ ;; ====================================================================== +;; Various lemmas for the guard proofs of rm* functions + +(def-gl-export rm16-guard-proof-helper + :hyp (and (n08p a) + (n08p b)) + :concl (< (logior a (ash b 8)) *2^16*) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 8) (:nat b 8))) + :rule-classes :linear) + +(def-gl-export rb-and-rvm32-helper + :hyp (and (n08p a) + (n08p b) + (n16p c)) + :concl (equal (logior a (ash b 8) (ash c 16)) + (logior a (ash (logior b (ash c 8)) 8))) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 8) (:nat b 8)) (:nat c 16)) + :rule-classes :linear) + +(def-gl-export rm32-guard-proof-helper + :hyp (and (n08p a) + (n08p b) + (n08p c) + (n08p d)) + :concl (< + (logior a + (ash (logior b + (ash (logior c (ash d 8)) 8)) + 8)) + *2^32*) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8))) + :rule-classes :linear) + +(def-gl-export rb-and-rvm64-helper + :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) + (n08p e) (n08p f) (n08p g) (n08p h)) + :concl (equal + (logior a (ash b 8) + (ash (logior c (ash d 8)) 16) + (ash (logior e (ash f 8) (ash (logior g (ash h 8)) 16)) 32)) + (logior a + (ash (logior + b + (ash (logior + c + (ash (logior + d + (ash (logior + e + (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 8)) 8)) + 8)) + 8))) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) + (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) + +(def-gl-export rm64-guard-proof-helper + :hyp (and (n32p a) (n32p b)) + :concl (< (logior a (ash b 32)) *2^64*) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 32) (:nat b 32))) + :rule-classes :linear) + +(in-theory (e/d () + (rm16-guard-proof-helper + rb-and-rvm32-helper + rm32-guard-proof-helper + rb-and-rvm64-helper + rm64-guard-proof-helper))) + +(def-gl-export rm32-rb-system-level-mode-proof-helper + :hyp (and (n08p a) + (n08p b) + (n08p c) + (n08p d)) + :concl (equal (logior a (ash b 8) (ash (logior c (ash d 8)) 16)) + (logior a (ash (logior b (ash (logior c (ash d 8)) 8)) 8))) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8)))) + +;; (def-gl-export rm64-in-system-level-mode-guard-proof-helper +;; :hyp (and (n08p a) +;; (n08p b) +;; (n08p c) +;; (n08p d) +;; (n08p e) +;; (n08p f) +;; (n08p g) +;; (n08p h)) +;; :concl (< (logior a +;; (ash b 8) +;; (ash (logior c (ash d 8)) 16) +;; (ash (logior +;; e (ash f 8) +;; (ash (logior g (ash h 8)) 16)) 32)) +;; *2^64*) +;; :g-bindings (gl::auto-bindings +;; (:mix (:nat a 8) +;; (:nat b 8) +;; (:nat c 8) +;; (:nat d 8) +;; (:nat e 8) +;; (:nat f 8) +;; (:nat g 8) +;; (:nat h 8)))) + +(def-gl-export rm64-to-rb-in-system-level-mode-helper + :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) + (n08p e) (n08p f) (n08p g) (n08p h)) + :concl (equal + (logior a + (ash (logior b (ash (logior c (ash d 8)) 8)) 8) + (ash (logior e (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 32)) + (logior + a + (ash (logior + b + (ash (logior + c + (ash (logior d + (ash + (logior e + (ash + (logior f + (ash (logior g (ash h 8)) 8)) 8)) 8)) 8)) 8)) 8))) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) + (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) + (def-gl-export rm64-in-system-level-mode-guard-proof-helper :hyp (and (n08p a) (n08p b) @@ -22,12 +160,18 @@ (n08p f) (n08p g) (n08p h)) - :concl (< (logior a - (ash b 8) - (ash (logior c (ash d 8)) 16) - (ash (logior - e (ash f 8) - (ash (logior g (ash h 8)) 16)) 32)) + :concl (< (logior + a + (ash (logior + b + (ash (logior + c + (ash (logior d + (ash + (logior e + (ash + (logior f + (ash (logior g (ash h 8)) 8)) 8)) 8)) 8)) 8)) 8)) *2^64*) :g-bindings (gl::auto-bindings (:mix (:nat a 8) diff --git a/books/projects/x86isa/machine/x86-environment.lisp b/books/projects/x86isa/machine/x86-environment.lisp index c47e424a133..0ebb43cbfec 100644 --- a/books/projects/x86isa/machine/x86-environment.lisp +++ b/books/projects/x86isa/machine/x86-environment.lisp @@ -98,9 +98,7 @@ (< n (len (string-to-bytes str))) (stringp str)) (stringp (read-n-bytes-from-string-as-string n str))) - :rule-classes :type-prescription)) - - ) + :rule-classes :type-prescription))) ;; ====================================================================== @@ -133,12 +131,12 @@ ((when flg) (mv flg acc x86))) - (if (equal 0 mem-val) - (mv nil (append (reverse acc) '(0)) x86) + (if (equal 0 mem-val) + (mv nil (append (reverse acc) '(0)) x86) - (read-memory-zero-terminated - (the (signed-byte 49) (1+ ptr)) - x86 (cons mem-val acc)))) + (read-memory-zero-terminated + (the (signed-byte 49) (1+ ptr)) + x86 (cons mem-val acc)))) (mv t (reverse acc) x86)) @@ -170,7 +168,7 @@ ((when flg) (mv flg "nil" x86)) (charlist (bytes-to-charlist bytes))) - (mv nil (coerce charlist 'string) x86)) + (mv nil (coerce charlist 'string) x86)) /// @@ -213,10 +211,10 @@ (rm08 ptr :r x86)) ((when flg) (mv flg nil x86))) - (read-bytes-from-memory (the (signed-byte 49) (1+ ptr)) - (the (unsigned-byte 48) (1- nbytes)) - x86 - (cons byte acc)))) + (read-bytes-from-memory (the (signed-byte 49) (1+ ptr)) + (the (unsigned-byte 48) (1- nbytes)) + x86 + (cons byte acc)))) (mv t (reverse acc) x86)) /// @@ -249,7 +247,7 @@ ((when flg) (mv flg "nil" x86)) (charlist (bytes-to-charlist bytes))) - (mv nil (coerce charlist 'string) x86)) + (mv nil (coerce charlist 'string) x86)) /// @@ -260,9 +258,7 @@ (defthm x86p-mv-nth-2-read-string-from-memory (implies (x86p x86) - (x86p (mv-nth 2 (read-string-from-memory ptr nbytes x86)))))) - - ) + (x86p (mv-nth 2 (read-string-from-memory ptr nbytes x86))))))) ;; ====================================================================== diff --git a/books/projects/x86isa/machine/x86-top-level-memory.lisp b/books/projects/x86isa/machine/x86-top-level-memory.lisp index 3e45fcec5e3..27e88513f63 100644 --- a/books/projects/x86isa/machine/x86-top-level-memory.lisp +++ b/books/projects/x86isa/machine/x86-top-level-memory.lisp @@ -180,83 +180,12 @@ memory. (< k i)) (signed-byte-p n (+ k addr)))) -(local - (encapsulate - () - - (local (include-book "centaur/gl/gl" :dir :system)) - - ;; Various lemmas for the guard proofs of rm* functions - - (def-gl-export rm16-guard-proof-helper - :hyp (and (n08p a) - (n08p b)) - :concl (< (logior a (ash b 8)) *2^16*) - :g-bindings - (gl::auto-bindings - (:mix (:nat a 8) (:nat b 8))) - :rule-classes :linear) - - (def-gl-export rb-and-rvm32-helper - :hyp (and (n08p a) - (n08p b) - (n16p c)) - :concl (equal (logior a (ash b 8) (ash c 16)) - (logior a (ash (logior b (ash c 8)) 8))) - :g-bindings - (gl::auto-bindings - (:mix (:nat a 8) (:nat b 8)) (:nat c 16)) - :rule-classes :linear) - - (def-gl-export rm32-guard-proof-helper - :hyp (and (n08p a) - (n08p b) - (n08p c) - (n08p d)) - :concl (< - (logior a - (ash (logior b - (ash (logior c (ash d 8)) 8)) - 8)) - *2^32*) - :g-bindings - (gl::auto-bindings - (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8))) - :rule-classes :linear) - - (def-gl-export rb-and-rvm64-helper - :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) - (n08p e) (n08p f) (n08p g) (n08p h)) - :concl (equal - (logior a (ash b 8) - (ash (logior c (ash d 8)) 16) - (ash (logior e (ash f 8) (ash (logior g (ash h 8)) 16)) 32)) - (logior a - (ash (logior - b - (ash (logior - c - (ash (logior - d - (ash (logior - e - (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 8)) 8)) - 8)) - 8))) - :g-bindings - (gl::auto-bindings - (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) - (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) - - (def-gl-export rm64-guard-proof-helper - :hyp (and (n32p a) (n32p b)) - :concl (< (logior a (ash b 32)) *2^64*) - :g-bindings - (gl::auto-bindings - (:mix (:nat a 32) (:nat b 32))) - :rule-classes :linear) - - )) ;; End of local encapsulate +(local (in-theory (e/d* (rm16-guard-proof-helper + rb-and-rvm32-helper + rm32-guard-proof-helper + rb-and-rvm64-helper + rm64-guard-proof-helper) + ()))) (acl2::set-waterfall-parallelism t) @@ -822,7 +751,12 @@ memory. (defthm strip-cdrs-addr-byte-alistp-is-byte-listp (implies (addr-byte-alistp addr-lst) (byte-listp (strip-cdrs addr-lst))) - :rule-classes (:type-prescription :rewrite))) + :rule-classes (:type-prescription :rewrite)) + + (defthm append-and-addr-byte-alistp + (implies (and (addr-byte-alistp x) + (addr-byte-alistp y)) + (addr-byte-alistp (append x y))))) (defthm len-of-strip-cdrs (equal (len (strip-cdrs as)) (len as))) @@ -1351,6 +1285,10 @@ memory. /// + (defthm len-of-read-from-physical-memory + (equal (len (read-from-physical-memory p-addrs x86)) + (len p-addrs))) + (defthm cdr-read-from-physical-memory (equal (cdr (read-from-physical-memory p-addrs x86)) (read-from-physical-memory (cdr p-addrs) x86))) @@ -2114,9 +2052,9 @@ memory. (if (mbt (equal (len addr-list) (len byte-list))) (if (endp addr-list) nil - (acons (nth 0 addr-list) (nth 0 byte-list) - (create-addr-bytes-alist (nthcdr 1 addr-list) - (nthcdr 1 byte-list)))) + (acons (car addr-list) (car byte-list) + (create-addr-bytes-alist (cdr addr-list) + (cdr byte-list)))) nil) /// @@ -2125,6 +2063,12 @@ memory. (true-listp (create-addr-bytes-alist l-addrs bytes)) :rule-classes :type-prescription) + (defthm alistp-create-addr-bytes-alist + (implies (and (canonical-address-listp addrs) + (byte-listp bytes)) + (alistp (create-addr-bytes-alist addrs bytes))) + :rule-classes (:type-prescription :rewrite)) + (defthm consp-create-addr-bytes-alist-in-terms-of-len (implies (and (not (zp (len byte-list))) (equal (len addr-list) (len byte-list))) @@ -2197,7 +2141,24 @@ memory. (implies (and (not (zp (len byte-list))) (equal (len addr-list) (len byte-list))) (equal (len (create-addr-bytes-alist addr-list byte-list)) - (len addr-list))))) + (len addr-list)))) + + (defthm cons-and-create-addr-bytes-alist + (implies (equal (len x) (len a)) + (equal (cons (cons xe ae) + (create-addr-bytes-alist x a)) + (create-addr-bytes-alist (cons xe x) (cons ae a))))) + + (local (include-book "std/lists/len" :dir :system)) + (local (include-book "std/lists/append" :dir :system)) + + (defthm append-and-create-addr-bytes-alist + (implies (and (equal (len x) (len a)) + (equal (len y) (len b))) + (equal (append (create-addr-bytes-alist x a) + (create-addr-bytes-alist y b)) + (create-addr-bytes-alist (append x y) + (append a b)))))) (define create-canonical-address-list (count addr) :guard (natp count) @@ -2238,7 +2199,39 @@ memory. (canonical-address-p addr) (natp count)) (equal (len (create-canonical-address-list count addr)) - count)))) + count))) + + (defthm car-create-canonical-address-list + (implies (and (canonical-address-p addr) + (posp count)) + (equal (car (create-canonical-address-list count addr)) + addr))) + + (defthm cdr-create-canonical-address-list + (implies (and (canonical-address-p addr) + (posp count)) + (equal (cdr (create-canonical-address-list count addr)) + (create-canonical-address-list (1- count) (1+ addr))))) + + (defthm consp-of-create-canonical-address-list + (implies (and (canonical-address-p addr) + (natp count) + (< 0 count)) + (consp (create-canonical-address-list count addr))) + :hints (("Goal" :in-theory (e/d (canonical-address-p + signed-byte-p) + ())))) + + (defthmd create-canonical-address-list-split + (implies (and (canonical-address-p addr) + (canonical-address-p (+ k addr)) + (natp j) + (natp k)) + (equal (create-canonical-address-list (+ k j) addr) + (append (create-canonical-address-list k addr) + (create-canonical-address-list j (+ k addr))))) + :hints (("Goal" :in-theory (e/d* (canonical-address-p signed-byte-p) + ()))))) (define addr-range (count addr) :guard (natp count) @@ -2353,37 +2346,37 @@ memory. 1+lin-addr) #.*2^47*)) - (if (programmer-level-mode x86) - - (mbe - :logic (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 2 lin-addr) r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)) + (mbe :logic + (b* (((mv flg bytes x86) + (rb (create-canonical-address-list 2 lin-addr) r-w-x x86)) + (result (combine-bytes bytes))) + (mv flg result x86)) :exec - (rvm16 lin-addr x86)) + (if (programmer-level-mode x86) - (let* ((cpl (cpl x86))) - (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) - (la-to-pa lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) + (rvm16 lin-addr x86) - (1+lin-addr - (the (signed-byte #.*max-linear-address-size+1*) - (1+ (the (signed-byte #.*max-linear-address-size*) - lin-addr)))) - ((mv flag (the (unsigned-byte #.*physical-address-size*) ?p-addr1) x86) - (la-to-pa 1+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) + (let* ((cpl (cpl x86))) + (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) + (la-to-pa lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) - (byte0 (the (unsigned-byte 8) (memi p-addr0 x86))) - (byte1 (the (unsigned-byte 8) (memi p-addr1 x86))) + (1+lin-addr + (the (signed-byte #.*max-linear-address-size+1*) + (1+ (the (signed-byte #.*max-linear-address-size*) + lin-addr)))) + ((mv flag (the (unsigned-byte #.*physical-address-size*) ?p-addr1) x86) + (la-to-pa 1+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) - (word (the (unsigned-byte 16) - (logior (the (unsigned-byte 16) (ash byte1 8)) - byte0)))) + (byte0 (the (unsigned-byte 8) (memi p-addr0 x86))) + (byte1 (the (unsigned-byte 8) (memi p-addr1 x86))) - (mv nil word x86)))) + (word (the (unsigned-byte 16) + (logior (the (unsigned-byte 16) (ash byte1 8)) + byte0)))) + + (mv nil word x86))))) (mv 'rm16 0 x86))) @@ -2418,8 +2411,8 @@ memory. :guard (canonical-address-p lin-addr) (mv-let (flag val x86) - (rm16 lin-addr r-w-x x86) - (mv flag (n16-to-i16 val) x86)) + (rm16 lin-addr r-w-x x86) + (mv flag (n16-to-i16 val) x86)) /// (defthm-sb i16p-mv-nth-1-rim16 @@ -2447,7 +2440,7 @@ memory. :parents (x86-top-level-memory) :guard (canonical-address-p lin-addr) - :guard-hints (("Goal" :in-theory (e/d (wb-and-wvm16) (wb)))) + :guard-hints (("Goal" :in-theory (e/d (wb-and-wvm16 byte-ify) ()))) :prepwork @@ -2461,7 +2454,10 @@ memory. (byte-ify 2 val)) x86))) :hints (("Goal" :in-theory (e/d (wm08 wvm08 wvm16 byte-ify) - (force + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + force (force) unsigned-byte-p (nth) nth @@ -2478,39 +2474,37 @@ memory. 1+lin-addr) #.*2^47*)) - (if (programmer-level-mode x86) - - (mbe - :logic - (wb (create-addr-bytes-alist - (create-canonical-address-list 2 lin-addr) - (byte-ify 2 val)) - x86) + (mbe :logic (wb (create-addr-bytes-alist + (create-canonical-address-list 2 lin-addr) + (byte-ify 2 val)) + x86) :exec - (wvm16 lin-addr val x86)) + (if (programmer-level-mode x86) - (let* ((cpl (cpl x86))) + (wvm16 lin-addr val x86) - (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) - (la-to-pa lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) + (let* ((cpl (cpl x86))) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) - (la-to-pa 1+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) + (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) + (la-to-pa lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) - (byte0 (mbe - :logic (part-select val :low 0 :width 8) - :exec (the (unsigned-byte 8) (logand #xff val)))) - (byte1 (mbe - :logic (part-select val :low 8 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -8))))) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) + (la-to-pa 1+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) - (x86 (!memi p-addr0 byte0 x86)) - (x86 (!memi p-addr1 byte1 x86))) - (mv nil x86)))) + (byte0 (mbe + :logic (part-select val :low 0 :width 8) + :exec (the (unsigned-byte 8) (logand #xff val)))) + (byte1 (mbe + :logic (part-select val :low 8 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -8))))) + + (x86 (!memi p-addr0 byte0 x86)) + (x86 (!memi p-addr1 byte1 x86))) + (mv nil x86))))) (mv 'wm16 x86))) @@ -2521,7 +2515,7 @@ memory. (defthm x86p-wm16 (implies (force (x86p x86)) (x86p (mv-nth 1 (wm16 lin-addr val x86)))) - :hints (("Goal" :in-theory (e/d () (unsigned-byte-p signed-byte-p force (force))))) + :hints (("Goal" :in-theory (e/d (byte-ify) (unsigned-byte-p signed-byte-p force (force))))) :rule-classes (:rewrite :type-prescription))) (define wim16 @@ -2546,7 +2540,16 @@ memory. :parents (x86-top-level-memory) :guard (canonical-address-p lin-addr) - :guard-hints (("Goal" :in-theory (e/d (rb-and-rvm32 rm08) (rb)))) + :guard-hints (("Goal" :in-theory (e/d (rb-and-rvm32 rm08) + (rb-1-accumulator-thm + rb-1 + (:rewrite acl2::ash-0) + (:rewrite acl2::zip-open) + (:linear ash-monotone-2) + (:linear bitops::logior-<-0-linear-2) + (:rewrite xr-and-ia32e-la-to-pa-in-non-marking-mode) + (:rewrite bitops::logior-equal-0) + (:linear memi-is-n08p))))) :prepwork @@ -2559,8 +2562,8 @@ memory. (list nil (combine-bytes - (mv-nth 1 (rb (create-canonical-address-list 4 lin-addr) - r-w-x x86))) + (mv-nth 1 (rb-1 (create-canonical-address-list 4 lin-addr) + r-w-x x86 nil))) x86) (rvm32 lin-addr x86))) :hints (("Goal" :expand (create-canonical-address-list 4 lin-addr) @@ -2577,60 +2580,62 @@ memory. 3+lin-addr) #.*2^47*)) + (mbe :logic + (b* (((mv flg bytes x86) + (rb (create-canonical-address-list 4 lin-addr) + r-w-x x86)) + (result (combine-bytes bytes))) + (mv flg result x86)) - (if (programmer-level-mode x86) - - (mbe :logic (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 4 lin-addr) - r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)) - :exec (rvm32 lin-addr x86)) - - (let* ((cpl (cpl x86))) - - (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) - (la-to-pa lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - - (1+lin-addr (the (signed-byte #.*max-linear-address-size+1*) - (+ 1 (the (signed-byte #.*max-linear-address-size*) - lin-addr)))) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) - (la-to-pa 1+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - - (2+lin-addr (the (signed-byte #.*max-linear-address-size+2*) - (+ 2 (the (signed-byte #.*max-linear-address-size*) - lin-addr)))) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) - (la-to-pa 2+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - - (3+lin-addr (the (signed-byte #.*max-linear-address-size+3*) - (+ 3 (the (signed-byte #.*max-linear-address-size*) - lin-addr)))) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) - (la-to-pa 3+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - - (byte0 (the (unsigned-byte 8) (memi p-addr0 x86))) - (byte1 (the (unsigned-byte 8) (memi p-addr1 x86))) - (byte2 (the (unsigned-byte 8) (memi p-addr2 x86))) - (byte3 (the (unsigned-byte 8) (memi p-addr3 x86))) - - (word0 (the (unsigned-byte 16) - (logior (the (unsigned-byte 16) (ash byte1 8)) - byte0))) - (word1 (the (unsigned-byte 16) - (logior (the (unsigned-byte 16) (ash byte3 8)) - byte2))) - - (dword (the (unsigned-byte 32) - (logior (the (unsigned-byte 32) (ash word1 16)) - word0)))) - - (mv nil dword x86)))) + :exec + (if (programmer-level-mode x86) + + (rvm32 lin-addr x86) + + (let* ((cpl (cpl x86))) + + (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) + (la-to-pa lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + + (1+lin-addr (the (signed-byte #.*max-linear-address-size+1*) + (+ 1 (the (signed-byte #.*max-linear-address-size*) + lin-addr)))) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) + (la-to-pa 1+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + + (2+lin-addr (the (signed-byte #.*max-linear-address-size+2*) + (+ 2 (the (signed-byte #.*max-linear-address-size*) + lin-addr)))) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) + (la-to-pa 2+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + + (3+lin-addr (the (signed-byte #.*max-linear-address-size+3*) + (+ 3 (the (signed-byte #.*max-linear-address-size*) + lin-addr)))) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) + (la-to-pa 3+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + + (byte0 (the (unsigned-byte 8) (memi p-addr0 x86))) + (byte1 (the (unsigned-byte 8) (memi p-addr1 x86))) + (byte2 (the (unsigned-byte 8) (memi p-addr2 x86))) + (byte3 (the (unsigned-byte 8) (memi p-addr3 x86))) + + (word0 (the (unsigned-byte 16) + (logior (the (unsigned-byte 16) (ash byte1 8)) + byte0))) + (word1 (the (unsigned-byte 16) + (logior (the (unsigned-byte 16) (ash byte3 8)) + byte2))) + + (dword (the (unsigned-byte 32) + (logior (the (unsigned-byte 32) (ash word1 16)) + word0)))) + + (mv nil dword x86))))) (mv 'rm32 0 x86))) @@ -2665,8 +2670,8 @@ memory. :guard (canonical-address-p lin-addr) (mv-let (flag val x86) - (rm32 lin-addr r-w-x x86) - (mv flag (n32-to-i32 val) x86)) + (rm32 lin-addr r-w-x x86) + (mv flag (n32-to-i32 val) x86)) /// (defthm-sb i32p-mv-nth-1-rim32 @@ -2694,7 +2699,14 @@ memory. :parents (x86-top-level-memory) :guard (canonical-address-p lin-addr) - :guard-hints (("Goal" :in-theory (e/d (wb-and-wvm32) (wb)))) + :guard-hints (("Goal" :in-theory (e/d (wb-and-wvm32 byte-ify) + ((:rewrite acl2::ash-0) + (:rewrite acl2::zip-open) + (:linear ash-monotone-2) + (:linear bitops::logior-<-0-linear-2) + (:rewrite xr-and-ia32e-la-to-pa-in-non-marking-mode) + (:rewrite bitops::logior-equal-0) + (:linear memi-is-n08p))))) :prepwork @@ -2707,7 +2719,11 @@ memory. (create-canonical-address-list 4 lin-addr) (byte-ify 4 val)) x86))) - :hints (("Goal" :in-theory (e/d (wm08 wvm08 wvm32 byte-ify) (force (force))))))) + :hints (("Goal" :in-theory (e/d (wm08 wvm08 wvm32 byte-ify) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + force (force))))))) (if (mbt (canonical-address-p lin-addr)) @@ -2721,64 +2737,65 @@ memory. 3+lin-addr) #.*2^47*)) - (if (programmer-level-mode x86) - - (mbe - :logic - (wb (create-addr-bytes-alist - (create-canonical-address-list 4 lin-addr) - (byte-ify 4 val)) - x86) - :exec - (wvm32 lin-addr val x86)) - - (let* ((cpl (cpl x86))) - - (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) - (la-to-pa lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - - ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) - (+ 1 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) - (la-to-pa 1+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - - (2+lin-addr (the (signed-byte #.*max-linear-address-size+2*) - (+ 2 (the (signed-byte #.*max-linear-address-size*) - lin-addr)))) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) - (la-to-pa 2+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - - (3+lin-addr (the (signed-byte #.*max-linear-address-size+3*) - (+ 3 (the (signed-byte #.*max-linear-address-size*) - lin-addr)))) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) - (la-to-pa 3+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - - (byte0 (mbe - :logic (part-select val :low 0 :width 8) - :exec (the (unsigned-byte 8) (logand #xff val)))) - (byte1 (mbe - :logic (part-select val :low 8 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -8))))) - (byte2 (mbe - :logic (part-select val :low 16 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -16))))) - (byte3 (mbe - :logic (part-select val :low 24 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -24))))) + (mbe + :logic + (wb (create-addr-bytes-alist + (create-canonical-address-list 4 lin-addr) + (byte-ify 4 val)) + x86) + :exec - (x86 (!memi p-addr0 byte0 x86)) - (x86 (!memi p-addr1 byte1 x86)) - (x86 (!memi p-addr2 byte2 x86)) - (x86 (!memi p-addr3 byte3 x86))) - (mv nil x86)))) + (if (programmer-level-mode x86) + + (wvm32 lin-addr val x86) + + (let* ((cpl (cpl x86))) + + (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) + (la-to-pa lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + + ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) + (+ 1 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) + (la-to-pa 1+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + + (2+lin-addr (the (signed-byte #.*max-linear-address-size+2*) + (+ 2 (the (signed-byte #.*max-linear-address-size*) + lin-addr)))) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) + (la-to-pa 2+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + + (3+lin-addr (the (signed-byte #.*max-linear-address-size+3*) + (+ 3 (the (signed-byte #.*max-linear-address-size*) + lin-addr)))) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) + (la-to-pa 3+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + + (byte0 (mbe + :logic (part-select val :low 0 :width 8) + :exec (the (unsigned-byte 8) (logand #xff val)))) + (byte1 (mbe + :logic (part-select val :low 8 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -8))))) + (byte2 (mbe + :logic (part-select val :low 16 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -16))))) + (byte3 (mbe + :logic (part-select val :low 24 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -24))))) + + (x86 (!memi p-addr0 byte0 x86)) + (x86 (!memi p-addr1 byte1 x86)) + (x86 (!memi p-addr2 byte2 x86)) + (x86 (!memi p-addr3 byte3 x86))) + (mv nil x86))))) (mv 'wm32 x86))) @@ -2814,9 +2831,22 @@ memory. :parents (x86-top-level-memory) :guard (canonical-address-p lin-addr) - :guard-hints (("Goal" :in-theory (e/d (rb-and-rvm64 rm08) - (rb not member-equal - ash-monotone-2)))) + :guard-hints (("Goal" + :expand ((create-canonical-address-list 8 lin-addr) + (create-canonical-address-list 7 (+ 1 lin-addr)) + (create-canonical-address-list 6 (+ 2 lin-addr)) + (create-canonical-address-list 5 (+ 3 lin-addr))) + :in-theory (e/d (rb-and-rvm64 rm08) + (not + member-equal + ash-monotone-2 + (:rewrite acl2::ash-0) + (:rewrite acl2::zip-open) + (:linear ash-monotone-2) + (:linear bitops::logior-<-0-linear-2) + (:rewrite xr-and-ia32e-la-to-pa-in-non-marking-mode) + (:rewrite bitops::logior-equal-0) + (:linear memi-is-n08p))))) :prepwork ((local @@ -2836,7 +2866,8 @@ memory. r-w-x x86 nil))) 32)) x86))) - :hints (("Goal" :use ((:instance rb-and-rvm32) (:instance rb-and-rvm32 (lin-addr (+ 4 lin-addr)))) + :hints (("Goal" :use ((:instance rb-and-rvm32) + (:instance rb-and-rvm32 (lin-addr (+ 4 lin-addr)))) :in-theory (e/d (rvm64) (force (force))))))) @@ -2876,8 +2907,8 @@ memory. (canonical-address-p (+ 7 lin-addr))) (equal (rvm64 lin-addr x86) (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 8 lin-addr) - r-w-x x86)) + (rb-1 (create-canonical-address-list 8 lin-addr) + r-w-x x86 nil)) (result (combine-bytes bytes))) (mv flg result x86)))) :hints (("Goal" @@ -2889,38 +2920,7 @@ memory. signed-byte-p force (force)))))) - (defthmd rb-and-rvm64 - (implies (and (programmer-level-mode x86) - (x86p x86) - (canonical-address-p lin-addr) - (canonical-address-p (+ 7 lin-addr))) - (equal (rvm64 lin-addr x86) - (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 8 lin-addr) - r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)))) - :hints (("Goal" :expand (create-canonical-address-list 8 lin-addr) - :in-theory (e/d (rm08 rvm08 rvm32 rvm64 ifix) - (rb-and-rvm32-helper - rm64-guard-proof-helper - logior-expt-to-plus-quotep - signed-byte-p - force (force)))))) - - (local (in-theory (e/d* () (rb-and-rvm64-helper)))) - - (defthm combine-bytes-size-for-rm64-programmer-level-mode - (implies - (and (signed-byte-p 48 lin-addr) - (x86p x86) - (programmer-level-mode x86) - (signed-byte-p 48 (+ 7 lin-addr))) - (< (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list 8 lin-addr) r-w-x x86))) - *2^64*)) - :rule-classes :linear)) + (local (in-theory (e/d* () (rb-and-rvm64-helper))))) (if (mbt (canonical-address-p lin-addr)) @@ -2934,89 +2934,91 @@ memory. 7+lin-addr) #.*2^47*)) - (if (programmer-level-mode x86) - - (mbe :logic - (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 8 lin-addr) - r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)) - :exec (rvm64 lin-addr x86)) - - (let* ((cpl (cpl x86))) - - (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) - (la-to-pa lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) - (+ 1 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) - (la-to-pa 1+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+2*) 2+lin-addr) - (+ 2 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) - (la-to-pa 2+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+3*) 3+lin-addr) - (+ 3 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) - (la-to-pa 3+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+4*) 4+lin-addr) - (+ 4 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr4) x86) - (la-to-pa 4+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+5*) 5+lin-addr) - (+ 5 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr5) x86) - (la-to-pa 5+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+6*) 6+lin-addr) - (+ 6 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr6) x86) - (la-to-pa 6+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+7*) 7+lin-addr) - (+ 7 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr7) x86) - (la-to-pa 7+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) + (mbe :logic + (b* (((mv flg bytes x86) + (rb (create-canonical-address-list 8 lin-addr) + r-w-x x86)) + (result (combine-bytes bytes))) + (mv flg result x86)) - (byte0 (memi p-addr0 x86)) - (byte1 (memi p-addr1 x86)) - (byte2 (memi p-addr2 x86)) - (byte3 (memi p-addr3 x86)) - (byte4 (memi p-addr4 x86)) - (byte5 (memi p-addr5 x86)) - (byte6 (memi p-addr6 x86)) - (byte7 (memi p-addr7 x86)) - - (word0 (the (unsigned-byte 16) - (logior (the (unsigned-byte 16) (ash byte1 8)) - byte0))) - (word1 (the (unsigned-byte 16) - (logior (the (unsigned-byte 16) (ash byte3 8)) - byte2))) - (dword0 (the (unsigned-byte 32) - (logior (the (unsigned-byte 32) (ash word1 16)) - word0))) - (word2 (the (unsigned-byte 16) - (logior (the (unsigned-byte 16) (ash byte5 8)) - byte4))) - (word3 (the (unsigned-byte 16) - (logior (the (unsigned-byte 16) (ash byte7 8)) - byte6))) - (dword1 (the (unsigned-byte 32) - (logior (the (unsigned-byte 32) (ash word3 16)) - word2))) - (qword (the (unsigned-byte 64) - (logior (the (unsigned-byte 64) (ash dword1 32)) - dword0)))) - - (mv nil qword x86)))) + :exec + (if (programmer-level-mode x86) + + (rvm64 lin-addr x86) + + (let* ((cpl (cpl x86))) + + (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) + (la-to-pa lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) + (+ 1 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) + (la-to-pa 1+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+2*) 2+lin-addr) + (+ 2 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) + (la-to-pa 2+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+3*) 3+lin-addr) + (+ 3 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) + (la-to-pa 3+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+4*) 4+lin-addr) + (+ 4 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr4) x86) + (la-to-pa 4+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+5*) 5+lin-addr) + (+ 5 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr5) x86) + (la-to-pa 5+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+6*) 6+lin-addr) + (+ 6 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr6) x86) + (la-to-pa 6+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+7*) 7+lin-addr) + (+ 7 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr7) x86) + (la-to-pa 7+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + + (byte0 (memi p-addr0 x86)) + (byte1 (memi p-addr1 x86)) + (byte2 (memi p-addr2 x86)) + (byte3 (memi p-addr3 x86)) + (byte4 (memi p-addr4 x86)) + (byte5 (memi p-addr5 x86)) + (byte6 (memi p-addr6 x86)) + (byte7 (memi p-addr7 x86)) + + (word0 (the (unsigned-byte 16) + (logior (the (unsigned-byte 16) (ash byte1 8)) + byte0))) + (word1 (the (unsigned-byte 16) + (logior (the (unsigned-byte 16) (ash byte3 8)) + byte2))) + (dword0 (the (unsigned-byte 32) + (logior (the (unsigned-byte 32) (ash word1 16)) + word0))) + (word2 (the (unsigned-byte 16) + (logior (the (unsigned-byte 16) (ash byte5 8)) + byte4))) + (word3 (the (unsigned-byte 16) + (logior (the (unsigned-byte 16) (ash byte7 8)) + byte6))) + (dword1 (the (unsigned-byte 32) + (logior (the (unsigned-byte 32) (ash word3 16)) + word2))) + (qword (the (unsigned-byte 64) + (logior (the (unsigned-byte 64) (ash dword1 32)) + dword0)))) + + (mv nil qword x86))))) (mv 'rm64 0 x86))) @@ -3029,7 +3031,7 @@ memory. (x86p x86)) :bound 64 :concl (mv-nth 1 (rm64 lin-addr r-w-x x86)) - :hints (("Goal" :in-theory (e/d () (signed-byte-p ash-monotone-2 rb)))) + :hints (("Goal" :in-theory (e/d () (signed-byte-p ash-monotone-2)))) :otf-flg t :gen-linear t :hints-l (("Goal" :in-theory (e/d (signed-byte-p) (ash-monotone-2 rb)))) @@ -3081,7 +3083,19 @@ memory. :parents (x86-top-level-memory) :guard (canonical-address-p lin-addr) - :guard-hints (("Goal" :in-theory (e/d (wb-and-wvm64) (wb)))) + :guard-hints (("Goal" + :expand ((create-canonical-address-list 8 lin-addr) + (create-canonical-address-list 7 (+ 1 lin-addr)) + (create-canonical-address-list 6 (+ 2 lin-addr)) + (create-canonical-address-list 5 (+ 3 lin-addr))) + :in-theory (e/d (wb-and-wvm64 byte-ify) + ((:rewrite acl2::ash-0) + (:rewrite acl2::zip-open) + (:linear ash-monotone-2) + (:linear bitops::logior-<-0-linear-2) + (:rewrite xr-and-ia32e-la-to-pa-in-non-marking-mode) + (:rewrite bitops::logior-equal-0) + (:linear memi-is-n08p))))) :prepwork @@ -3094,7 +3108,11 @@ memory. (create-canonical-address-list 8 lin-addr) (byte-ify 8 val)) x86))) - :hints (("Goal" :in-theory (e/d (wm08 wvm08 wvm32 wvm64 byte-ify) (force (force))))))) + :hints (("Goal" :in-theory (e/d (wm08 wvm08 wvm32 wvm64 byte-ify) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + force (force))))))) (if (mbt (canonical-address-p lin-addr)) @@ -3108,93 +3126,95 @@ memory. 7+lin-addr) #.*2^47*)) - (if (programmer-level-mode x86) - - (mbe - :logic - (wb (create-addr-bytes-alist - (create-canonical-address-list 8 lin-addr) - (byte-ify 8 val)) - x86) - :exec - (wvm64 lin-addr val x86)) - - (let* ((cpl (cpl x86))) - - (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) - (la-to-pa lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) - (+ 1 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) - (la-to-pa 1+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+2*) 2+lin-addr) - (+ 2 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) - (la-to-pa 2+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+3*) 3+lin-addr) - (+ 3 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) - (la-to-pa 3+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+4*) 4+lin-addr) - (+ 4 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr4) x86) - (la-to-pa 4+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+5*) 5+lin-addr) - (+ 5 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr5) x86) - (la-to-pa 5+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+6*) 6+lin-addr) - (+ 6 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr6) x86) - (la-to-pa 6+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+7*) 7+lin-addr) - (+ 7 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr7) x86) - (la-to-pa 7+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) + (mbe + :logic + (wb (create-addr-bytes-alist + (create-canonical-address-list 8 lin-addr) + (byte-ify 8 val)) + x86) - (byte0 (mbe :logic (part-select val :low 0 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff val)))) - (byte1 (mbe :logic (part-select val :low 8 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -8))))) - (byte2 (mbe :logic (part-select val :low 16 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -16))))) - (byte3 (mbe :logic (part-select val :low 24 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -24))))) - (byte4 (mbe :logic (part-select val :low 32 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -32))))) - (byte5 (mbe :logic (part-select val :low 40 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -40))))) - (byte6 (mbe :logic (part-select val :low 48 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -48))))) - (byte7 (mbe :logic (part-select val :low 56 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -56))))) + :exec + (if (programmer-level-mode x86) + + (wvm64 lin-addr val x86) + + + (let* ((cpl (cpl x86))) + + (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) + (la-to-pa lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) + (+ 1 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) + (la-to-pa 1+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+2*) 2+lin-addr) + (+ 2 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) + (la-to-pa 2+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+3*) 3+lin-addr) + (+ 3 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) + (la-to-pa 3+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+4*) 4+lin-addr) + (+ 4 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr4) x86) + (la-to-pa 4+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+5*) 5+lin-addr) + (+ 5 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr5) x86) + (la-to-pa 5+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+6*) 6+lin-addr) + (+ 6 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr6) x86) + (la-to-pa 6+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+7*) 7+lin-addr) + (+ 7 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr7) x86) + (la-to-pa 7+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + + (byte0 (mbe :logic (part-select val :low 0 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff val)))) + (byte1 (mbe :logic (part-select val :low 8 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -8))))) + (byte2 (mbe :logic (part-select val :low 16 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -16))))) + (byte3 (mbe :logic (part-select val :low 24 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -24))))) + (byte4 (mbe :logic (part-select val :low 32 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -32))))) + (byte5 (mbe :logic (part-select val :low 40 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -40))))) + (byte6 (mbe :logic (part-select val :low 48 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -48))))) + (byte7 (mbe :logic (part-select val :low 56 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -56))))) - (x86 (!memi p-addr0 byte0 x86)) - (x86 (!memi p-addr1 byte1 x86)) - (x86 (!memi p-addr2 byte2 x86)) - (x86 (!memi p-addr3 byte3 x86)) - (x86 (!memi p-addr4 byte4 x86)) - (x86 (!memi p-addr5 byte5 x86)) - (x86 (!memi p-addr6 byte6 x86)) - (x86 (!memi p-addr7 byte7 x86))) + (x86 (!memi p-addr0 byte0 x86)) + (x86 (!memi p-addr1 byte1 x86)) + (x86 (!memi p-addr2 byte2 x86)) + (x86 (!memi p-addr3 byte3 x86)) + (x86 (!memi p-addr4 byte4 x86)) + (x86 (!memi p-addr5 byte5 x86)) + (x86 (!memi p-addr6 byte6 x86)) + (x86 (!memi p-addr7 byte7 x86))) - (mv nil x86)))) + (mv nil x86))))) (mv 'wm64 x86))) @@ -3529,7 +3549,10 @@ memory. (byte-ify 16 val)) x86))) :hints (("Goal" :in-theory (e/d (wm08 wvm08 wvm32 wvm64 wvm128 byte-ify) - (force (force) NTHCDR-BYTE-LISTP)))))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + force (force) nthcdr-byte-listp)))))) (if (mbt (canonical-address-p lin-addr)) @@ -3718,6 +3741,50 @@ memory. ;; ====================================================================== +;; Normalizing calls of rm08 and wm08: +;; Note that we don't have to prove rm16-to-rb and wm16-to-rb and +;; other such rules about rm*/wm* functions because these other +;; functions have MBEs which say that they are equal to calls of +;; rb/wb. + +;; Enable these rules when doing code proofs. + +(local + (defthm dumb-integerp-of-mem-rewrite + (implies (x86p x86) + (integerp (xr :mem index x86))))) + +(defthmd rm08-to-rb + (implies (and (x86p x86) + (force (canonical-address-p lin-addr))) + (equal (rm08 lin-addr r-w-x x86) + (b* (((mv flg bytes x86) + (rb (create-canonical-address-list 1 lin-addr) r-w-x x86)) + (result (combine-bytes bytes))) + (mv flg result x86)))) + :hints (("Goal" + :use ((:instance rb-and-rm08-in-programmer-level-mode (addr lin-addr))) + :in-theory (e/d* (rm08 rb ifix) + (rb-1 + signed-byte-p + unsigned-byte-p + force (force)))))) + +(defthmd wm08-to-wb + (implies (and (force (canonical-address-p lin-addr)) + (force (unsigned-byte-p 8 byte))) + (equal (wm08 lin-addr byte x86) + (wb (create-addr-bytes-alist + (create-canonical-address-list 1 lin-addr) + (list byte)) + x86))) + :hints (("Goal" :in-theory (e/d* (wm08 wvm08 wb) + (signed-byte-p + unsigned-byte-p + force (force)))))) + +;; ====================================================================== + (defsection Parametric-Memory-Reads-and-Writes :parents (x86-top-level-memory) @@ -3973,45 +4040,80 @@ memory. (wim32 next-addr canonical-address-high-int x86)) ((when (or flg0 flg1)) (mv 'wm64-canonical-address-user-mode x86))) - (mv nil x86)) + (mv nil x86)) (mv 'unreachable x86))) -(defthmd write-canonical-address-to-memory-user-exec-and-wvm64 - (implies (and (programmer-level-mode x86) - (canonical-address-p lin-addr) - (canonical-address-p canonical-address) - (canonical-address-p (+ 7 lin-addr))) - (equal (write-canonical-address-to-memory-user-exec - lin-addr canonical-address x86) - (wvm64 lin-addr - (part-select canonical-address - :low 0 :width 64) - x86))) - :hints (("Goal" :in-theory (e/d (wim64 wm64 wim32 wm32 wm08 - wvm64 wvm32 wvm08 - write-canonical-address-to-memory-user-exec - byte-ify - n16-to-i16) - ())))) - -(defthm write-canonical-address-to-memory-user-exec-and-wb - (implies (and (programmer-level-mode x86) - (canonical-address-p lin-addr) - (canonical-address-p canonical-address) - (canonical-address-p (+ 7 lin-addr)) - (x86p x86)) - (equal (write-canonical-address-to-memory-user-exec - lin-addr canonical-address x86) - (wb (create-addr-bytes-alist - (create-canonical-address-list 8 lin-addr) - (byte-ify 8 canonical-address)) - x86))) - :hints (("Goal" :in-theory (e/d - (write-canonical-address-to-memory-user-exec-and-wvm64 - byte-ify - wb-and-wvm64) - (wb))))) +(local (in-theory (e/d* () ((:meta acl2::mv-nth-cons-meta))))) + +(local + (defthm mv-nth-0-of-list-of-2-things + (equal (mv-nth 0 (list x y)) x))) + +(local + (defthm mv-nth-1-of-list-of-2-things + (equal (mv-nth 1 (list x y)) y))) + +(local + (defthm combining-wb-1 + (implies (and (addr-byte-alistp alst-1) + (addr-byte-alistp alst-2) + (programmer-level-mode x86) + (x86p x86)) + (equal + (mv-nth 1 (wb-1 alst-2 (mv-nth 1 (wb-1 alst-1 x86)))) + (mv-nth 1 (wb-1 (append alst-1 alst-2) x86)))) + :hints (("Goal" :in-theory (e/d* (wb-1) + ((:meta acl2::mv-nth-cons-meta))))))) + +(local + (defthmd wb-1-in-programmer-level-mode + (implies (and (addr-byte-alistp addr-lst) + (x86p x86) + (programmer-level-mode x86)) + (equal (wb-1 addr-lst x86) + (mv + nil + (mv-nth 1 (wb-1 addr-lst x86))))))) + + +(local + (defthm write-canonical-address-to-memory-user-exec-and-wb + (implies (and (programmer-level-mode x86) + (canonical-address-p lin-addr) + (canonical-address-p canonical-address) + (canonical-address-p (+ 7 lin-addr)) + (x86p x86)) + (equal (write-canonical-address-to-memory-user-exec + lin-addr canonical-address x86) + (wb (create-addr-bytes-alist + (create-canonical-address-list 8 lin-addr) + (byte-ify 8 canonical-address)) + x86))) + :hints (("Goal" + :use ((:instance create-canonical-address-list-split + (j 4) + (k 4) + (addr lin-addr)) + (:instance wb-1-in-programmer-level-mode + (addr-lst (create-addr-bytes-alist + (create-canonical-address-list 8 lin-addr) + (list (loghead 8 canonical-address) + (loghead 8 (logtail 8 canonical-address)) + (loghead 8 (logtail 16 canonical-address)) + (loghead 8 (logtail 24 canonical-address)) + (loghead 8 (logtail 32 canonical-address)) + (loghead 8 (logtail 40 canonical-address)) + (loghead 8 (logtail 48 canonical-address)) + (loghead 8 (logtail 56 canonical-address))))))) + :in-theory (e/d* + (write-canonical-address-to-memory-user-exec + wim32 + wm32 + byte-ify + wb-and-wvm64 + wb-1) + ()))))) (define write-canonical-address-to-memory ((lin-addr :type (signed-byte #.*max-linear-address-size*)) diff --git a/books/projects/x86isa/proofs/factorial/fact-inductive-assertions.lisp b/books/projects/x86isa/proofs/factorial/fact-inductive-assertions.lisp index 5340dff14b4..03e777eae82 100644 --- a/books/projects/x86isa/proofs/factorial/fact-inductive-assertions.lisp +++ b/books/projects/x86isa/proofs/factorial/fact-inductive-assertions.lisp @@ -438,6 +438,11 @@ x86)) (inv n0 addr (x86-fetch-decode-execute x86))) :hints (("Goal" + :in-theory (e/d* () + (get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix)) :cases ((equal (n32 (- (n32-to-i32 (n32 (rgfi *rdi* x86))) 1)) 0))) ("Subgoal 2" :in-theory (e/d* @@ -480,7 +485,14 @@ rr32) (create-canonical-address-list (create-canonical-address-list) - Loop-Inv-To-Loop-Inv)) + Loop-Inv-To-Loop-Inv + (:linear bitops::logior-<-0-linear-2) + (:rewrite acl2::ifix-when-not-integerp) + (:linear bitops::logior-<-0-linear-1) + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix)) :use ((:instance Loop-Inv-To-Loop-Inv (n0 n0) (n (loghead 32 (rgfi *rdi* x86))) @@ -526,7 +538,14 @@ (create-canonical-address-list (create-canonical-address-list) Loop-Inv-To-Halt - Loop-Inv-to-Halt-helper)) + Loop-Inv-to-Halt-helper + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:linear bitops::logior-<-0-linear-2) + (:rewrite acl2::ifix-when-not-integerp) + (:linear bitops::logior-<-0-linear-1))) :use ((:instance Loop-Inv-to-Halt-helper (n (loghead 32 (rgfi *rdi* x86))) (a (loghead 32 (rgfi *rax* x86)))) @@ -572,7 +591,41 @@ zf-spec pf-spec32) (create-canonical-address-list - (create-canonical-address-list)))) + (create-canonical-address-list) + (:rewrite get-prefixes-opener-lemma-group-4-prefix) + (:rewrite get-prefixes-opener-lemma-group-3-prefix) + (:rewrite get-prefixes-opener-lemma-group-2-prefix) + (:rewrite get-prefixes-opener-lemma-group-1-prefix) + (:rewrite combine-bytes-of-rb-of-1-address-in-programmer-level-mode) + (:definition combine-bytes) + (:rewrite acl2::ash-0) + (:rewrite acl2::zip-open) + (:rewrite rb-in-terms-of-nth-and-pos) + (:rewrite acl2::zp-when-integerp) + (:rewrite acl2::equal-of-booleans-rewrite) + (:rewrite canonical-address-p-limits-thm-3) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition byte-listp) + (:linear unsigned-byte-p-of-combine-bytes) + (:linear size-of-combine-bytes) + (:rewrite default-<-2) + (:rewrite default-+-1) + (:rewrite bitops::unsigned-byte-p-when-unsigned-byte-p-less) + (:definition n08p$inline) + (:rewrite loghead-of-non-integerp) + (:rewrite default-<-1) + (:definition nth) + (:rewrite subset-p-cdr-y) + (:rewrite acl2::ifix-when-not-integerp) + (:rewrite acl2::logtail-identity) + (:rewrite canonical-address-p-limits-thm-2) + (:rewrite canonical-address-p-limits-thm-1) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite get-prefixes-opener-lemma-zero-cnt) + (:rewrite combine-bytes-rb-in-terms-of-rb-subset-p) + (:rewrite x86p-x86-fetch-decode-execute) + (:definition create-canonical-address-list)))) ("Subgoal 2" :in-theory (e/d (x86-fetch-decode-execute rr32) @@ -588,7 +641,7 @@ (equal (inv n0 addr (x86-run k (x86-fetch-decode-execute x86))) (inv n0 addr (x86-fetch-decode-execute (x86-run k x86))))) :hints (("Goal" :in-theory (e/d (x86-run-and-x86-fetch-decode-and-execute-commutative) - ())))) + ((:meta acl2::mv-nth-cons-meta)))))) (defthm Inv-Inv-x86-run (implies (and (x86p x86) @@ -597,7 +650,11 @@ :hints (("Goal" :induct (x86-run k x86) :in-theory (e/d (x86-run inv-x86-run-and-x86-fetch-decode-and-execute-commutative) - (assertions))))) + (assertions + (:rewrite x86-fetch-decode-execute-opener) + (:rewrite get-prefixes-opener-lemma-no-prefix-byte) + (:meta acl2::mv-nth-cons-meta) + (:rewrite rm08-to-rb)))))) ;; ====================================================================== diff --git a/books/projects/x86isa/proofs/factorial/fact-wormhole-abstraction.lisp b/books/projects/x86isa/proofs/factorial/fact-wormhole-abstraction.lisp index ae0410b96c5..bdf808c203b 100644 --- a/books/projects/x86isa/proofs/factorial/fact-wormhole-abstraction.lisp +++ b/books/projects/x86isa/proofs/factorial/fact-wormhole-abstraction.lisp @@ -338,38 +338,38 @@ ;; (5) Prove that the code (*factorial_recursive*) implements the ;; algorithm: - (encapsulate - () + () - (local (include-book "centaur/gl/gl" :dir :system)) + (local (include-book "centaur/gl/gl" :dir :system)) - (local - (def-gl-thm loop-effects-helper-1 - :hyp (and (not (equal rdi 1)) - (unsigned-byte-p 32 rdi)) - :concl (equal (equal (loghead 32 (+ -1 (logext 32 rdi))) 0) - nil) - :g-bindings - `((rdi (:g-number ,(gl-int 0 2 33)))))) + (local + (def-gl-thm loop-effects-helper-1 + :hyp (and (not (equal rdi 1)) + (unsigned-byte-p 32 rdi)) + :concl (equal (equal (loghead 32 (+ -1 (logext 32 rdi))) 0) + nil) + :g-bindings + `((rdi (:g-number ,(gl-int 0 2 33)))))) - (defthm loop-effects-helper - (implies (and (not (equal rdi 1)) - (unsigned-byte-p 32 rdi)) - (equal (equal (loghead 32 (+ -1 (logext 32 rdi))) 0) - nil)))) + (defthm loop-effects-helper + (implies (and (not (equal rdi 1)) + (unsigned-byte-p 32 rdi)) + (equal (equal (loghead 32 (+ -1 (logext 32 rdi))) 0) + nil)))) (defthm loop-effects ;; imul %edi,%eax ;; sub $0x1,%edi ;; jne 400600 - (implies (and (equal addr (- (rip x86) #x10)) - (fact-init-x86-state n addr x86) - (equal loop-addr (+ #x10 addr)) - (n32p a) - (posp n) - (equal a (rgfi *rax* x86))) + (implies (and + (equal addr (- (rip x86) #x10)) + (fact-init-x86-state n addr x86) + (equal loop-addr (+ #x10 addr)) + (n32p a) + (posp n) + (equal a (rgfi *rax* x86))) (equal (x86-run (loop-clk n a) x86) (let* ((x86 (loop-all-induction n a loop-addr x86)) (x86 (xw :rip 0 (+ #x18 addr) x86))) @@ -404,7 +404,19 @@ fact-init-x86-state) (bitops::logior-equal-0 negative-logand-to-positive-logand-with-integerp-x - not))))) + not + (:linear loghead-n-x-<-x) + (:linear logext-n-x-1-<-x) + (:rewrite acl2::natp-rw) + (:rewrite acl2::<-*-0) + (:rewrite acl2::natp-posp--1) + (:rewrite acl2::natp-when-integerp) + (:rewrite acl2::natp-when-gte-0) + (:rewrite acl2::natp-*) + (:rewrite get-prefixes-opener-lemma-group-4-prefix) + (:rewrite get-prefixes-opener-lemma-group-3-prefix) + (:rewrite get-prefixes-opener-lemma-group-2-prefix) + (:rewrite get-prefixes-opener-lemma-group-1-prefix)))))) (in-theory (e/d (subset-p) (loop-clk))) diff --git a/books/projects/x86isa/proofs/utilities/general-memory-utils.lisp b/books/projects/x86isa/proofs/utilities/general-memory-utils.lisp index ea719eb19ea..fe3f5f700e5 100644 --- a/books/projects/x86isa/proofs/utilities/general-memory-utils.lisp +++ b/books/projects/x86isa/proofs/utilities/general-memory-utils.lisp @@ -17,6 +17,8 @@ (local (xdoc::set-default-parents general-memory-utils)) +(in-theory (e/d* (rm08-to-rb wm08-to-wb) ())) + ;; =================================================================== ;; Some lemmas for constructing a number from its constituent parts: @@ -321,20 +323,13 @@ /// - (local (include-book "std/lists/nthcdr" :dir :system)) + (local (include-book "std/alists/top" :dir :system)) (defthm assoc-list-and-cons (implies (not (member-p ax cx)) (equal (assoc-list cx (cons (cons ax ay) term)) (assoc-list cx term)))) - (defthm assoc-list-and-create-addr-bytes-alist - (implies (and (true-listp y) - (equal (len x) (len y)) - (no-duplicates-p x)) - (equal (assoc-list x (create-addr-bytes-alist x y)) - y))) - (defthm assoc-and-append-with-list-cons (implies (not (equal ax cx)) (equal (assoc-equal cx (append term (list (cons ax ay)))) @@ -345,12 +340,28 @@ (equal (assoc-list cx (append term (list (cons ax ay)))) (assoc-list cx term)))) + (defthm assoc-list-and-create-addr-bytes-alist + (implies (and (true-listp x) + (true-listp y) + (equal (len x) (len y)) + (no-duplicates-p x)) + (equal (assoc-list x (create-addr-bytes-alist x y)) + y)) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) + (defthm assoc-list-of-rev-of-create-addr-bytes-alist (implies (and (true-listp y) (equal (len x) (len y)) (no-duplicates-p x)) (equal (assoc-list x (acl2::rev (create-addr-bytes-alist x y))) - y)))) + y)) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp)))))) ;; ---------------------------------------------------------------------- @@ -534,28 +545,6 @@ (defthm create-canonical-address-list-of-0 (equal (create-canonical-address-list 0 addr) nil)) -(defthm car-create-canonical-address-list - (implies (and (canonical-address-p addr) - (posp count)) - (equal (car (create-canonical-address-list count addr)) - addr))) - -(defthm cdr-create-canonical-address-list - (implies (and (canonical-address-p addr) - (posp count)) - (equal (cdr (create-canonical-address-list count addr)) - (create-canonical-address-list (1- count) (1+ addr))))) - -(defthm consp-of-create-canonical-address-list - (implies (and (canonical-address-p addr) - (natp count) - (< 0 count)) - (consp (create-canonical-address-list count addr))) - :hints (("Goal" :in-theory (e/d (create-canonical-address-list - canonical-address-p - signed-byte-p) - ())))) - (defthm member-p-canonical-address-p-canonical-address-listp (implies (member-p e (create-canonical-address-list n prog-addr)) (canonical-address-p e)) @@ -807,20 +796,7 @@ (implies (signed-byte-p 64 x) (equal (n64-to-i64 (loghead 64 x)) x)) - :hints (("Goal" :in-theory (e/d (canonical-address-p n64-to-i64) ())))) - - ) - -(defthmd create-canonical-address-list-split - (implies (and (canonical-address-p addr) - (canonical-address-p (+ k addr)) - (natp j) - (natp k)) - (equal (create-canonical-address-list (+ k j) addr) - (append (create-canonical-address-list k addr) - (create-canonical-address-list j (+ k addr))))) - :hints (("Goal" :in-theory (e/d* (canonical-address-p signed-byte-p) - ())))) + :hints (("Goal" :in-theory (e/d (canonical-address-p n64-to-i64) ()))))) ;; ====================================================================== @@ -876,52 +852,50 @@ :rule-classes (:rewrite :forward-chaining))) (encapsulate - () + () - (local (include-book "std/lists/reverse" :dir :system)) - - (defthm member-p-and-strip-cars-of-remove-duplicate-keys - (implies (member-p a (strip-cars xs)) - (member-p a (strip-cars (remove-duplicate-keys xs))))) - - (defthm member-p-and-remove-duplicate-keys-and-car - (implies (consp xs) - (member-p (car (car (remove-duplicate-keys xs))) - (strip-cars xs)))) - - (defthm consp-remove-duplicate-keys - (implies (consp (remove-duplicate-keys xs)) - (consp xs)) - :rule-classes :forward-chaining) - - (defthm subset-p-strip-cars-and-remove-duplicate-keys - (subset-p (strip-cars (cdr (remove-duplicate-keys xs))) - (strip-cars xs)) - :hints (("Goal" :in-theory (e/d (subset-p) ())))) - - (defthm member-p-strip-cars-of-remove-duplicate-keys - ;; implies, equal, or iff? - (implies (member-p a (strip-cars (remove-duplicate-keys xs))) - (member-p a (strip-cars xs))) - :rule-classes (:forward-chaining :rewrite)) - - (defthm member-p-strip-cars-remove-duplicate-keys-and-rev - ;; implies, equal, or iff? - (implies (member-p a (strip-cars (remove-duplicate-keys xs))) - (member-p a (strip-cars (acl2::rev xs)))) - :rule-classes (:forward-chaining :rewrite)) - - (defthm canonical-address-listp-strip-cars-remove-duplicate-keys-addr-bytes-alistp - (implies (and (subset-p addresses (strip-cars (remove-duplicate-keys addr-lst))) - (addr-byte-alistp addr-lst)) - (canonical-address-listp addresses)) - :hints (("Goal" :in-theory (e/d* (subset-p - canonical-address-listp - addr-byte-alistp) - ()))) - :rule-classes :forward-chaining) - - ) + (local (include-book "std/lists/reverse" :dir :system)) + + (defthm member-p-and-strip-cars-of-remove-duplicate-keys + (implies (member-p a (strip-cars xs)) + (member-p a (strip-cars (remove-duplicate-keys xs))))) + + (defthm member-p-and-remove-duplicate-keys-and-car + (implies (consp xs) + (member-p (car (car (remove-duplicate-keys xs))) + (strip-cars xs)))) + + (defthm consp-remove-duplicate-keys + (implies (consp (remove-duplicate-keys xs)) + (consp xs)) + :rule-classes :forward-chaining) + + (defthm subset-p-strip-cars-and-remove-duplicate-keys + (subset-p (strip-cars (cdr (remove-duplicate-keys xs))) + (strip-cars xs)) + :hints (("Goal" :in-theory (e/d (subset-p) ())))) + + (defthm member-p-strip-cars-of-remove-duplicate-keys + ;; implies, equal, or iff? + (implies (member-p a (strip-cars (remove-duplicate-keys xs))) + (member-p a (strip-cars xs))) + :rule-classes (:forward-chaining :rewrite)) + + (defthm member-p-strip-cars-remove-duplicate-keys-and-rev + ;; implies, equal, or iff? + (implies (member-p a (strip-cars (remove-duplicate-keys xs))) + (member-p a (strip-cars (acl2::rev xs)))) + :rule-classes (:forward-chaining :rewrite)) + + (defthm canonical-address-listp-strip-cars-remove-duplicate-keys-addr-bytes-alistp + (implies (and (subset-p addresses (strip-cars (remove-duplicate-keys addr-lst))) + (addr-byte-alistp addr-lst)) + (canonical-address-listp addresses)) + :hints (("Goal" :in-theory (e/d* (subset-p + canonical-address-listp + addr-byte-alistp) + ()))) + :rule-classes :forward-chaining)) ;; ====================================================================== @@ -933,7 +907,6 @@ (assoc-list xs term1))) :hints (("Goal" :in-theory (e/d* (subset-p) ())))) - (defthm assoc-list-append-and-rev-lemma-helper-1 (implies (and (canonical-address-listp x) (byte-listp y) @@ -942,7 +915,6 @@ (equal (assoc-list x (append (acl2::rev (create-addr-bytes-alist x y)) term)) y))) - (defthm assoc-list-append-and-rev-lemma-helper-2 (implies (and (canonical-address-listp a) (equal (len a) (len b)) @@ -952,8 +924,6 @@ (assoc-list x term))) :hints (("Goal" :in-theory (e/d* (disjoint-p) ())))) - - ;; (defthm assoc-list-append-and-rev-lemma ;; ;; Bad lemma --- can cause stack overflows and looping. ;; (implies (and (canonical-address-listp a) @@ -1021,8 +991,12 @@ (create-canonical-address-list (len bytes) lin-addr) bytes) x86))) - :hints (("Goal" :in-theory (e/d (write-bytes-to-memory) - (acl2::mv-nth-cons-meta)))))) + :hints (("Goal" :in-theory (e/d (write-bytes-to-memory wb wm08 wvm08) + (acl2::mv-nth-cons-meta + wm08-to-wb + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp)))))) (defthm write-bytes-to-memory-is-wb-in-programmer-level-mode (implies (and (canonical-address-p (+ (len bytes) lin-addr)) diff --git a/books/projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils.lisp b/books/projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils.lisp index a89f9f50951..b8cebb1ea2a 100644 --- a/books/projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils.lisp +++ b/books/projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils.lisp @@ -37,7 +37,7 @@ programmer-level mode.

" ) ;; (acl2::why x86-run-opener-not-ms-not-zp-n) ;; (acl2::why x86-fetch-decode-execute-opener) -;; (acl2::why get-prefixes-opener-lemma-2) +;; (acl2::why get-prefixes-opener-lemma-no-prefix-byte) ;; (acl2::why rb-in-terms-of-nth-and-pos) ;; (acl2::why program-at-wb-disjoint) ;; (acl2::why member-p-canonical-address-listp) @@ -329,7 +329,8 @@ programmer-level mode.

" ) (programmer-level-mode x86)) (equal (mv-nth 1 (rvm08 addr (mv-nth 1 (wb addr-lst x86)))) (mv-nth 1 (rvm08 addr x86)))) - :hints (("Goal" :in-theory (e/d (wm08 wb) ()))))) + :hints (("Goal" :in-theory (e/d (wm08 wvm08 wb rvm08) + (wm08-to-wb)))))) (local (defthm rm08-wb-not-member-p @@ -347,8 +348,8 @@ programmer-level mode.

" ) :hints (("Goal" :do-not '(preprocess) :in-theory (e/d* (disjoint-p) (strip-cars - wb-by-wb-1-for-programmer-level-mode-induction-rule))))) - + wb-by-wb-1-for-programmer-level-mode-induction-rule + (:meta acl2::mv-nth-cons-meta)))))) (local (defthm rb-wb-equal-assoc-helper-1 @@ -410,7 +411,6 @@ programmer-level mode.

" ) (mv-nth 1 (rvm08 addr x86)))) :hints (("Goal" :in-theory (e/d (wm08) ()))))) - (local (defthm rvm08-wb-1-member-p-helper (implies (and (member-p addr (strip-cars (remove-duplicate-keys addr-lst))) @@ -419,7 +419,10 @@ programmer-level mode.

" ) (equal (mv-nth 1 (rvm08 addr (mv-nth 1 (wb-1 addr-lst x86)))) (cdr (assoc-equal addr (reverse addr-lst))))) :hints (("Goal" - :in-theory (e/d (wm08 member-p) (unsigned-byte-p signed-byte-p)))))) + :in-theory (e/d (wm08 member-p) + (wm08-to-wb + unsigned-byte-p + signed-byte-p)))))) (local (defthm rvm08-wb-member-p-helper @@ -683,7 +686,7 @@ programmer-level mode.

" ) (equal (wb (acons addr val addr-list) x86) (wb addr-list x86))) :hints (("Goal" :do-not '(generalize) - :in-theory (e/d (wb wm08 mv-nth) ())))) + :in-theory (e/d (wb wm08 mv-nth) (wm08-to-wb))))) (defun-nx wb-duplicate-writes-induct (addr-list x86) (if (endp addr-list) @@ -724,7 +727,8 @@ programmer-level mode.

" ) (wb (remove-duplicate-keys addr-list) x86))) :hints (("Goal" :do-not '(generalize) :in-theory (e/d (wm08 wb) - (acl2::mv-nth-cons-meta)) + (wm08-to-wb + acl2::mv-nth-cons-meta)) :induct (wb-duplicate-writes-induct addr-list x86)))) ;; ====================================================================== @@ -746,12 +750,12 @@ programmer-level mode.

" ) :hints (("Goal" :in-theory (e/d (pos rb) (signed-byte-p))))) -(defthm rm08-in-terms-of-rb - ;; Also see rb-and-rm08. - (implies (and (canonical-address-p addr) - (programmer-level-mode x86)) - (equal (mv-nth 1 (rm08 addr r-w-x x86)) - (car (mv-nth 1 (rb (list addr) r-w-x x86)))))) +;; (defthm rm08-in-terms-of-rb +;; ;; Also see rb-and-rm08. +;; (implies (and (canonical-address-p addr) +;; (programmer-level-mode x86)) +;; (equal (mv-nth 1 (rm08 addr r-w-x x86)) +;; (car (mv-nth 1 (rb (list addr) r-w-x x86)))))) (defun find-info-from-program-at-term-in-programmer-mode (thm mfc state) (declare (xargs :stobjs (state) :mode :program) @@ -783,12 +787,11 @@ programmer-level mode.

" ) (programmer-level-mode x86)) (equal (car (mv-nth 1 (rb (list addr) :x x86))) (nth (pos addr (create-canonical-address-list n prog-addr)) bytes))) - :hints (("Goal" :in-theory (e/d (program-at) + :hints (("Goal" :in-theory (e/d (program-at rb) (acl2::mv-nth-cons-meta - rm08-in-terms-of-rb - member-p-canonical-address-p-canonical-address-listp - rb)) - :use ((:instance rm08-in-terms-of-rb + rm08-to-rb + member-p-canonical-address-p-canonical-address-listp)) + :use ((:instance rm08-to-rb (r-w-x :x)) (:instance member-p-canonical-address-p-canonical-address-listp (e addr)) @@ -871,6 +874,26 @@ programmer-level mode.

" ) (theory 'minimal-theory)) :use ((:instance rb-in-terms-of-rb-subset-p))))) +(defthm combine-bytes-of-rb-of-1-address-in-programmer-level-mode + (implies (and (canonical-address-p addr) + (programmer-level-mode x86) + (x86p x86)) + (equal (combine-bytes (mv-nth 1 (rb (cons addr nil) :x x86))) + (car (mv-nth 1 (rb (cons addr nil) :x x86))))) + :hints (("Goal" :in-theory (e/d* (combine-bytes + rb rb-1 + memi) + (rm08-to-rb + byte-listp + mv-nth + create-canonical-address-list-1 + (zp) + rb-returns-no-error-programmer-level-mode + rb-returns-x86-programmer-level-mode + combine-bytes-rb-in-terms-of-rb-subset-p + rb-in-terms-of-nth-and-pos + rb-in-terms-of-rb-subset-p))))) + ;; ====================================================================== (globally-disable '(rb wb canonical-address-p program-at diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/common-system-level-utils.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/common-system-level-utils.lisp index 91e3e7d12fc..98263c3069f 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/common-system-level-utils.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/common-system-level-utils.lisp @@ -68,10 +68,13 @@ ;; Normalizing memory reads: -(local - (defthm dumb-integerp-of-mem-rewrite - (implies (x86p x86) - (integerp (xr :mem index x86))))) +;; (local +;; (defthm dumb-integerp-of-mem-rewrite +;; (implies (x86p x86) +;; (integerp (xr :mem index x86))))) + +;; All these functions open up to rb. +(in-theory (e/d (rm16 rm32 rm64) ())) (defthm mv-nth-2-rb-in-system-level-non-marking-mode (implies (and (not (page-structure-marking-mode x86)) @@ -88,81 +91,6 @@ (mv-nth 2 (las-to-pas l-addrs r-w-x (cpl x86) (double-rewrite x86))))) :hints (("Goal" :in-theory (e/d* (rb) (force (force)))))) -(defthm rm08-to-rb - (implies (and (x86p x86) - (force (canonical-address-p lin-addr))) - (equal (rm08 lin-addr r-w-x x86) - (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 1 lin-addr) r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)))) - :hints (("Goal" - :use ((:instance rb-and-rm08-in-programmer-level-mode (addr lin-addr))) - :in-theory (e/d* (rm08 rb ifix) - (rb-1 signed-byte-p - unsigned-byte-p - force (force)))))) - -(defthm rm16-to-rb - ;; Why don't we need (x86p x86) here? - (implies (and (force (canonical-address-p lin-addr)) - (force (canonical-address-p (+ 1 lin-addr)))) - (equal (rm16 lin-addr r-w-x x86) - (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 2 lin-addr) r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)))) - :hints (("Goal" - :in-theory (e/d* (rm16 rm08 ifix) - (cons-equal - signed-byte-p - unsigned-byte-p - bitops::logior-equal-0 - (:meta acl2::mv-nth-cons-meta) - force (force)))))) - -(defthm rm32-to-rb - (implies (and (force (canonical-address-p lin-addr)) - (force (canonical-address-p (+ 3 lin-addr))) - (x86p x86)) - (equal (rm32 lin-addr r-w-x x86) - (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 4 lin-addr) r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)))) - :hints (("Goal" - :in-theory (e/d* (rm32 rm08) - (signed-byte-p - unsigned-byte-p - bitops::logior-equal-0 - force (force)))))) - -(defthm rm64-to-rb - (implies (and (force (canonical-address-p lin-addr)) - (force (canonical-address-p (+ 7 lin-addr))) - (force (x86p x86))) - (equal (rm64 lin-addr r-w-x x86) - (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 8 lin-addr) r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)))) - :hints (("Goal" - :expand ((create-canonical-address-list 8 lin-addr) - (create-canonical-address-list 7 (+ 1 lin-addr)) - (create-canonical-address-list 6 (+ 2 lin-addr)) - (create-canonical-address-list 5 (+ 3 lin-addr))) - :in-theory (e/d* (rm64) - ((:linear bitops::logior-<-0-linear-2) - (:linear ash-monotone-2) - (:rewrite bitops::ash-<-0) - (:rewrite acl2::natp-when-integerp) - cons-equal - signed-byte-p - unsigned-byte-p - bitops::logior-equal-0 - (:meta acl2::mv-nth-cons-meta) - force (force)))))) - (defthm mv-nth-0-rb-and-mv-nth-0-las-to-pas-in-system-level-mode (implies (not (xr :programmer-level-mode 0 x86)) (equal (mv-nth 0 (rb l-addrs r-w-x x86)) @@ -173,62 +101,8 @@ ;; Normalizing memory writes: -(defthm wm08-to-wb - (implies (and (force (canonical-address-p lin-addr)) - (force (unsigned-byte-p 8 byte))) - (equal (wm08 lin-addr byte x86) - (wb (create-addr-bytes-alist - (create-canonical-address-list 1 lin-addr) - (list byte)) - x86))) - :hints (("Goal" :in-theory (e/d* (wm08 wvm08 wb) - (signed-byte-p - unsigned-byte-p - force (force)))))) - -(defthm wm16-to-wb - (implies (and (force (canonical-address-p lin-addr)) - (force (canonical-address-p (1+ lin-addr)))) - (equal (wm16 lin-addr word x86) - (wb (create-addr-bytes-alist - (create-canonical-address-list 2 lin-addr) - (byte-ify 2 word)) - x86))) - :hints (("Goal" :in-theory (e/d* (wm16 wb byte-ify) - (signed-byte-p - unsigned-byte-p - force (force)))))) - -(defthm wm32-to-wb - (implies (and (force (canonical-address-p lin-addr)) - (force (canonical-address-p (+ 3 lin-addr)))) - (equal (wm32 lin-addr dword x86) - (wb (create-addr-bytes-alist - (create-canonical-address-list 4 lin-addr) - (byte-ify 4 dword)) - x86))) - :hints (("Goal" :in-theory (e/d* (wm32 wb byte-ify) - (signed-byte-p - unsigned-byte-p - force (force)))))) - -(defthm wm64-to-wb - (implies (and (force (canonical-address-p lin-addr)) - (force (canonical-address-p (+ 7 lin-addr)))) - (equal (wm64 lin-addr qword x86) - (wb (create-addr-bytes-alist - (create-canonical-address-list 8 lin-addr) - (byte-ify 8 qword)) - x86))) - :hints (("Goal" - :expand ((create-canonical-address-list 8 lin-addr) - (create-canonical-address-list 7 (+ 1 lin-addr)) - (create-canonical-address-list 6 (+ 2 lin-addr)) - (create-canonical-address-list 5 (+ 3 lin-addr))) - :in-theory (e/d* (wm64 wb byte-ify) - (signed-byte-p - unsigned-byte-p - force (force)))))) +;; All these functions open up to wb. +(in-theory (e/d (wm16 wm32 wm64) ())) (defthm mv-nth-0-wb-and-mv-nth-0-las-to-pas-in-system-level-mode (implies (not (xr :programmer-level-mode 0 x86)) diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/gl-lemmas.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/gl-lemmas.lisp index 857d9b04d33..af5c6e3d31f 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/gl-lemmas.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/gl-lemmas.lisp @@ -128,41 +128,6 @@ ;; ====================================================================== -(def-gl-export rm32-rb-system-level-mode-proof-helper - :hyp (and (n08p a) - (n08p b) - (n08p c) - (n08p d)) - :concl (equal (logior a (ash b 8) (ash (logior c (ash d 8)) 16)) - (logior a (ash (logior b (ash (logior c (ash d 8)) 8)) 8))) - :g-bindings - (gl::auto-bindings - (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8)))) - -(def-gl-export rm64-to-rb-in-system-level-mode-helper - :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) - (n08p e) (n08p f) (n08p g) (n08p h)) - :concl (equal - (logior a - (ash (logior b (ash (logior c (ash d 8)) 8)) 8) - (ash (logior e (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 32)) - (logior - a - (ash (logior - b - (ash (logior - c - (ash (logior d - (ash - (logior e - (ash - (logior f - (ash (logior g (ash h 8)) 8)) 8)) 8)) 8)) 8)) 8))) - :g-bindings - (gl::auto-bindings - (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) - (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) - (def-gl-export rm-low-64-and-write-to-physical-memory-equal-helper-2 :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) (n08p e) (n08p f) (n08p g) (n08p h)) diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/physical-memory-utils.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/physical-memory-utils.lisp index ed4cd75035b..e62e0148531 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/physical-memory-utils.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/physical-memory-utils.lisp @@ -435,8 +435,7 @@ (write-to-physical-memory nth force - (force) - rm32-rb-system-level-mode-proof-helper + (force) member-p-cons acl2::commutativity-of-logior mv-nth-2-rcl-spec-16 diff --git a/books/projects/x86isa/proofs/wordCount/wc.acl2 b/books/projects/x86isa/proofs/wordCount/cert.acl2 similarity index 100% rename from books/projects/x86isa/proofs/wordCount/wc.acl2 rename to books/projects/x86isa/proofs/wordCount/cert.acl2 diff --git a/books/projects/x86isa/proofs/wordCount/wc.lisp b/books/projects/x86isa/proofs/wordCount/wc.lisp index e87ffe5170c..cabf0de733c 100644 --- a/books/projects/x86isa/proofs/wordCount/wc.lisp +++ b/books/projects/x86isa/proofs/wordCount/wc.lisp @@ -1,7 +1,7 @@ ;; AUTHOR: ;; Shilpi Goel -;; There are a lot of similar-looking theorems here that I plan to +;; There are a lot of similar-looking theorems here that I plan to ;; generate and prove automatically in the future. (in-package "X86ISA") @@ -427,6 +427,119 @@ (in-theory (e/d* (subset-p) (env-assumptions i64p))) +(i-am-here) + +(in-theory (e/d* () + ((:DEFINITION CREATE-ADDR-BYTES-ALIST) + (:TYPE-PRESCRIPTION XW) + (:DEFINITION CREATE-CANONICAL-ADDRESS-LIST) + (:REWRITE DEFAULT-+-2) + (:REWRITE DEFAULT-+-1) + (:DEFINITION ACONS) + (:REWRITE CONS-AND-CREATE-ADDR-BYTES-ALIST) + (:REWRITE GET-PREFIXES-OPENER-LEMMA-GROUP-4-PREFIX) + (:REWRITE GET-PREFIXES-OPENER-LEMMA-GROUP-3-PREFIX) + (:REWRITE GET-PREFIXES-OPENER-LEMMA-GROUP-2-PREFIX) + (:REWRITE GET-PREFIXES-OPENER-LEMMA-GROUP-1-PREFIX) + (:TYPE-PRESCRIPTION ACL2::|x < y => 0 < -x+y|) + (:DEFINITION BINARY-APPEND) + (:REWRITE ACL2::APPEND-WHEN-NOT-CONSP) + ;; (:REWRITE CDR-CREATE-CANONICAL-ADDRESS-LIST) + ;; (:REWRITE CANONICAL-ADDRESS-P-LIMITS-THM-0) + (:REWRITE ACL2::CDR-OF-APPEND-WHEN-CONSP) + ;; (:REWRITE CONSP-CREATE-ADDR-BYTES-ALIST) + (:REWRITE WB-NOT-CONSP-ADDR-LST) + ;; (:REWRITE CONSP-OF-CREATE-CANONICAL-ADDRESS-LIST) + (:TYPE-PRESCRIPTION CONSP-APPEND) + ;; (:REWRITE LOOP-PRECONDITIONS-WEIRD-RBP-RSP) + ;; (:REWRITE CANONICAL-ADDRESS-P-LIMITS-THM-1) + (:REWRITE ACL2::LOGHEAD-IDENTITY) + (:REWRITE ACL2::CONSP-WHEN-MEMBER-EQUAL-OF-ATOM-LISTP) + (:TYPE-PRESCRIPTION BITOPS::LOGTAIL-NATP) + ;; (:REWRITE COMBINE-BYTES-OF-RB-OF-1-ADDRESS-IN-PROGRAMMER-LEVEL-MODE) + (:REWRITE SUBSET-P-CDR-Y) + (:TYPE-PRESCRIPTION TRUE-LISTP-CREATE-CANONICAL-ADDRESS-LIST) + (:TYPE-PRESCRIPTION ACL2::|x < y => 0 < y-x|) + (:TYPE-PRESCRIPTION NATP-GET-PREFIXES) + ;; (:REWRITE DISJOINT-P-TWO-CREATE-CANONICAL-ADDRESS-LISTS-THM-0) + (:REWRITE CAR-CREATE-CANONICAL-ADDRESS-LIST) + (:TYPE-PRESCRIPTION CONSP-CREATE-ADDR-BYTES-ALIST) + ;; (:REWRITE DISJOINT-P-TWO-CREATE-CANONICAL-ADDRESS-LISTS-THM-1) + (:REWRITE LOGHEAD-OF-NON-INTEGERP) + (:REWRITE ACL2::CAR-OF-APPEND) + (:REWRITE ACL2::EQUAL-OF-BOOLEANS-REWRITE) + (:LINEAR RGFI-IS-I64P . 1) + (:LINEAR RGFI-IS-I64P . 2) + ;; (:REWRITE RB-IN-TERMS-OF-NTH-AND-POS) + (:REWRITE ACL2::CONSP-OF-APPEND) + (:REWRITE DEFAULT-<-1) + (:TYPE-PRESCRIPTION BYTE-IFY) + (:TYPE-PRESCRIPTION CONSP-CREATE-ADDR-BYTES-ALIST-IN-TERMS-OF-LEN) + (:REWRITE ACL2::LOGTAIL-IDENTITY) + (:REWRITE GREATER-LOGBITP-OF-UNSIGNED-BYTE-P . 2) + (:REWRITE BITOPS::UNSIGNED-BYTE-P-WHEN-UNSIGNED-BYTE-P-LESS) + (:REWRITE DEFAULT-UNARY-MINUS) + (:TYPE-PRESCRIPTION ACL2::TRUE-LISTP-APPEND) + (:TYPE-PRESCRIPTION BINARY-APPEND) + (:TYPE-PRESCRIPTION MSRI-IS-N64P) + (:REWRITE LOGHEAD-ZERO-SMALLER) + (:REWRITE DEFAULT-<-2) + (:DEFINITION LEN) + (:REWRITE ZF-SPEC-THM) + (:REWRITE UNSIGNED-BYTE-P-OF-LOGTAIL) + (:LINEAR RIP-IS-I48P . 2) + (:REWRITE PROGRAMMER-LEVEL-MODE-RM08-NO-ERROR) + (:REWRITE ACL2::EQUAL-CONSTANT-+) + (:LINEAR RIP-IS-I48P . 1) + (:REWRITE ACL2::ZP-WHEN-INTEGERP) + (:TYPE-PRESCRIPTION TRUE-LISTP-CREATE-ADDR-BYTES-ALIST) + (:REWRITE ACL2::IFIX-WHEN-NOT-INTEGERP) + (:REWRITE BITOPS::LOGBITP-NONZERO-OF-BIT) + (:REWRITE ACL2::COMMUTATIVITY-2-OF-+) + (:REWRITE RM08-VALUE-WHEN-ERROR) + (:REWRITE ACL2::DIFFERENCE-UNSIGNED-BYTE-P) + (:LINEAR MEMBER-P-POS-VALUE) + (:LINEAR MEMBER-P-POS-1-VALUE) + (:LINEAR ACL2::INDEX-OF-<-LEN) + (:REWRITE CONSP-BYTE-IFY) + (:REWRITE ACL2::ZP-WHEN-GT-0) + (:REWRITE RIGHT-SHIFT-TO-LOGTAIL) + (:TYPE-PRESCRIPTION BOOLEANP) + (:TYPE-PRESCRIPTION ACL2::BOOL->BIT$INLINE) + (:REWRITE BITOPS::BASIC-UNSIGNED-BYTE-P-OF-+) + (:REWRITE BITOPS::LOGBITP-WHEN-BITMASKP) + (:LINEAR MSRI-IS-N64P) + (:TYPE-PRESCRIPTION ADDR-BYTE-ALISTP-CREATE-ADDR-BYTES-ALIST) + (:REWRITE BITOPS::LOGTAIL-OF-LOGTAIL) + (:TYPE-PRESCRIPTION BITP) + (:TYPE-PRESCRIPTION ACL2::BITMASKP$INLINE) + ;; (:REWRITE GET-PREFIXES-OPENER-LEMMA-ZERO-CNT) + (:REWRITE N43P-GET-PREFIXES) + ;; (:REWRITE XW-XW-INTRA-SIMPLE-FIELD-SHADOW-WRITES) + ;; (:REWRITE X86-RUN-HALTED) + (:TYPE-PRESCRIPTION X86-DECODE-SIB-P) + (:TYPE-PRESCRIPTION ACL2::EXPT-TYPE-PRESCRIPTION-POSITIVE) + (:TYPE-PRESCRIPTION ACL2::EXPT-TYPE-PRESCRIPTION-NONZERO) + (:TYPE-PRESCRIPTION ACL2::EXPT-TYPE-PRESCRIPTION-INTEGERP) + (:REWRITE BITOPS::NORMALIZE-LOGBITP-WHEN-MODS-EQUAL) + (:REWRITE BITOPS::LOGBITP-OF-NEGATIVE-CONST) + (:REWRITE BITOPS::LOGBITP-OF-MASK) + (:REWRITE BITOPS::LOGBITP-OF-CONST) + (:REWRITE GREATER-LOGBITP-OF-UNSIGNED-BYTE-P . 1) + ;; (:REWRITE DISJOINT-P-SUBSET-P) + (:META BITOPS::OPEN-LOGBITP-OF-CONST-LITE-META) + (:TYPE-PRESCRIPTION N43P$INLINE) + ;; (:REWRITE X86-RUN-OPENER-NOT-MS-NOT-FAULT-ZP-N) + ))) + +(acl2::why x86-run-opener-not-ms-not-zp-n) +(acl2::why x86-fetch-decode-execute-opener) +(acl2::why get-prefixes-opener-lemma-no-prefix-byte) +(acl2::why rb-in-terms-of-nth-and-pos) +(acl2::why program-at-wb-disjoint) +(acl2::why member-p-canonical-address-listp) +(acl2::why rb-wb-disjoint) + (defthm effects-to-gc-no-call ;; push %rbp @@ -562,6 +675,9 @@ write-user-rflags) (wb-remove-duplicate-writes + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp force (force)))))) ;; ---------------------------------------------------------------------- diff --git a/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy-init.lisp b/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy-init.lisp index 04aa5721796..aa1a99be139 100644 --- a/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy-init.lisp +++ b/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy-init.lisp @@ -351,7 +351,7 @@ (:rewrite acl2::nfix-when-not-natp) (:rewrite acl2::nfix-when-natp) (:rewrite constant-upper-bound-of-logior-for-naturals) - (:linear combine-bytes-size-for-rm64-programmer-level-mode) + ;; (:linear combine-bytes-size-for-rm64-programmer-level-mode) (:rewrite acl2::natp-when-integerp) (:rewrite acl2::natp-when-gte-0) (:rewrite 4k-aligned-physical-address-helper) diff --git a/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy.lisp b/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy.lisp index 0db594d8b35..26879430df9 100644 --- a/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy.lisp +++ b/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy.lisp @@ -18,37 +18,37 @@ (in-theory ;; For the effects theorems: (e/d* (instruction-decoding-and-spec-rules - shr-spec - shr-spec-64 - sal/shl-spec - sal/shl-spec-64 - gpr-and-spec-1 - gpr-and-spec-4 - gpr-and-spec-8 - gpr-sub-spec-8 - gpr-or-spec-8 - gpr-xor-spec-4 - jcc/cmovcc/setcc-spec - top-level-opcode-execute - two-byte-opcode-decode-and-execute - x86-operand-from-modr/m-and-sib-bytes - x86-effective-addr - x86-effective-addr-from-sib - x86-operand-to-reg/mem - rr08 rr32 rr64 wr08 wr32 wr64 - rim08 rim32 rim64 - !flgi-undefined - write-user-rflags - - pos - mv-nth-0-las-to-pas-subset-p - member-p - subset-p - - rb-alt-wb-equal-in-system-level-mode) - - (rewire_dst_to_src-disable - rewire_dst_to_src-disable-more)))) + shr-spec + shr-spec-64 + sal/shl-spec + sal/shl-spec-64 + gpr-and-spec-1 + gpr-and-spec-4 + gpr-and-spec-8 + gpr-sub-spec-8 + gpr-or-spec-8 + gpr-xor-spec-4 + jcc/cmovcc/setcc-spec + top-level-opcode-execute + two-byte-opcode-decode-and-execute + x86-operand-from-modr/m-and-sib-bytes + x86-effective-addr + x86-effective-addr-from-sib + x86-operand-to-reg/mem + rr08 rr32 rr64 wr08 wr32 wr64 + rim08 rim32 rim64 + !flgi-undefined + write-user-rflags + + pos + mv-nth-0-las-to-pas-subset-p + member-p + subset-p + + rb-alt-wb-equal-in-system-level-mode) + + (rewire_dst_to_src-disable + rewire_dst_to_src-disable-more)))) ;; Argh, ACL2's default ancestors-check is killing me --- it prevents ;; x86-fetch-decode-execute from opening up (because the first hyp of @@ -61,49 +61,49 @@ (defthmd rewrite-to-pml4-table-entry-addr (implies (and (x86-state-okp x86) - (source-addresses-ok-p x86) - (destination-addresses-ok-p x86)) + (source-addresses-ok-p x86) + (destination-addresses-ok-p x86)) (and (equal (logior (logand -4096 (logext 64 (xr :ctr *cr3* x86))) - (logand 4088 - (loghead 28 (logtail 36 (xr :rgf *rdi* x86))))) + (logand 4088 + (loghead 28 (logtail 36 (xr :rgf *rdi* x86))))) (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) (equal (logior (logand -4096 (logext 64 (xr :ctr *cr3* x86))) - (logand 4088 - (loghead 28 (logtail 36 (xr :rgf *rsi* x86))))) + (logand 4088 + (loghead 28 (logtail 36 (xr :rgf *rsi* x86))))) (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86)))))) (defthmd rewrite-to-page-dir-ptr-table-entry-addr (implies (and (x86-state-okp x86) - (source-addresses-ok-p x86) - (source-pml4te-ok-p x86) - (destination-addresses-ok-p x86) - (destination-pml4te-ok-p x86)) + (source-addresses-ok-p x86) + (source-pml4te-ok-p x86) + (destination-addresses-ok-p x86) + (destination-pml4te-ok-p x86)) (and (equal (logior (logand 4088 - (loghead 32 (logtail 27 (xr :rgf *rdi* x86)))) + (loghead 32 (logtail 27 (xr :rgf *rdi* x86)))) (ash (loghead - 40 - (logtail - 12 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (logior - (logand -4096 (logext 64 (xr :ctr *cr3* x86))) - (logand 4088 - (loghead 28 (logtail 36 (xr :rgf *rdi* x86)))))) - :r x86))))) + 40 + (logtail + 12 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (logior + (logand -4096 (logext 64 (xr :ctr *cr3* x86))) + (logand 4088 + (loghead 28 (logtail 36 (xr :rgf *rdi* x86)))))) + :r x86))))) 12)) (page-dir-ptr-table-entry-addr (xr :rgf *rdi* x86) @@ -111,23 +111,23 @@ (equal (logior (logand 4088 - (loghead 32 (logtail 27 (xr :rgf *rsi* x86)))) + (loghead 32 (logtail 27 (xr :rgf *rsi* x86)))) (ash (loghead - 40 - (logtail - 12 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (logior - (logand -4096 (logext 64 (xr :ctr *cr3* x86))) - (logand 4088 - (loghead 28 (logtail 36 (xr :rgf *rsi* x86)))))) - :r x86))))) + 40 + (logtail + 12 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (logior + (logand -4096 (logext 64 (xr :ctr *cr3* x86))) + (logand 4088 + (loghead 28 (logtail 36 (xr :rgf *rsi* x86)))))) + :r x86))))) 12)) (page-dir-ptr-table-entry-addr (xr :rgf *rsi* x86) @@ -221,510 +221,510 @@ (xw :rgf *rdx* (logand - 4503598553628672 - (logior - (logand - -4503598553628673 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86))))) - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))) + 4503598553628672 + (logior + (logand + -4503598553628673 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86))))) + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))) (xw - :rgf *rsp* (+ 8 (xr :rgf *rsp* x86)) - (xw - :rgf *rsi* 0 - (xw - :rgf *rdi* - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (xw - :rgf *r8* 1099511627775 - (xw - :rgf *r9* - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (xw - :rip 0 - (logext - 64 - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list 8 (xr :rgf *rsp* x86)) - :r x86)))) - (xw - :undef 0 (+ 46 (nfix (xr :undef 0 x86))) - (!flgi - *cf* - (bool->bit - (< - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (logior - (logand - 18442240475155922943 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86)))))))) - (!flgi - *pf* - (pf-spec64 - (loghead - 64 - (+ - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (- - (logand - 4503598553628672 - (logior - (logand - -4503598553628673 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86))))) - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))))))) - (!flgi - *af* - (sub-af-spec64 - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (logior - (logand - 18442240475155922943 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))) - (!flgi - *zf* 1 - (!flgi - *sf* - (sf-spec64 - (loghead - 64 - (+ - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (- - (logand - 4503598553628672 - (logior - (logand - -4503598553628673 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86))))) - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))))))) - (!flgi - *of* - (of-spec64 - (+ - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (- - (logand - 4503598553628672 - (logior - (logand - -4503598553628673 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86))))) - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86)))))))))) - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list 8 (xr :rgf *rsp* x86)) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 40 (+ 206 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 15 (+ 190 (xr :rip 0 x86))) - :x 0 - (mv-nth - 1 - (wb - (create-addr-bytes-alist - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - (byte-ify - 8 - (logior - (logand - 18442240475155922943 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))) - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 6 (+ 184 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 40 (+ 144 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 3 (+ 140 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr - (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 32 (+ 108 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 18 (+ 86 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 40 (+ 46 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 4 (+ 38 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr - (xr :rgf *rdi* x86) - (pml4-table-base-addr x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 25 (+ 13 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (+ -24 (xr :rgf *rsp* x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 5 (+ 8 (xr :rip 0 x86))) - :x 0 - (mv-nth - 1 - (wb - (create-addr-bytes-alist - (create-canonical-address-list - 8 - (+ -24 (xr :rgf *rsp* x86))) - (byte-ify - 8 - (xr :ctr *cr3* x86))) - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 (xr :rip 0 x86)) - :x 0 - x86)))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + :rgf *rsp* (+ 8 (xr :rgf *rsp* x86)) + (xw + :rgf *rsi* 0 + (xw + :rgf *rdi* + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (xw + :rgf *r8* 1099511627775 + (xw + :rgf *r9* + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (xw + :rip 0 + (logext + 64 + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list 8 (xr :rgf *rsp* x86)) + :r x86)))) + (xw + :undef 0 (+ 46 (nfix (xr :undef 0 x86))) + (!flgi + *cf* + (bool->bit + (< + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (logior + (logand + 18442240475155922943 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86)))))))) + (!flgi + *pf* + (pf-spec64 + (loghead + 64 + (+ + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (- + (logand + 4503598553628672 + (logior + (logand + -4503598553628673 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86))))) + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))))))) + (!flgi + *af* + (sub-af-spec64 + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (logior + (logand + 18442240475155922943 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))) + (!flgi + *zf* 1 + (!flgi + *sf* + (sf-spec64 + (loghead + 64 + (+ + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (- + (logand + 4503598553628672 + (logior + (logand + -4503598553628673 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86))))) + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))))))) + (!flgi + *of* + (of-spec64 + (+ + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (- + (logand + 4503598553628672 + (logior + (logand + -4503598553628673 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86))))) + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86)))))))))) + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list 8 (xr :rgf *rsp* x86)) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 40 (+ 206 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 15 (+ 190 (xr :rip 0 x86))) + :x 0 + (mv-nth + 1 + (wb + (create-addr-bytes-alist + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (byte-ify + 8 + (logior + (logand + 18442240475155922943 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))) + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 6 (+ 184 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 40 (+ 144 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 3 (+ 140 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr + (xr :rgf *rsi* x86) + (pml4-table-base-addr x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 32 (+ 108 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 18 (+ 86 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 40 (+ 46 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 4 (+ 38 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr + (xr :rgf *rdi* x86) + (pml4-table-base-addr x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 25 (+ 13 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (+ -24 (xr :rgf *rsp* x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 5 (+ 8 (xr :rip 0 x86))) + :x 0 + (mv-nth + 1 + (wb + (create-addr-bytes-alist + (create-canonical-address-list + 8 + (+ -24 (xr :rgf *rsp* x86))) + (byte-ify + 8 + (xr :ctr *cr3* x86))) + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 (xr :rip 0 x86)) + :x 0 + x86)))))))))))))))))))))))))))))))))))))))))))))))))))))))))) :hints (("Goal" - :expand ((:free (x) (hide x)) - (rewire_dst_to_src-effects-preconditions x86)) - :use ((:instance x86-run-plus - (n1 (rewire_dst_to_src-clk-1-to-45)) - (n2 (rewire_dst_to_src-clk-46-to-58))) - (:instance rewire_dst_to_src-effects-1-to-45-instructions) - (:instance rewire_dst_to_src-effects-46-to-58-instructions) - (:instance rewrite-to-pml4-table-entry-addr) - (:instance rewrite-to-page-dir-ptr-table-entry-addr)) - :in-theory (union-theories - '(program-alt-ok-p-and-program-ok-p - natp - (natp) - rewire_dst_to_src-clk - rewire_dst_to_src-clk-1-to-45 - rewire_dst_to_src-clk-46-to-58) - (theory 'minimal-theory))))) + :expand ((:free (x) (hide x)) + (rewire_dst_to_src-effects-preconditions x86)) + :use ((:instance x86-run-plus + (n1 (rewire_dst_to_src-clk-1-to-45)) + (n2 (rewire_dst_to_src-clk-46-to-58))) + (:instance rewire_dst_to_src-effects-1-to-45-instructions) + (:instance rewire_dst_to_src-effects-46-to-58-instructions) + (:instance rewrite-to-pml4-table-entry-addr) + (:instance rewrite-to-page-dir-ptr-table-entry-addr)) + :in-theory (union-theories + '(program-alt-ok-p-and-program-ok-p + natp + (natp) + rewire_dst_to_src-clk + rewire_dst_to_src-clk-1-to-45 + rewire_dst_to_src-clk-46-to-58) + (theory 'minimal-theory))))) (in-theory (e/d () ((rewire_dst_to_src-clk) rewire_dst_to_src-clk))) @@ -747,302 +747,302 @@ (local (defthmd program-at-alt-in-final-state-==-program-at-in-final-state-helper-1 (implies (rewire_dst_to_src-effects-preconditions x86) - (and - (not - (mv-nth 0 - (las-to-pas - (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - :x (cpl x86) (x86-run (rewire_dst_to_src-clk) x86)))) - (equal - (mv-nth 1 - (las-to-pas - (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - :x (cpl x86) (x86-run (rewire_dst_to_src-clk) x86))) - (mv-nth 1 - (las-to-pas - (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - :x (cpl x86) x86))))) + (and + (not + (mv-nth 0 + (las-to-pas + (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + :x (cpl x86) (x86-run (rewire_dst_to_src-clk) x86)))) + (equal + (mv-nth 1 + (las-to-pas + (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + :x (cpl x86) (x86-run (rewire_dst_to_src-clk) x86))) + (mv-nth 1 + (las-to-pas + (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + :x (cpl x86) x86))))) :hints (("Goal" - :do-not-induct t - :hands-off (x86-run) - :use ((:instance rewire_dst_to_src-effects)) - :in-theory (e/d* (disjoint-p-all-translation-governing-addresses-subset-p) - ( - ;; x86-state-okp - ;; program-ok-p - ;; stack-ok-p - ;; program-and-stack-no-interfere-p - ;; source-addresses-ok-p - ;; source-pml4te-ok-p - ;; source-pdpte-ok-p - source-pml4te-and-stack-no-interfere-p - ;; source-pml4te-and-program-no-interfere-p - source-pdpte-and-stack-no-interfere-p - ;; source-pdpte-and-program-no-interfere-p - source-pdpte-and-source-pml4e-no-interfere-p - ;; destination-addresses-ok-p - ;; destination-pml4te-ok-p - ;; destination-pdpte-ok-p - destination-pml4te-and-stack-no-interfere-p - ;; destination-pml4te-and-program-no-interfere-p - destination-pml4te-and-source-pml4te-no-interfere-p - destination-pml4te-and-source-pdpte-no-interfere-p - destination-pdpte-and-source-pml4e-no-interfere-p - destination-pdpte-and-source-pdpte-no-interfere-p - destination-pdpte-and-destination-pml4te-no-interfere-p - destination-pdpte-and-stack-no-interfere-p - ;; destination-pdpte-and-program-no-interfere-p - return-address-ok-p - stack-containing-return-address-ok-p - ;; stack-containing-return-address-and-program-no-interfere-p - stack-containing-return-address-and-source-pml4e-no-interfere-p - stack-containing-return-address-and-source-pdpte-no-interfere-p - stack-containing-return-address-and-destination-pml4e-no-interfere-p - stack-containing-return-address-and-destination-pdpte-no-interfere-p - stack-containing-return-address-and-rest-of-the-stack-no-interfere-p - - create-canonical-address-list - (:rewrite program-at-values-and-!flgi) - (:rewrite get-prefixes-opener-lemma-group-4-prefix-in-marking-mode) - (:rewrite rb-in-terms-of-rb-subset-p-in-system-level-mode) - (:rewrite get-prefixes-opener-lemma-group-3-prefix-in-marking-mode) - (:rewrite get-prefixes-opener-lemma-group-2-prefix-in-marking-mode) - (:rewrite get-prefixes-opener-lemma-group-1-prefix-in-marking-mode) - (:rewrite mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) - (:rewrite mv-nth-2-rb-in-system-level-non-marking-mode) - (:rewrite rb-returns-x86-programmer-level-mode) - (:linear rm-low-64-logand-logior-helper-1) - (:definition n64p$inline) - (:type-prescription xlate-equiv-memory) - (:rewrite program-at-alt-wb-disjoint-in-system-level-mode) - (:type-prescription natp-page-dir-ptr-table-entry-addr) - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs - mv-nth-2-las-to-pas-system-level-non-marking-mode - (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) - (:rewrite acl2::cdr-of-append-when-consp) - (:rewrite acl2::car-of-append) - (:rewrite acl2::consp-of-append) - (:rewrite acl2::append-atom-under-list-equiv) - (:rewrite int-lists-in-seq-p-and-append) - (:type-prescription binary-append) - (:rewrite xr-fault-wb-in-system-level-mode) - (:type-prescription n01p-page-size) - (:type-prescription member-p-physical-address-p-physical-address-listp) - (:rewrite acl2::right-cancellation-for-+) - (:type-prescription member-p-physical-address-p) - (:rewrite acl2::append-singleton-under-set-equiv) - (:rewrite rewrite-rb-to-rb-alt) - (:rewrite acl2::loghead-identity) - (:definition subset-p) - (:rewrite - infer-disjointness-with-all-translation-governing-addresses-from-gather-all-paging-structure-qword-addresses-with-disjoint-p$) - (:meta acl2::mv-nth-cons-meta) - (:rewrite bitops::loghead-of-loghead-2) - (:type-prescription member-p) - (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) - (:rewrite member-p-canonical-address-listp) - (:rewrite right-shift-to-logtail) - (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) - (:type-prescription binary-logand) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:rewrite mv-nth-1-las-to-pas-subset-p) - (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) - (:rewrite - int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) - (:type-prescription int-lists-in-seq-p) - (:definition int-lists-in-seq-p) - (:rewrite xw-xw-intra-simple-field-shadow-writes) - (:rewrite page-dir-ptr-table-entry-addr-is-a-multiple-of-8) - (:rewrite gl::nfix-natp))))))) + :do-not-induct t + :hands-off (x86-run) + :use ((:instance rewire_dst_to_src-effects)) + :in-theory (e/d* (disjoint-p-all-translation-governing-addresses-subset-p) + ( + ;; x86-state-okp + ;; program-ok-p + ;; stack-ok-p + ;; program-and-stack-no-interfere-p + ;; source-addresses-ok-p + ;; source-pml4te-ok-p + ;; source-pdpte-ok-p + source-pml4te-and-stack-no-interfere-p + ;; source-pml4te-and-program-no-interfere-p + source-pdpte-and-stack-no-interfere-p + ;; source-pdpte-and-program-no-interfere-p + source-pdpte-and-source-pml4e-no-interfere-p + ;; destination-addresses-ok-p + ;; destination-pml4te-ok-p + ;; destination-pdpte-ok-p + destination-pml4te-and-stack-no-interfere-p + ;; destination-pml4te-and-program-no-interfere-p + destination-pml4te-and-source-pml4te-no-interfere-p + destination-pml4te-and-source-pdpte-no-interfere-p + destination-pdpte-and-source-pml4e-no-interfere-p + destination-pdpte-and-source-pdpte-no-interfere-p + destination-pdpte-and-destination-pml4te-no-interfere-p + destination-pdpte-and-stack-no-interfere-p + ;; destination-pdpte-and-program-no-interfere-p + return-address-ok-p + stack-containing-return-address-ok-p + ;; stack-containing-return-address-and-program-no-interfere-p + stack-containing-return-address-and-source-pml4e-no-interfere-p + stack-containing-return-address-and-source-pdpte-no-interfere-p + stack-containing-return-address-and-destination-pml4e-no-interfere-p + stack-containing-return-address-and-destination-pdpte-no-interfere-p + stack-containing-return-address-and-rest-of-the-stack-no-interfere-p + + create-canonical-address-list + (:rewrite program-at-values-and-!flgi) + (:rewrite get-prefixes-opener-lemma-group-4-prefix-in-marking-mode) + (:rewrite rb-in-terms-of-rb-subset-p-in-system-level-mode) + (:rewrite get-prefixes-opener-lemma-group-3-prefix-in-marking-mode) + (:rewrite get-prefixes-opener-lemma-group-2-prefix-in-marking-mode) + (:rewrite get-prefixes-opener-lemma-group-1-prefix-in-marking-mode) + (:rewrite mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) + (:rewrite mv-nth-2-rb-in-system-level-non-marking-mode) + (:rewrite rb-returns-x86-programmer-level-mode) + (:linear rm-low-64-logand-logior-helper-1) + (:definition n64p$inline) + (:type-prescription xlate-equiv-memory) + (:rewrite program-at-alt-wb-disjoint-in-system-level-mode) + (:type-prescription natp-page-dir-ptr-table-entry-addr) + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs + mv-nth-2-las-to-pas-system-level-non-marking-mode + (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) + (:rewrite acl2::cdr-of-append-when-consp) + (:rewrite acl2::car-of-append) + (:rewrite acl2::consp-of-append) + (:rewrite acl2::append-atom-under-list-equiv) + (:rewrite int-lists-in-seq-p-and-append) + (:type-prescription binary-append) + (:rewrite xr-fault-wb-in-system-level-mode) + (:type-prescription n01p-page-size) + (:type-prescription member-p-physical-address-p-physical-address-listp) + (:rewrite acl2::right-cancellation-for-+) + (:type-prescription member-p-physical-address-p) + (:rewrite acl2::append-singleton-under-set-equiv) + (:rewrite rewrite-rb-to-rb-alt) + (:rewrite acl2::loghead-identity) + (:definition subset-p) + (:rewrite + infer-disjointness-with-all-translation-governing-addresses-from-gather-all-paging-structure-qword-addresses-with-disjoint-p$) + (:meta acl2::mv-nth-cons-meta) + (:rewrite bitops::loghead-of-loghead-2) + (:type-prescription member-p) + (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) + (:rewrite member-p-canonical-address-listp) + (:rewrite right-shift-to-logtail) + (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) + (:type-prescription binary-logand) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:rewrite mv-nth-1-las-to-pas-subset-p) + (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) + (:rewrite + int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) + (:type-prescription int-lists-in-seq-p) + (:definition int-lists-in-seq-p) + (:rewrite xw-xw-intra-simple-field-shadow-writes) + (:rewrite page-dir-ptr-table-entry-addr-is-a-multiple-of-8) + (:rewrite gl::nfix-natp))))))) (local (defthmd program-at-alt-in-final-state-==-program-at-in-final-state-helper-2 (implies (rewire_dst_to_src-effects-preconditions x86) - (disjoint-p - ;; disjoint-p$ - (mv-nth 1 - (las-to-pas (create-canonical-address-list 272 (xr :rip 0 x86)) - :x (cpl x86) - (x86-run (rewire_dst_to_src-clk) x86))) - (open-qword-paddr-list (gather-all-paging-structure-qword-addresses - (x86-run (rewire_dst_to_src-clk) x86))))) + (disjoint-p + ;; disjoint-p$ + (mv-nth 1 + (las-to-pas (create-canonical-address-list 272 (xr :rip 0 x86)) + :x (cpl x86) + (x86-run (rewire_dst_to_src-clk) x86))) + (open-qword-paddr-list (gather-all-paging-structure-qword-addresses + (x86-run (rewire_dst_to_src-clk) x86))))) :hints (("Goal" - :do-not-induct t - :hands-off (x86-run) - :use ((:instance rewire_dst_to_src-effects) - (:instance program-at-alt-in-final-state-==-program-at-in-final-state-helper-1)) - :in-theory (e/d* (page-size) - ( - ;; x86-state-okp - ;; program-ok-p - ;; stack-ok-p - ;; program-and-stack-no-interfere-p - ;; source-addresses-ok-p - ;; source-pml4te-ok-p - ;; source-pdpte-ok-p - source-pml4te-and-stack-no-interfere-p - ;; source-pml4te-and-program-no-interfere-p - source-pdpte-and-stack-no-interfere-p - ;; source-pdpte-and-program-no-interfere-p - source-pdpte-and-source-pml4e-no-interfere-p - ;; destination-addresses-ok-p - ;; destination-pml4te-ok-p - ;; destination-pdpte-ok-p - destination-pml4te-and-stack-no-interfere-p - ;; destination-pml4te-and-program-no-interfere-p - destination-pml4te-and-source-pml4te-no-interfere-p - destination-pml4te-and-source-pdpte-no-interfere-p - destination-pdpte-and-source-pml4e-no-interfere-p - destination-pdpte-and-source-pdpte-no-interfere-p - destination-pdpte-and-destination-pml4te-no-interfere-p - destination-pdpte-and-stack-no-interfere-p - ;; destination-pdpte-and-program-no-interfere-p - return-address-ok-p - stack-containing-return-address-ok-p - ;; stack-containing-return-address-and-program-no-interfere-p - stack-containing-return-address-and-source-pml4e-no-interfere-p - stack-containing-return-address-and-source-pdpte-no-interfere-p - stack-containing-return-address-and-destination-pml4e-no-interfere-p - stack-containing-return-address-and-destination-pdpte-no-interfere-p - stack-containing-return-address-and-rest-of-the-stack-no-interfere-p - - create-canonical-address-list - (:rewrite program-at-values-and-!flgi) - (:rewrite get-prefixes-opener-lemma-group-4-prefix-in-marking-mode) - (:rewrite rb-in-terms-of-rb-subset-p-in-system-level-mode) - (:rewrite get-prefixes-opener-lemma-group-3-prefix-in-marking-mode) - (:rewrite get-prefixes-opener-lemma-group-2-prefix-in-marking-mode) - (:rewrite get-prefixes-opener-lemma-group-1-prefix-in-marking-mode) - (:rewrite mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) - (:rewrite mv-nth-2-rb-in-system-level-non-marking-mode) - (:rewrite rb-returns-x86-programmer-level-mode) - (:linear rm-low-64-logand-logior-helper-1) - (:definition n64p$inline) - (:type-prescription xlate-equiv-memory) - (:rewrite program-at-alt-wb-disjoint-in-system-level-mode) - (:type-prescription natp-page-dir-ptr-table-entry-addr) - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs - mv-nth-2-las-to-pas-system-level-non-marking-mode - (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) - (:rewrite acl2::cdr-of-append-when-consp) - (:rewrite acl2::car-of-append) - (:rewrite acl2::consp-of-append) - (:rewrite acl2::append-atom-under-list-equiv) - (:rewrite int-lists-in-seq-p-and-append) - (:type-prescription binary-append) - (:rewrite xr-fault-wb-in-system-level-mode) - (:type-prescription n01p-page-size) - (:type-prescription member-p-physical-address-p-physical-address-listp) - (:rewrite acl2::right-cancellation-for-+) - (:type-prescription member-p-physical-address-p) - (:rewrite acl2::append-singleton-under-set-equiv) - (:rewrite rewrite-rb-to-rb-alt) - (:rewrite acl2::loghead-identity) - (:definition subset-p) - (:rewrite - infer-disjointness-with-all-translation-governing-addresses-from-gather-all-paging-structure-qword-addresses-with-disjoint-p$) - (:meta acl2::mv-nth-cons-meta) - (:rewrite bitops::loghead-of-loghead-2) - (:type-prescription member-p) - (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) - (:rewrite member-p-canonical-address-listp) - (:rewrite right-shift-to-logtail) - (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) - (:type-prescription binary-logand) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:rewrite mv-nth-1-las-to-pas-subset-p) - (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) - (:rewrite - int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) - (:type-prescription int-lists-in-seq-p) - (:definition int-lists-in-seq-p) - (:rewrite xw-xw-intra-simple-field-shadow-writes) - (:rewrite page-dir-ptr-table-entry-addr-is-a-multiple-of-8) - (:rewrite gl::nfix-natp))))))) + :do-not-induct t + :hands-off (x86-run) + :use ((:instance rewire_dst_to_src-effects) + (:instance program-at-alt-in-final-state-==-program-at-in-final-state-helper-1)) + :in-theory (e/d* (page-size) + ( + ;; x86-state-okp + ;; program-ok-p + ;; stack-ok-p + ;; program-and-stack-no-interfere-p + ;; source-addresses-ok-p + ;; source-pml4te-ok-p + ;; source-pdpte-ok-p + source-pml4te-and-stack-no-interfere-p + ;; source-pml4te-and-program-no-interfere-p + source-pdpte-and-stack-no-interfere-p + ;; source-pdpte-and-program-no-interfere-p + source-pdpte-and-source-pml4e-no-interfere-p + ;; destination-addresses-ok-p + ;; destination-pml4te-ok-p + ;; destination-pdpte-ok-p + destination-pml4te-and-stack-no-interfere-p + ;; destination-pml4te-and-program-no-interfere-p + destination-pml4te-and-source-pml4te-no-interfere-p + destination-pml4te-and-source-pdpte-no-interfere-p + destination-pdpte-and-source-pml4e-no-interfere-p + destination-pdpte-and-source-pdpte-no-interfere-p + destination-pdpte-and-destination-pml4te-no-interfere-p + destination-pdpte-and-stack-no-interfere-p + ;; destination-pdpte-and-program-no-interfere-p + return-address-ok-p + stack-containing-return-address-ok-p + ;; stack-containing-return-address-and-program-no-interfere-p + stack-containing-return-address-and-source-pml4e-no-interfere-p + stack-containing-return-address-and-source-pdpte-no-interfere-p + stack-containing-return-address-and-destination-pml4e-no-interfere-p + stack-containing-return-address-and-destination-pdpte-no-interfere-p + stack-containing-return-address-and-rest-of-the-stack-no-interfere-p + + create-canonical-address-list + (:rewrite program-at-values-and-!flgi) + (:rewrite get-prefixes-opener-lemma-group-4-prefix-in-marking-mode) + (:rewrite rb-in-terms-of-rb-subset-p-in-system-level-mode) + (:rewrite get-prefixes-opener-lemma-group-3-prefix-in-marking-mode) + (:rewrite get-prefixes-opener-lemma-group-2-prefix-in-marking-mode) + (:rewrite get-prefixes-opener-lemma-group-1-prefix-in-marking-mode) + (:rewrite mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) + (:rewrite mv-nth-2-rb-in-system-level-non-marking-mode) + (:rewrite rb-returns-x86-programmer-level-mode) + (:linear rm-low-64-logand-logior-helper-1) + (:definition n64p$inline) + (:type-prescription xlate-equiv-memory) + (:rewrite program-at-alt-wb-disjoint-in-system-level-mode) + (:type-prescription natp-page-dir-ptr-table-entry-addr) + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs + mv-nth-2-las-to-pas-system-level-non-marking-mode + (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) + (:rewrite acl2::cdr-of-append-when-consp) + (:rewrite acl2::car-of-append) + (:rewrite acl2::consp-of-append) + (:rewrite acl2::append-atom-under-list-equiv) + (:rewrite int-lists-in-seq-p-and-append) + (:type-prescription binary-append) + (:rewrite xr-fault-wb-in-system-level-mode) + (:type-prescription n01p-page-size) + (:type-prescription member-p-physical-address-p-physical-address-listp) + (:rewrite acl2::right-cancellation-for-+) + (:type-prescription member-p-physical-address-p) + (:rewrite acl2::append-singleton-under-set-equiv) + (:rewrite rewrite-rb-to-rb-alt) + (:rewrite acl2::loghead-identity) + (:definition subset-p) + (:rewrite + infer-disjointness-with-all-translation-governing-addresses-from-gather-all-paging-structure-qword-addresses-with-disjoint-p$) + (:meta acl2::mv-nth-cons-meta) + (:rewrite bitops::loghead-of-loghead-2) + (:type-prescription member-p) + (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) + (:rewrite member-p-canonical-address-listp) + (:rewrite right-shift-to-logtail) + (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) + (:type-prescription binary-logand) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:rewrite mv-nth-1-las-to-pas-subset-p) + (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) + (:rewrite + int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) + (:type-prescription int-lists-in-seq-p) + (:definition int-lists-in-seq-p) + (:rewrite xw-xw-intra-simple-field-shadow-writes) + (:rewrite page-dir-ptr-table-entry-addr-is-a-multiple-of-8) + (:rewrite gl::nfix-natp))))))) (local (defthmd program-at-alt-in-final-state-==-program-at-in-final-state-helper-3 (implies (rewire_dst_to_src-effects-preconditions x86) - (disjoint-p$ - (mv-nth 1 - (las-to-pas (create-canonical-address-list 272 (xr :rip 0 x86)) - :x (cpl x86) - (x86-run (rewire_dst_to_src-clk) x86))) - (open-qword-paddr-list (gather-all-paging-structure-qword-addresses - (x86-run (rewire_dst_to_src-clk) x86))))) + (disjoint-p$ + (mv-nth 1 + (las-to-pas (create-canonical-address-list 272 (xr :rip 0 x86)) + :x (cpl x86) + (x86-run (rewire_dst_to_src-clk) x86))) + (open-qword-paddr-list (gather-all-paging-structure-qword-addresses + (x86-run (rewire_dst_to_src-clk) x86))))) :hints (("Goal" - :do-not-induct t - :hands-off (x86-run disjoint-p) - :use ((:instance program-at-alt-in-final-state-==-program-at-in-final-state-helper-2)) - :in-theory (e/d* (disjoint-p$) - (rewire_dst_to_src-effects-preconditions)))))) + :do-not-induct t + :hands-off (x86-run disjoint-p) + :use ((:instance program-at-alt-in-final-state-==-program-at-in-final-state-helper-2)) + :in-theory (e/d* (disjoint-p$) + (rewire_dst_to_src-effects-preconditions)))))) ;; ====================================================================== (defthmd rewire_dst_to_src-effects-preconditions-and-ms-fault-programmer-level-and-marking-mode-fields (implies (rewire_dst_to_src-effects-preconditions x86) - (and (equal (xr :ms 0 x86) nil) - (equal (xr :fault 0 x86) nil) - (equal (xr :programmer-level-mode 0 x86) nil) - (equal (xr :page-structure-marking-mode 0 x86) t)))) + (and (equal (xr :ms 0 x86) nil) + (equal (xr :fault 0 x86) nil) + (equal (xr :programmer-level-mode 0 x86) nil) + (equal (xr :page-structure-marking-mode 0 x86) t)))) (defthmd fault-from-final-state (implies (rewire_dst_to_src-effects-preconditions x86) - (equal (xr :fault 0 (x86-run (rewire_dst_to_src-clk) x86)) - (xr :fault 0 x86))) + (equal (xr :fault 0 (x86-run (rewire_dst_to_src-clk) x86)) + (xr :fault 0 x86))) :hints (("Goal" - :do-not '(preprocess) - :use ((:instance rewire_dst_to_src-effects)) - :hands-off (x86-run) - :in-theory (e/d* - (disjoint-p-all-translation-governing-addresses-subset-p) - (x86-fetch-decode-execute-opener-in-marking-mode - mv-nth-0-rb-and-mv-nth-0-las-to-pas-in-system-level-mode - mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures - two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas - combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence - mv-nth-2-las-to-pas-system-level-non-marking-mode - mv-nth-2-get-prefixes-alt-no-prefix-byte - rm08-to-rb - rewrite-rb-to-rb-alt - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 - unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs - subset-p - (:meta acl2::mv-nth-cons-meta) - create-canonical-address-list - acl2::loghead-identity - n64p$inline - (:r greater-logbitp-of-unsigned-byte-p . 2) - xr-fault-wb-in-system-level-mode - xw-xw-intra-simple-field-shadow-writes - unsigned-byte-p-of-loghead - r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors - canonical-address-p-pml4-table-entry-addr-to-c-program-optimized-form - right-shift-to-logtail - bitops::loghead-of-loghead-2 - bitops::logand-with-bitmask - (:linear rm-low-64-logand-logior-helper-1) - (:t binary-logior) - (:t binary-logand) - force (force)))))) + :do-not '(preprocess) + :use ((:instance rewire_dst_to_src-effects)) + :hands-off (x86-run) + :in-theory (e/d* + (disjoint-p-all-translation-governing-addresses-subset-p) + (x86-fetch-decode-execute-opener-in-marking-mode + mv-nth-0-rb-and-mv-nth-0-las-to-pas-in-system-level-mode + mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures + two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas + combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence + mv-nth-2-las-to-pas-system-level-non-marking-mode + mv-nth-2-get-prefixes-alt-no-prefix-byte + rm08-to-rb + rewrite-rb-to-rb-alt + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 + unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs + subset-p + (:meta acl2::mv-nth-cons-meta) + create-canonical-address-list + acl2::loghead-identity + n64p$inline + (:r greater-logbitp-of-unsigned-byte-p . 2) + xr-fault-wb-in-system-level-mode + xw-xw-intra-simple-field-shadow-writes + unsigned-byte-p-of-loghead + r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors + canonical-address-p-pml4-table-entry-addr-to-c-program-optimized-form + right-shift-to-logtail + bitops::loghead-of-loghead-2 + bitops::logand-with-bitmask + (:linear rm-low-64-logand-logior-helper-1) + (:t binary-logior) + (:t binary-logand) + force (force)))))) (defthmd ms-fault-programmer-level-and-marking-mode-from-final-state (implies (rewire_dst_to_src-effects-preconditions x86) - (and (equal (xr :ms 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) - (equal (xr :fault 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) - (equal (xr :programmer-level-mode 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) - (equal (xr :page-structure-marking-mode 0 (x86-run (rewire_dst_to_src-clk) x86)) t))) + (and (equal (xr :ms 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) + (equal (xr :fault 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) + (equal (xr :programmer-level-mode 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) + (equal (xr :page-structure-marking-mode 0 (x86-run (rewire_dst_to_src-clk) x86)) t))) :hints (("Goal" - :do-not '(preprocess) - :use ((:instance rewire_dst_to_src-effects) - (:instance fault-from-final-state)) - :hands-off (x86-run) - :in-theory (e/d* - (rewire_dst_to_src-effects-preconditions-and-ms-fault-programmer-level-and-marking-mode-fields) - (rewire_dst_to_src-effects-preconditions))))) + :do-not '(preprocess) + :use ((:instance rewire_dst_to_src-effects) + (:instance fault-from-final-state)) + :hands-off (x86-run) + :in-theory (e/d* + (rewire_dst_to_src-effects-preconditions-and-ms-fault-programmer-level-and-marking-mode-fields) + (rewire_dst_to_src-effects-preconditions))))) ;; ====================================================================== @@ -1054,10 +1054,10 @@ ;; the return address. (disjoint-p (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r (cpl x86) x86)) + (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 (xr :rgf *rsp* x86)) x86))) @@ -1066,23 +1066,23 @@ (and (disjoint-p (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :w (cpl x86) x86)) + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :w (cpl x86) x86)) (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r (cpl x86) x86))) + (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r (cpl x86) x86))) (disjoint-p (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r (cpl x86) x86)) + (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 @@ -1096,9 +1096,9 @@ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r (cpl x86) x86)) + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 @@ -1108,10 +1108,10 @@ (defun-nx more-source-PDPTE-and-source-PML4E-no-interfere-p (x86) (disjoint-p (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r (cpl x86) x86)) + (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 @@ -1142,8 +1142,8 @@ (create-canonical-address-list 8 (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) :w (cpl x86) x86)) (mv-nth 1 @@ -1174,10 +1174,10 @@ ;; From source-pml4te-ok-p: (disjoint-p (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r (cpl x86) x86)) + (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 @@ -1187,12 +1187,12 @@ ;; Derived from destination-PDPTE-and-source-PML4E-no-interfere-p. (disjoint-p (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :w (cpl x86) x86)) + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :w (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 @@ -1202,12 +1202,12 @@ ;; Derived from source-PML4TE-and-stack-no-interfere-p: (disjoint-p (mv-nth 1 (las-to-pas - (create-canonical-address-list 8 (+ -24 (xr :rgf *rsp* x86))) :w (cpl x86) x86)) + (create-canonical-address-list 8 (+ -24 (xr :rgf *rsp* x86))) :w (cpl x86) x86)) (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r (cpl x86) x86))))) + (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r (cpl x86) x86))))) (defun-nx throwaway-hyps-for-destination-entries-from-final-state (x86) (and @@ -1267,9 +1267,9 @@ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) - :r (cpl x86) x86)) + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) + :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 @@ -1285,7 +1285,7 @@ (create-canonical-address-list 8 (page-dir-ptr-table-entry-addr (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) :w (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list @@ -1299,344 +1299,344 @@ (defthm xlate-equiv-memory-and-pml4-table-base-addr (implies (xlate-equiv-memory x86-1 x86-2) - (equal (pml4-table-base-addr x86-1) - (pml4-table-base-addr x86-2))) + (equal (pml4-table-base-addr x86-1) + (pml4-table-base-addr x86-2))) :hints (("Goal" :in-theory (e/d* (pml4-table-base-addr) ()))) :rule-classes :congruence) (defthm pdpt-base-addr-after-mv-nth-2-las-to-pas ;; Similar to mv-nth-1-rb-after-mv-nth-2-las-to-pas. (implies (and - (disjoint-p - (mv-nth - 1 - (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - :r (cpl x86) (double-rewrite x86))) - (all-translation-governing-addresses l-addrs-2 (double-rewrite x86))) - (disjoint-p - (mv-nth - 1 - (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - :r (cpl x86) (double-rewrite x86))) - (all-translation-governing-addresses - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - (double-rewrite x86))) - (not (xr :programmer-level-mode 0 x86)) - (canonical-address-listp l-addrs-2)) - (equal (pdpt-base-addr lin-addr (mv-nth 2 (las-to-pas l-addrs-2 r-w-x-2 cpl-2 x86))) - (pdpt-base-addr lin-addr (double-rewrite x86)))) + (disjoint-p + (mv-nth + 1 + (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + :r (cpl x86) (double-rewrite x86))) + (all-translation-governing-addresses l-addrs-2 (double-rewrite x86))) + (disjoint-p + (mv-nth + 1 + (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + :r (cpl x86) (double-rewrite x86))) + (all-translation-governing-addresses + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + (double-rewrite x86))) + (not (xr :programmer-level-mode 0 x86)) + (canonical-address-listp l-addrs-2)) + (equal (pdpt-base-addr lin-addr (mv-nth 2 (las-to-pas l-addrs-2 r-w-x-2 cpl-2 x86))) + (pdpt-base-addr lin-addr (double-rewrite x86)))) :hints (("Goal" :in-theory (e/d* (pdpt-base-addr) (force (force)))))) (defthm pdpt-base-addr-after-mv-nth-1-wb ;; Similar to rb-wb-disjoint-in-system-level-mode (implies (and - (disjoint-p - (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - :r (cpl x86) (double-rewrite x86)))) - (disjoint-p - (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - :r (cpl x86) (double-rewrite x86))) - (all-translation-governing-addresses - (strip-cars addr-lst) (double-rewrite x86))) - (disjoint-p - (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - :r (cpl x86) (double-rewrite x86))) - (all-translation-governing-addresses - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - (double-rewrite x86))) - (disjoint-p - (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - (all-translation-governing-addresses - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - (double-rewrite x86))) - - (addr-byte-alistp addr-lst) - (not (programmer-level-mode x86)) - (x86p x86)) - (equal (pdpt-base-addr lin-addr (mv-nth 1 (wb addr-lst x86))) - (pdpt-base-addr lin-addr (double-rewrite x86)))) + (disjoint-p + (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) + (mv-nth 1 (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + :r (cpl x86) (double-rewrite x86)))) + (disjoint-p + (mv-nth 1 (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + :r (cpl x86) (double-rewrite x86))) + (all-translation-governing-addresses + (strip-cars addr-lst) (double-rewrite x86))) + (disjoint-p + (mv-nth 1 (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + :r (cpl x86) (double-rewrite x86))) + (all-translation-governing-addresses + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + (double-rewrite x86))) + (disjoint-p + (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) + (all-translation-governing-addresses + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + (double-rewrite x86))) + + (addr-byte-alistp addr-lst) + (not (programmer-level-mode x86)) + (x86p x86)) + (equal (pdpt-base-addr lin-addr (mv-nth 1 (wb addr-lst x86))) + (pdpt-base-addr lin-addr (double-rewrite x86)))) :hints (("Goal" :in-theory (e/d* (pdpt-base-addr) - (member-p-strip-cars-of-remove-duplicate-keys - remove-duplicate-keys - force (force)))))) + (member-p-strip-cars-of-remove-duplicate-keys + remove-duplicate-keys + force (force)))))) (defthmd pml4-table-base-addr-from-final-state (implies (rewire_dst_to_src-effects-preconditions x86) - (equal - (pml4-table-base-addr (x86-run (rewire_dst_to_src-clk) x86)) - (pml4-table-base-addr x86))) + (equal + (pml4-table-base-addr (x86-run (rewire_dst_to_src-clk) x86)) + (pml4-table-base-addr x86))) :hints (("Goal" - :use ((:instance rewire_dst_to_src-effects)) - :in-theory (e/d* (pml4-table-base-addr) - (rewire_dst_to_src-effects-preconditions-defs))))) + :use ((:instance rewire_dst_to_src-effects)) + :in-theory (e/d* (pml4-table-base-addr) + (rewire_dst_to_src-effects-preconditions-defs))))) (in-theory (e/d () (pml4-table-base-addr))) (local (defthmd source-pml4-table-entry-from-final-state-helper (implies (and (rewire_dst_to_src-effects-preconditions x86) - (throwaway-hyps-for-source-entries-from-final-state x86) - (more-stack-containing-return-address-and-source-PML4E-no-interfere-p x86) - (more-destination-PDPTE-and-source-PML4E-no-interfere-p x86) - (more-destination-PML4TE-and-source-PML4TE-no-interfere-p x86) - (more-source-PDPTE-and-source-PML4E-no-interfere-p x86)) - (equal - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r - (x86-run (rewire_dst_to_src-clk) x86))) - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r x86)))) + (throwaway-hyps-for-source-entries-from-final-state x86) + (more-stack-containing-return-address-and-source-PML4E-no-interfere-p x86) + (more-destination-PDPTE-and-source-PML4E-no-interfere-p x86) + (more-destination-PML4TE-and-source-PML4TE-no-interfere-p x86) + (more-source-PDPTE-and-source-PML4E-no-interfere-p x86)) + (equal + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r + (x86-run (rewire_dst_to_src-clk) x86))) + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r x86)))) :hints (("Goal" - :use ((:instance rewire_dst_to_src-effects)) - :in-theory (e/d* (pml4-table-base-addr-from-final-state - disjoint-p-all-translation-governing-addresses-subset-p) - (page-dir-ptr-table-entry-addr-to-c-program-optimized-form - unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 - unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode - mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free - two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas - combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence - rewrite-rb-to-rb-alt - las-to-pas-values-and-!flgi - create-canonical-address-list - gather-all-paging-structure-qword-addresses-!flgi - subset-p - (:meta acl2::mv-nth-cons-meta) - r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors - acl2::loghead-identity - mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures - mv-nth-2-las-to-pas-system-level-non-marking-mode - member-p-canonical-address-listp - xr-page-structure-marking-mode-mv-nth-2-las-to-pas - right-shift-to-logtail - (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:rewrite bitops::logand-with-bitmask) - (:rewrite xw-xw-intra-simple-field-shadow-writes) - (:rewrite x86-run-opener-not-ms-not-zp-n) - (:type-prescription acl2::bitmaskp$inline) - (:rewrite x86-run-opener-not-ms-not-fault-zp-n) - (:definition ms$inline) - (:definition fault$inline) - (:rewrite gl::nfix-natp))))))) + :use ((:instance rewire_dst_to_src-effects)) + :in-theory (e/d* (pml4-table-base-addr-from-final-state + disjoint-p-all-translation-governing-addresses-subset-p) + (page-dir-ptr-table-entry-addr-to-c-program-optimized-form + unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 + unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode + mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free + two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas + combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence + rewrite-rb-to-rb-alt + las-to-pas-values-and-!flgi + create-canonical-address-list + gather-all-paging-structure-qword-addresses-!flgi + subset-p + (:meta acl2::mv-nth-cons-meta) + r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors + acl2::loghead-identity + mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures + mv-nth-2-las-to-pas-system-level-non-marking-mode + member-p-canonical-address-listp + xr-page-structure-marking-mode-mv-nth-2-las-to-pas + right-shift-to-logtail + (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:rewrite bitops::logand-with-bitmask) + (:rewrite xw-xw-intra-simple-field-shadow-writes) + (:rewrite x86-run-opener-not-ms-not-zp-n) + (:type-prescription acl2::bitmaskp$inline) + (:rewrite x86-run-opener-not-ms-not-fault-zp-n) + (:definition ms$inline) + (:definition fault$inline) + (:rewrite gl::nfix-natp))))))) (local (defthmd throwaway-hyps-for-source-entries-from-final-state-lemma (implies (rewire_dst_to_src-effects-preconditions x86) - (throwaway-hyps-for-source-entries-from-final-state x86)) + (throwaway-hyps-for-source-entries-from-final-state x86)) :hints (("Goal" - :hands-off (disjoint-p) - :in-theory (e/d* (disjoint-p$) ()))))) + :hands-off (disjoint-p) + :in-theory (e/d* (disjoint-p$) ()))))) (defthmd source-pml4-table-entry-from-final-state (implies (and (rewire_dst_to_src-effects-preconditions x86) - (more-stack-containing-return-address-and-source-PML4E-no-interfere-p x86) - (more-destination-PDPTE-and-source-PML4E-no-interfere-p x86) - (more-destination-PML4TE-and-source-PML4TE-no-interfere-p x86) - (more-source-PDPTE-and-source-PML4E-no-interfere-p x86)) - (equal - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r - (x86-run (rewire_dst_to_src-clk) x86))) - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) - :r x86)))) + (more-stack-containing-return-address-and-source-PML4E-no-interfere-p x86) + (more-destination-PDPTE-and-source-PML4E-no-interfere-p x86) + (more-destination-PML4TE-and-source-PML4TE-no-interfere-p x86) + (more-source-PDPTE-and-source-PML4E-no-interfere-p x86)) + (equal + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r + (x86-run (rewire_dst_to_src-clk) x86))) + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rdi* x86) (pml4-table-base-addr x86))) + :r x86)))) :hints (("Goal" - :hands-off (disjoint-p) - :in-theory (e/d* () (rewire_dst_to_src-effects-preconditions)) - :use ((:instance source-pml4-table-entry-from-final-state-helper) - (:instance throwaway-hyps-for-source-entries-from-final-state-lemma))))) + :hands-off (disjoint-p) + :in-theory (e/d* () (rewire_dst_to_src-effects-preconditions)) + :use ((:instance source-pml4-table-entry-from-final-state-helper) + (:instance throwaway-hyps-for-source-entries-from-final-state-lemma))))) (defthmd destination-pml4-table-entry-from-final-state-helper (implies (and - (rewire_dst_to_src-effects-preconditions x86) - (throwaway-hyps-for-destination-entries-from-final-state x86) - (more-stack-containing-return-address-and-destination-PML4E-no-interfere-p x86) - (more-destination-PDPTE-and-destination-PML4TE-no-interfere-p x86)) - - (equal - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) - :r - (x86-run (rewire_dst_to_src-clk) x86))) - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) - :r x86)))) + (rewire_dst_to_src-effects-preconditions x86) + (throwaway-hyps-for-destination-entries-from-final-state x86) + (more-stack-containing-return-address-and-destination-PML4E-no-interfere-p x86) + (more-destination-PDPTE-and-destination-PML4TE-no-interfere-p x86)) + + (equal + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) + :r + (x86-run (rewire_dst_to_src-clk) x86))) + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) + :r x86)))) :hints (("Goal" - :use ((:instance rewire_dst_to_src-effects)) - :in-theory (e/d* (pml4-table-base-addr-from-final-state - disjoint-p-all-translation-governing-addresses-subset-p) - (rewrite-rb-to-rb-alt - las-to-pas-values-and-!flgi - create-canonical-address-list - gather-all-paging-structure-qword-addresses-!flgi - subset-p - (:meta acl2::mv-nth-cons-meta) - r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors - acl2::loghead-identity - mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures - mv-nth-2-las-to-pas-system-level-non-marking-mode - member-p-canonical-address-listp - xr-page-structure-marking-mode-mv-nth-2-las-to-pas - (:rewrite page-dir-ptr-table-entry-addr-to-c-program-optimized-form) - (:rewrite unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12) - (:rewrite unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode) - (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) - (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) - (:rewrite right-shift-to-logtail) - (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) - (:definition int-lists-in-seq-p) - (:rewrite bitops::loghead-of-ash-same) - (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:rewrite acl2::cdr-of-append-when-consp) - (:type-prescription binary-append) - (:rewrite bitops::logand-with-bitmask) - (:rewrite - int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) - (:rewrite acl2::consp-of-append) - (:type-prescription int-lists-in-seq-p) - (:rewrite int-lists-in-seq-p-and-append) - (:rewrite acl2::car-of-append) - (:rewrite xw-xw-intra-simple-field-shadow-writes) - (:rewrite x86-run-opener-not-ms-not-zp-n) - (:rewrite acl2::right-cancellation-for-+) - (:type-prescription acl2::bitmaskp$inline) - (:rewrite x86-run-opener-not-ms-not-fault-zp-n) - (:definition ms$inline) - (:definition fault$inline) - (:rewrite gl::nfix-natp)))))) + :use ((:instance rewire_dst_to_src-effects)) + :in-theory (e/d* (pml4-table-base-addr-from-final-state + disjoint-p-all-translation-governing-addresses-subset-p) + (rewrite-rb-to-rb-alt + las-to-pas-values-and-!flgi + create-canonical-address-list + gather-all-paging-structure-qword-addresses-!flgi + subset-p + (:meta acl2::mv-nth-cons-meta) + r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors + acl2::loghead-identity + mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures + mv-nth-2-las-to-pas-system-level-non-marking-mode + member-p-canonical-address-listp + xr-page-structure-marking-mode-mv-nth-2-las-to-pas + (:rewrite page-dir-ptr-table-entry-addr-to-c-program-optimized-form) + (:rewrite unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12) + (:rewrite unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode) + (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) + (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) + (:rewrite right-shift-to-logtail) + (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) + (:definition int-lists-in-seq-p) + (:rewrite bitops::loghead-of-ash-same) + (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:rewrite acl2::cdr-of-append-when-consp) + (:type-prescription binary-append) + (:rewrite bitops::logand-with-bitmask) + (:rewrite + int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) + (:rewrite acl2::consp-of-append) + (:type-prescription int-lists-in-seq-p) + (:rewrite int-lists-in-seq-p-and-append) + (:rewrite acl2::car-of-append) + (:rewrite xw-xw-intra-simple-field-shadow-writes) + (:rewrite x86-run-opener-not-ms-not-zp-n) + (:rewrite acl2::right-cancellation-for-+) + (:type-prescription acl2::bitmaskp$inline) + (:rewrite x86-run-opener-not-ms-not-fault-zp-n) + (:definition ms$inline) + (:definition fault$inline) + (:rewrite gl::nfix-natp)))))) (local (defthmd throwaway-hyps-for-destination-entries-from-final-state-lemma (implies (rewire_dst_to_src-effects-preconditions x86) - (throwaway-hyps-for-destination-entries-from-final-state x86)) + (throwaway-hyps-for-destination-entries-from-final-state x86)) :hints (("Goal" - :in-theory (e/d* (disjoint-p$) ()) - :hands-off (disjoint-p))))) + :in-theory (e/d* (disjoint-p$) ()) + :hands-off (disjoint-p))))) (defthmd destination-pml4-table-entry-from-final-state (implies (and (rewire_dst_to_src-effects-preconditions x86) - (more-stack-containing-return-address-and-destination-PML4E-no-interfere-p x86) - (more-destination-PDPTE-and-destination-PML4TE-no-interfere-p x86)) - - (equal - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) - :r - (x86-run (rewire_dst_to_src-clk) x86))) - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) - :r x86)))) + (more-stack-containing-return-address-and-destination-PML4E-no-interfere-p x86) + (more-destination-PDPTE-and-destination-PML4TE-no-interfere-p x86)) + + (equal + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) + :r + (x86-run (rewire_dst_to_src-clk) x86))) + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86))) + :r x86)))) :hints (("Goal" - :use ((:instance destination-pml4-table-entry-from-final-state-helper) - (:instance throwaway-hyps-for-destination-entries-from-final-state-lemma)) - :in-theory (e/d* () - (rewire_dst_to_src-effects-preconditions))))) + :use ((:instance destination-pml4-table-entry-from-final-state-helper) + (:instance throwaway-hyps-for-destination-entries-from-final-state-lemma)) + :in-theory (e/d* () + (rewire_dst_to_src-effects-preconditions))))) (in-theory (e/d () (pml4-table-entry-addr))) (defthmd source-pdpt-base-addr-from-final-state-helper (implies (and (rewire_dst_to_src-effects-preconditions x86) - (throwaway-hyps-for-source-entries-from-final-state x86) - (more-stack-containing-return-address-and-source-PML4E-no-interfere-p x86) - (more-destination-PDPTE-and-source-PML4E-no-interfere-p x86) - (more-destination-PML4TE-and-source-PML4TE-no-interfere-p x86) - (more-source-PDPTE-and-source-PML4E-no-interfere-p x86)) - (equal - (pdpt-base-addr (xr :rgf *rdi* x86) (x86-run (rewire_dst_to_src-clk) x86)) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + (throwaway-hyps-for-source-entries-from-final-state x86) + (more-stack-containing-return-address-and-source-PML4E-no-interfere-p x86) + (more-destination-PDPTE-and-source-PML4E-no-interfere-p x86) + (more-destination-PML4TE-and-source-PML4TE-no-interfere-p x86) + (more-source-PDPTE-and-source-PML4E-no-interfere-p x86)) + (equal + (pdpt-base-addr (xr :rgf *rdi* x86) (x86-run (rewire_dst_to_src-clk) x86)) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) :hints (("Goal" - :use ((:instance rewire_dst_to_src-effects)) - :in-theory (e/d* (pdpt-base-addr - pml4-table-base-addr-from-final-state - source-pml4-table-entry-from-final-state) - (rewire_dst_to_src-effects-preconditions-defs))))) + :use ((:instance rewire_dst_to_src-effects)) + :in-theory (e/d* (pdpt-base-addr + pml4-table-base-addr-from-final-state + source-pml4-table-entry-from-final-state) + (rewire_dst_to_src-effects-preconditions-defs))))) (defthmd source-pdpt-base-addr-from-final-state (implies (and (rewire_dst_to_src-effects-preconditions x86) - (more-stack-containing-return-address-and-source-PML4E-no-interfere-p x86) - (more-destination-PDPTE-and-source-PML4E-no-interfere-p x86) - (more-destination-PML4TE-and-source-PML4TE-no-interfere-p x86) - (more-source-PDPTE-and-source-PML4E-no-interfere-p x86)) - (equal - (pdpt-base-addr (xr :rgf *rdi* x86) (x86-run (rewire_dst_to_src-clk) x86)) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + (more-stack-containing-return-address-and-source-PML4E-no-interfere-p x86) + (more-destination-PDPTE-and-source-PML4E-no-interfere-p x86) + (more-destination-PML4TE-and-source-PML4TE-no-interfere-p x86) + (more-source-PDPTE-and-source-PML4E-no-interfere-p x86)) + (equal + (pdpt-base-addr (xr :rgf *rdi* x86) (x86-run (rewire_dst_to_src-clk) x86)) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) :hints (("Goal" - :use ((:instance throwaway-hyps-for-source-entries-from-final-state-lemma) - (:instance source-pdpt-base-addr-from-final-state-helper)) - :in-theory (e/d* () - (rewire_dst_to_src-effects-preconditions-defs))))) + :use ((:instance throwaway-hyps-for-source-entries-from-final-state-lemma) + (:instance source-pdpt-base-addr-from-final-state-helper)) + :in-theory (e/d* () + (rewire_dst_to_src-effects-preconditions-defs))))) (local (defthmd destination-pdpt-base-addr-from-final-state-helper (implies (and (rewire_dst_to_src-effects-preconditions x86) - (throwaway-hyps-for-destination-entries-from-final-state x86) - (more-stack-containing-return-address-and-destination-PML4E-no-interfere-p x86) - (more-destination-PDPTE-and-destination-PML4TE-no-interfere-p x86)) - (equal - (pdpt-base-addr (xr :rgf *rsi* x86) (x86-run (rewire_dst_to_src-clk) x86)) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (throwaway-hyps-for-destination-entries-from-final-state x86) + (more-stack-containing-return-address-and-destination-PML4E-no-interfere-p x86) + (more-destination-PDPTE-and-destination-PML4TE-no-interfere-p x86)) + (equal + (pdpt-base-addr (xr :rgf *rsi* x86) (x86-run (rewire_dst_to_src-clk) x86)) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) :hints (("Goal" - :use ((:instance rewire_dst_to_src-effects)) - :in-theory (e/d* (pdpt-base-addr - pml4-table-base-addr-from-final-state - destination-pml4-table-entry-from-final-state) - (rewire_dst_to_src-effects-preconditions-defs)))))) + :use ((:instance rewire_dst_to_src-effects)) + :in-theory (e/d* (pdpt-base-addr + pml4-table-base-addr-from-final-state + destination-pml4-table-entry-from-final-state) + (rewire_dst_to_src-effects-preconditions-defs)))))) (defthmd destination-pdpt-base-addr-from-final-state (implies (and (rewire_dst_to_src-effects-preconditions x86) - (more-stack-containing-return-address-and-destination-PML4E-no-interfere-p x86) - (more-destination-PDPTE-and-destination-PML4TE-no-interfere-p x86)) - (equal - (pdpt-base-addr (xr :rgf *rsi* x86) (x86-run (rewire_dst_to_src-clk) x86)) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (more-stack-containing-return-address-and-destination-PML4E-no-interfere-p x86) + (more-destination-PDPTE-and-destination-PML4TE-no-interfere-p x86)) + (equal + (pdpt-base-addr (xr :rgf *rsi* x86) (x86-run (rewire_dst_to_src-clk) x86)) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) :hints (("Goal" - :use ((:instance destination-pdpt-base-addr-from-final-state-helper) - (:instance throwaway-hyps-for-destination-entries-from-final-state-lemma)) - :in-theory (e/d* () - (rewire_dst_to_src-effects-preconditions-defs))))) + :use ((:instance destination-pdpt-base-addr-from-final-state-helper) + (:instance throwaway-hyps-for-destination-entries-from-final-state-lemma)) + :in-theory (e/d* () + (rewire_dst_to_src-effects-preconditions-defs))))) (in-theory (e/d () (pdpt-base-addr))) ;; page-dir-ptr-table-entry-addr is already disabled. Also, we don't @@ -1646,224 +1646,224 @@ (defthmd source-addresses-from-final-state (implies (and (rewire_dst_to_src-effects-preconditions x86) - ;; The physical addresses corresponding to destination - ;; PDPTE are disjoint from the translation-governing - ;; addresses of the source linear addresses. Note - ;; that this means that the destination PDPTE can't - ;; serve as the PML4TE or PDPTE of the source. - (disjoint-p - (mv-nth - 1 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :w (cpl x86) x86)) - (all-translation-governing-addresses - (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - x86))) - - (equal - (mv-nth 1 - (las-to-pas - (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) - (x86-run (rewire_dst_to_src-clk) x86))) - (mv-nth 1 - (las-to-pas - (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) x86)))) + ;; The physical addresses corresponding to destination + ;; PDPTE are disjoint from the translation-governing + ;; addresses of the source linear addresses. Note + ;; that this means that the destination PDPTE can't + ;; serve as the PML4TE or PDPTE of the source. + (disjoint-p + (mv-nth + 1 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :w (cpl x86) x86)) + (all-translation-governing-addresses + (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + x86))) + + (equal + (mv-nth 1 + (las-to-pas + (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r (cpl x86) + (x86-run (rewire_dst_to_src-clk) x86))) + (mv-nth 1 + (las-to-pas + (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r (cpl x86) x86)))) :hints (("Goal" - :use ((:instance rewire_dst_to_src-effects)) - :in-theory (e/d* (pml4-table-base-addr-from-final-state - source-pml4-table-entry-from-final-state - source-pdpt-base-addr-from-final-state) - (rewrite-rb-to-rb-alt - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 - unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode - infer-disjointness-with-all-translation-governing-addresses-from-gather-all-paging-structure-qword-addresses-with-disjoint-p$ - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs - subset-p - (:meta acl2::mv-nth-cons-meta) - create-canonical-address-list - mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free - acl2::loghead-identity - (:rewrite xr-page-structure-marking-mode-mv-nth-2-las-to-pas) - (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) - (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) - (:definition int-lists-in-seq-p) - (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) - (:rewrite subset-p-two-create-canonical-address-lists-general) - (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) - (:rewrite canonical-address-p-limits-thm-0) - (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) - (:rewrite mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) - (:rewrite acl2::cdr-of-append-when-consp) - (:rewrite bitops::logand-with-bitmask) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:type-prescription binary-append) - (:rewrite int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) - (:rewrite acl2::consp-of-append) - (:type-prescription int-lists-in-seq-p) - (:type-prescription subset-p) - (:rewrite int-lists-in-seq-p-and-append) - (:rewrite acl2::car-of-append) - (:rewrite xw-xw-intra-simple-field-shadow-writes) - (:rewrite x86-run-opener-not-ms-not-zp-n) - (:rewrite acl2::right-cancellation-for-+) - (:type-prescription acl2::bitmaskp$inline) - (:rewrite x86-run-opener-not-ms-not-fault-zp-n) - (:definition ms$inline) - (:definition fault$inline) - (:rewrite gl::nfix-natp)))))) + :use ((:instance rewire_dst_to_src-effects)) + :in-theory (e/d* (pml4-table-base-addr-from-final-state + source-pml4-table-entry-from-final-state + source-pdpt-base-addr-from-final-state) + (rewrite-rb-to-rb-alt + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 + unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode + infer-disjointness-with-all-translation-governing-addresses-from-gather-all-paging-structure-qword-addresses-with-disjoint-p$ + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs + subset-p + (:meta acl2::mv-nth-cons-meta) + create-canonical-address-list + mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free + acl2::loghead-identity + (:rewrite xr-page-structure-marking-mode-mv-nth-2-las-to-pas) + (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) + (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) + (:definition int-lists-in-seq-p) + (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) + (:rewrite subset-p-two-create-canonical-address-lists-general) + (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) + (:rewrite canonical-address-p-limits-thm-0) + (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) + (:rewrite mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) + (:rewrite acl2::cdr-of-append-when-consp) + (:rewrite bitops::logand-with-bitmask) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:type-prescription binary-append) + (:rewrite int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) + (:rewrite acl2::consp-of-append) + (:type-prescription int-lists-in-seq-p) + (:type-prescription subset-p) + (:rewrite int-lists-in-seq-p-and-append) + (:rewrite acl2::car-of-append) + (:rewrite xw-xw-intra-simple-field-shadow-writes) + (:rewrite x86-run-opener-not-ms-not-zp-n) + (:rewrite acl2::right-cancellation-for-+) + (:type-prescription acl2::bitmaskp$inline) + (:rewrite x86-run-opener-not-ms-not-fault-zp-n) + (:definition ms$inline) + (:definition fault$inline) + (:rewrite gl::nfix-natp)))))) (defthmd source-data-from-final-state-in-terms-of-rb (implies (and (rewire_dst_to_src-effects-preconditions x86) - ;; The physical addresses corresponding to destination - ;; PDPTE are disjoint from the translation-governing - ;; addresses of the source linear addresses. Note - ;; that this means that the destination PDPTE can't - ;; serve as the PML4TE or PDPTE of the source. - (disjoint-p - (mv-nth - 1 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :w (cpl x86) x86)) - (all-translation-governing-addresses - (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - x86)) - - ;; The physical addresses corresponding to destination - ;; PDPTE are disjoint from the source physical - ;; addresses. - (disjoint-p - (mv-nth - 1 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :w (cpl x86) x86)) - (mv-nth 1 - (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) x86))) - - ;; The source physical addresses are disjoint from the - ;; paging structures. - (disjoint-p$ - (mv-nth 1 - (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) x86)) - (open-qword-paddr-list - (gather-all-paging-structure-qword-addresses x86))) - - ;; The stack is disjoint from the source physical - ;; addresses. - (disjoint-p - (mv-nth - 1 - (las-to-pas - (create-canonical-address-list 8 (+ -24 (xr :rgf *rsp* x86))) - :w (cpl x86) x86)) - (mv-nth 1 - (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) x86)))) - - (equal - (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r - (x86-run (rewire_dst_to_src-clk) x86))) - (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r x86)))) + ;; The physical addresses corresponding to destination + ;; PDPTE are disjoint from the translation-governing + ;; addresses of the source linear addresses. Note + ;; that this means that the destination PDPTE can't + ;; serve as the PML4TE or PDPTE of the source. + (disjoint-p + (mv-nth + 1 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :w (cpl x86) x86)) + (all-translation-governing-addresses + (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + x86)) + + ;; The physical addresses corresponding to destination + ;; PDPTE are disjoint from the source physical + ;; addresses. + (disjoint-p + (mv-nth + 1 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :w (cpl x86) x86)) + (mv-nth 1 + (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r (cpl x86) x86))) + + ;; The source physical addresses are disjoint from the + ;; paging structures. + (disjoint-p$ + (mv-nth 1 + (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r (cpl x86) x86)) + (open-qword-paddr-list + (gather-all-paging-structure-qword-addresses x86))) + + ;; The stack is disjoint from the source physical + ;; addresses. + (disjoint-p + (mv-nth + 1 + (las-to-pas + (create-canonical-address-list 8 (+ -24 (xr :rgf *rsp* x86))) + :w (cpl x86) x86)) + (mv-nth 1 + (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r (cpl x86) x86)))) + + (equal + (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r + (x86-run (rewire_dst_to_src-clk) x86))) + (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r x86)))) :hints (("Goal" - :use ((:instance rewire_dst_to_src-effects)) - :in-theory (e/d* - (pml4-table-base-addr-from-final-state - source-pml4-table-entry-from-final-state - source-pdpt-base-addr-from-final-state - source-addresses-from-final-state - - disjoint-p-all-translation-governing-addresses-subset-p) - - (rewrite-rb-to-rb-alt - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 - unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs - subset-p - (:meta acl2::mv-nth-cons-meta) - create-canonical-address-list - mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free - acl2::loghead-identity - (:rewrite xr-page-structure-marking-mode-mv-nth-2-las-to-pas) - (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) - (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) - (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) - (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) - (:definition int-lists-in-seq-p) - (:rewrite mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) - (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) - (:rewrite bitops::logand-with-bitmask) - (:rewrite acl2::cdr-of-append-when-consp) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:type-prescription binary-append) - (:rewrite int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) - (:rewrite acl2::consp-of-append) - (:type-prescription int-lists-in-seq-p) - (:rewrite int-lists-in-seq-p-and-append) - (:rewrite acl2::car-of-append) - (:rewrite xw-xw-intra-simple-field-shadow-writes) - (:rewrite x86-run-opener-not-ms-not-zp-n) - (:type-prescription xlate-equiv-memory) - (:rewrite acl2::right-cancellation-for-+) - (:type-prescription acl2::bitmaskp$inline) - (:rewrite x86-run-opener-not-ms-not-fault-zp-n) - (:definition ms$inline) - (:definition fault$inline) - (:rewrite gl::nfix-natp)))))) + :use ((:instance rewire_dst_to_src-effects)) + :in-theory (e/d* + (pml4-table-base-addr-from-final-state + source-pml4-table-entry-from-final-state + source-pdpt-base-addr-from-final-state + source-addresses-from-final-state + + disjoint-p-all-translation-governing-addresses-subset-p) + + (rewrite-rb-to-rb-alt + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 + unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs + subset-p + (:meta acl2::mv-nth-cons-meta) + create-canonical-address-list + mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free + acl2::loghead-identity + (:rewrite xr-page-structure-marking-mode-mv-nth-2-las-to-pas) + (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) + (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) + (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) + (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) + (:definition int-lists-in-seq-p) + (:rewrite mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) + (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) + (:rewrite bitops::logand-with-bitmask) + (:rewrite acl2::cdr-of-append-when-consp) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:type-prescription binary-append) + (:rewrite int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) + (:rewrite acl2::consp-of-append) + (:type-prescription int-lists-in-seq-p) + (:rewrite int-lists-in-seq-p-and-append) + (:rewrite acl2::car-of-append) + (:rewrite xw-xw-intra-simple-field-shadow-writes) + (:rewrite x86-run-opener-not-ms-not-zp-n) + (:type-prescription xlate-equiv-memory) + (:rewrite acl2::right-cancellation-for-+) + (:type-prescription acl2::bitmaskp$inline) + (:rewrite x86-run-opener-not-ms-not-fault-zp-n) + (:definition ms$inline) + (:definition fault$inline) + (:rewrite gl::nfix-natp)))))) (defthmd source-data-from-initial-state-in-terms-of-read-from-physical-memory-and-las-to-pas (implies (and - (rewire_dst_to_src-effects-preconditions x86) - (disjoint-p$ - (mv-nth - 1 - (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) x86)) - (open-qword-paddr-list - (gather-all-paging-structure-qword-addresses x86)))) - - (equal - (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r x86)) - (read-from-physical-memory - (mv-nth - 1 - (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) :r 0 x86)) - x86))) + (rewire_dst_to_src-effects-preconditions x86) + (disjoint-p$ + (mv-nth + 1 + (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r (cpl x86) x86)) + (open-qword-paddr-list + (gather-all-paging-structure-qword-addresses x86)))) + + (equal + (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r x86)) + (read-from-physical-memory + (mv-nth + 1 + (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) :r 0 x86)) + x86))) :hints (("Goal" - :in-theory (e/d* - (rb) - (rewrite-rb-to-rb-alt - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 - unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs - subset-p - (:meta acl2::mv-nth-cons-meta) - create-canonical-address-list - mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free - acl2::loghead-identity))))) + :in-theory (e/d* + (rb) + (rewrite-rb-to-rb-alt + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 + unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs + subset-p + (:meta acl2::mv-nth-cons-meta) + create-canonical-address-list + mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free + acl2::loghead-identity))))) ;; In order to prove destination-data-from-final-state-*, I first need ;; las-to-pas-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr, @@ -1873,9 +1873,9 @@ ;; ====================================================================== (in-theory (e/d* (rewire_dst_to_src-disable - rewire_dst_to_src-disable-more) - (unsigned-byte-p - signed-byte-p))) + rewire_dst_to_src-disable-more) + (unsigned-byte-p + signed-byte-p))) ;; ====================================================================== @@ -1884,112 +1884,142 @@ (def-gl-export rb-and-rm-low-64-for-direct-map-helper-1 :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) - (n08p e) (n08p f) (n08p g) (n08p h)) + (n08p e) (n08p f) (n08p g) (n08p h)) :concl (equal (logior a (ash b 8) - (ash (logior c (ash d 8)) 16) - (ash (logior e (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 32)) - (logior a - (ash (logior b - (ash (logior c - (ash - (logior d - (ash - (logior - e - (ash - (logior - f - (ash (logior g (ash h 8)) 8)) - 8)) 8)) 8)) 8)) 8))) + (ash (logior c (ash d 8)) 16) + (ash (logior e (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 32)) + (logior a + (ash (logior b + (ash (logior c + (ash + (logior d + (ash + (logior + e + (ash + (logior + f + (ash (logior g (ash h 8)) 8)) + 8)) 8)) 8)) 8)) 8))) :g-bindings (gl::auto-bindings (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) - (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) + (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) (def-gl-export rb-and-rm-low-64-for-direct-map-helper-2 :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) - (n08p e) (n08p f) (n08p g) (n08p h)) + (n08p e) (n08p f) (n08p g) (n08p h)) :concl (equal (loghead - 64 - (logior a - (ash b 8) - (ash (logior c (ash d 8)) 16) - (ash (logior e (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 32))) - (logior a - (ash b 8) - (ash (logior c (ash d 8)) 16) - (ash (logior e (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 32))) + 64 + (logior a + (ash b 8) + (ash (logior c (ash d 8)) 16) + (ash (logior e (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 32))) + (logior a + (ash b 8) + (ash (logior c (ash d 8)) 16) + (ash (logior e (ash (logior f (ash (logior g (ash h 8)) 8)) 8)) 32))) :g-bindings (gl::auto-bindings (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) - (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) + (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) + +(def-gl-export rm64-direct-map-helper + :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) + (n08p e) (n08p f) (n08p g) (n08p h)) + :concl (equal + (logior + a + (ash (logior + b + (ash (logior + c + (ash (logior + d + (ash (logior + e + (ash (logior f (ash (logior g (ash h 8)) 8)) + 8)) + 8)) + 8)) + 8)) + 8)) + (logior a (ash b 8) + (ash (logior c (ash d 8)) 16) + (ash (logior e (ash f 8) (ash (logior g (ash h 8)) 16)) 32))) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) + (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) (in-theory (e/d* () (rb-and-rm-low-64-for-direct-map-helper-1 - rb-and-rm-low-64-for-direct-map-helper-2))) + rb-and-rm-low-64-for-direct-map-helper-2 + rm64-direct-map-helper))) (defthm rb-and-rm-low-64-for-direct-map (implies (and - (direct-map-p 8 direct-mapped-addr r-w-x (cpl x86) (double-rewrite x86)) - ;; The physical addresses corresponding to - ;; direct-mapped-addr to (+ 7 direct-mapped-addr) are - ;; disjoint from their own translation-governing - ;; addresses. - (disjoint-p$ - (mv-nth 1 - (las-to-pas (create-canonical-address-list 8 direct-mapped-addr) - r-w-x (cpl x86) - (double-rewrite x86))) - (all-translation-governing-addresses - (create-canonical-address-list 8 direct-mapped-addr) - (double-rewrite x86))) - (not - (mv-nth 0 - (las-to-pas (create-canonical-address-list 8 direct-mapped-addr) - r-w-x (cpl x86) - (double-rewrite x86)))) - (physical-address-p direct-mapped-addr) - (canonical-address-p (+ 7 direct-mapped-addr)) - (not (programmer-level-mode x86)) - (x86p x86)) - (equal (combine-bytes - (mv-nth - 1 - (rb (create-canonical-address-list 8 direct-mapped-addr) r-w-x x86))) - (rm-low-64 direct-mapped-addr (double-rewrite x86)))) + (direct-map-p 8 direct-mapped-addr r-w-x (cpl x86) (double-rewrite x86)) + ;; The physical addresses corresponding to + ;; direct-mapped-addr to (+ 7 direct-mapped-addr) are + ;; disjoint from their own translation-governing + ;; addresses. + (disjoint-p$ + (mv-nth 1 + (las-to-pas (create-canonical-address-list 8 direct-mapped-addr) + r-w-x (cpl x86) + (double-rewrite x86))) + (all-translation-governing-addresses + (create-canonical-address-list 8 direct-mapped-addr) + (double-rewrite x86))) + (not + (mv-nth 0 + (las-to-pas (create-canonical-address-list 8 direct-mapped-addr) + r-w-x (cpl x86) + (double-rewrite x86)))) + (physical-address-p direct-mapped-addr) + (canonical-address-p (+ 7 direct-mapped-addr)) + (not (programmer-level-mode x86)) + (x86p x86)) + (equal (combine-bytes + (mv-nth + 1 + (rb (create-canonical-address-list 8 direct-mapped-addr) r-w-x x86))) + (rm-low-64 direct-mapped-addr (double-rewrite x86)))) :hints (("Goal" - :use ((:instance rewrite-read-from-physical-memory-to-rm-low-64 - (p-addrs (addr-range 8 direct-mapped-addr)) - (index direct-mapped-addr) - (x86 x86)) - (:instance rb-and-rm-low-64-for-direct-map-helper-2 - (a (xr :mem direct-mapped-addr x86)) - (b (xr :mem (+ 1 direct-mapped-addr) x86)) - (c (xr :mem (+ 2 direct-mapped-addr) x86)) - (d (xr :mem (+ 3 direct-mapped-addr) x86)) - (e (xr :mem (+ 4 direct-mapped-addr) x86)) - (f (xr :mem (+ 5 direct-mapped-addr) x86)) - (g (xr :mem (+ 6 direct-mapped-addr) x86)) - (h (xr :mem (+ 7 direct-mapped-addr) x86)))) - :in-theory (e/d* (rb - disjoint-p$ - direct-map-p - rm-low-64 - rm-low-32 - n08p - unsigned-byte-p - signed-byte-p) - (rb-and-rm-low-64-for-direct-map-helper-1 - rb-and-rm-low-64-for-direct-map-helper-2 - xlate-equiv-memory-and-xr-mem-from-rest-of-memory - bitops::loghead-of-logior - (:linear bitops::logior-<-0-linear-2) - (:linear ash-monotone-2) - (:rewrite bitops::ash-<-0) - (:rewrite acl2::ash-0) - (:rewrite acl2::zip-open) - (:linear <=-logior) - (:linear bitops::logior->=-0-linear) - (:linear bitops::logior-<-0-linear-1)))))) + :use ((:instance rewrite-read-from-physical-memory-to-rm-low-64 + (p-addrs (addr-range 8 direct-mapped-addr)) + (index direct-mapped-addr) + (x86 x86)) + (:instance rb-and-rm-low-64-for-direct-map-helper-2 + (a (xr :mem direct-mapped-addr x86)) + (b (xr :mem (+ 1 direct-mapped-addr) x86)) + (c (xr :mem (+ 2 direct-mapped-addr) x86)) + (d (xr :mem (+ 3 direct-mapped-addr) x86)) + (e (xr :mem (+ 4 direct-mapped-addr) x86)) + (f (xr :mem (+ 5 direct-mapped-addr) x86)) + (g (xr :mem (+ 6 direct-mapped-addr) x86)) + (h (xr :mem (+ 7 direct-mapped-addr) x86)))) + :in-theory (e/d* (rb + disjoint-p$ + direct-map-p + rm-low-64 + rm-low-32 + n08p + unsigned-byte-p + signed-byte-p + rm64-direct-map-helper) + (rb-and-rm-low-64-for-direct-map-helper-1 + rb-and-rm-low-64-for-direct-map-helper-2 + xlate-equiv-memory-and-xr-mem-from-rest-of-memory + bitops::loghead-of-logior + (:linear bitops::logior-<-0-linear-2) + (:linear ash-monotone-2) + (:rewrite bitops::ash-<-0) + (:rewrite acl2::ash-0) + (:rewrite acl2::zip-open) + (:linear <=-logior) + (:linear bitops::logior->=-0-linear) + (:linear bitops::logior-<-0-linear-1)))))) ;; ====================================================================== @@ -2000,48 +2030,48 @@ (def-gl-export same-pml4-table-entry-addr-for-n-+-lin-addrs :hyp (and (physical-address-p pml4-table-base-addr) - (canonical-address-p lin-addr) - (unsigned-byte-p 30 n) - ;; 1G aligned linear address - (equal (loghead 30 lin-addr) 0)) + (canonical-address-p lin-addr) + (unsigned-byte-p 30 n) + ;; 1G aligned linear address + (equal (loghead 30 lin-addr) 0)) :concl (equal (pml4-table-entry-addr (+ n lin-addr) pml4-table-base-addr) - (pml4-table-entry-addr lin-addr pml4-table-base-addr)) + (pml4-table-entry-addr lin-addr pml4-table-base-addr)) :g-bindings (gl::auto-bindings (:mix (:nat pml4-table-base-addr 64) (:nat lin-addr 64) (:nat n 64)))) (def-gl-export same-pdp-table-entry-addr-for-n-+-lin-addrs :hyp (and (unsigned-byte-p 30 n) - (physical-address-p pdpt-base-addr) - (canonical-address-p lin-addr) - ;; 1G aligned linear address - (equal (loghead 30 lin-addr) 0)) + (physical-address-p pdpt-base-addr) + (canonical-address-p lin-addr) + ;; 1G aligned linear address + (equal (loghead 30 lin-addr) 0)) :concl (equal (page-dir-ptr-table-entry-addr - (+ n lin-addr) pdpt-base-addr) - (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) + (+ n lin-addr) pdpt-base-addr) + (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) :g-bindings (gl::auto-bindings (:mix (:nat pdpt-base-addr 64) (:nat lin-addr 64) (:nat n 64)))) (def-gl-export loghead-30-of-1G-aligned-lin-addr-+-n-1 :hyp (and (canonical-address-p lin-addr) - (canonical-address-p (+ n lin-addr)) - (equal (loghead 30 lin-addr) 0) - (unsigned-byte-p 30 n)) + (canonical-address-p (+ n lin-addr)) + (equal (loghead 30 lin-addr) 0) + (unsigned-byte-p 30 n)) :concl (equal (loghead 30 (+ n lin-addr)) n) :g-bindings (gl::auto-bindings (:mix (:nat lin-addr 64) (:nat n 64)))) (def-gl-export loghead-30-of-1G-aligned-lin-addr-+-n-2 :hyp (and (equal (loghead 30 (+ n lin-addr)) n) - (canonical-address-p (+ n lin-addr)) - (canonical-address-p lin-addr) - (unsigned-byte-p 30 n)) + (canonical-address-p (+ n lin-addr)) + (canonical-address-p lin-addr) + (unsigned-byte-p 30 n)) :concl (equal (loghead 30 lin-addr) 0) :g-bindings (gl::auto-bindings (:mix (:nat lin-addr 64) (:nat n 64)))) (def-gl-export logior-to-+-for-ash-x-30 :hyp (and (unsigned-byte-p 22 x) - (unsigned-byte-p 30 n)) + (unsigned-byte-p 30 n)) :concl (equal (logior n (ash x 30)) (+ n (ash x 30))) :g-bindings (gl::auto-bindings (:mix (:nat n 64) (:nat x 64)))) @@ -2054,31 +2084,31 @@ (implies (and (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr lin-addr base-addr)) - r-w-x x86)))) + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr lin-addr base-addr)) + r-w-x x86)))) (equal cpl (cpl x86)) ;; PDPTE is direct-mapped. (direct-map-p 8 - (page-dir-ptr-table-entry-addr lin-addr base-addr) - r-w-x cpl (double-rewrite x86)) + (page-dir-ptr-table-entry-addr lin-addr base-addr) + r-w-x cpl (double-rewrite x86)) (not (mv-nth 0 (las-to-pas (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr lin-addr base-addr)) - r-w-x cpl x86))) + 8 + (page-dir-ptr-table-entry-addr lin-addr base-addr)) + r-w-x cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr lin-addr base-addr)) + 8 + (page-dir-ptr-table-entry-addr lin-addr base-addr)) r-w-x cpl x86)) (all-translation-governing-addresses (create-canonical-address-list @@ -2102,25 +2132,25 @@ (x86p x86)) (and (equal (mv-nth 0 - (ia32e-la-to-pa-page-dir-ptr-table - (+ n lin-addr) base-addr u/s-acc r/w-acc x/d-acc - wp smep smap ac nxe r-w-x cpl x86)) - nil) + (ia32e-la-to-pa-page-dir-ptr-table + (+ n lin-addr) base-addr u/s-acc r/w-acc x/d-acc + wp smep smap ac nxe r-w-x cpl x86)) + nil) (equal (mv-nth 1 - (ia32e-la-to-pa-page-dir-ptr-table - (+ n lin-addr) base-addr u/s-acc r/w-acc x/d-acc - wp smep smap ac nxe r-w-x cpl x86)) - (+ n - (ash - (loghead 22 (logtail - 30 - (rm-low-64 (page-dir-ptr-table-entry-addr lin-addr base-addr) x86))) - 30))))) + (ia32e-la-to-pa-page-dir-ptr-table + (+ n lin-addr) base-addr u/s-acc r/w-acc x/d-acc + wp smep smap ac nxe r-w-x cpl x86)) + (+ n + (ash + (loghead 22 (logtail + 30 + (rm-low-64 (page-dir-ptr-table-entry-addr lin-addr base-addr) x86))) + 30))))) :hints (("Goal" :in-theory (e/d* (ia32e-la-to-pa-page-dir-ptr-table) - (commutativity-of-+ - not - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask))))) + (commutativity-of-+ + not + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask))))) (defthmd ia32e-la-to-pa-pml4-table-values-for-same-1G-page ;; This lemma returns the flg and phy-addr values output by @@ -2132,31 +2162,31 @@ (equal pml4-table-base-addr (pml4-table-base-addr x86)) (equal pml4-table-entry-addr (pml4-table-entry-addr lin-addr pml4-table-base-addr)) (equal pml4-table-entry - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list 8 pml4-table-entry-addr) - :r x86)))) + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list 8 pml4-table-entry-addr) + :r x86)))) (equal pdpt-base-addr (pdpt-base-addr lin-addr x86)) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) + (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) (equal page-dir-ptr-table-entry (combine-bytes (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r x86)))) + :r x86)))) (direct-map-p 8 pml4-table-entry-addr :r cpl (double-rewrite x86)) (not (mv-nth 0 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86))) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86)) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 pml4-table-entry-addr) x86)) @@ -2178,12 +2208,12 @@ x86)) (disjoint-p (addr-range 8 pml4-table-entry-addr) - (addr-range 8 page-dir-ptr-table-entry-addr)) + (addr-range 8 page-dir-ptr-table-entry-addr)) (equal (page-size page-dir-ptr-table-entry) 1) (not (mv-nth 0 - (ia32e-la-to-pa-pml4-table - lin-addr pml4-table-base-addr wp smep smap ac nxe :r cpl x86))) + (ia32e-la-to-pa-pml4-table + lin-addr pml4-table-base-addr wp smep smap ac nxe :r cpl x86))) (canonical-address-p (+ 7 pml4-table-entry-addr)) (canonical-address-p (+ 7 page-dir-ptr-table-entry-addr)) @@ -2196,22 +2226,22 @@ (x86p x86)) (and (equal (mv-nth 0 - (ia32e-la-to-pa-pml4-table (+ n lin-addr) pml4-table-base-addr - wp smep smap ac nxe :r cpl x86)) - nil) + (ia32e-la-to-pa-pml4-table (+ n lin-addr) pml4-table-base-addr + wp smep smap ac nxe :r cpl x86)) + nil) (equal (mv-nth 1 - (ia32e-la-to-pa-pml4-table (+ n lin-addr) pml4-table-base-addr - wp smep smap ac nxe :r cpl x86)) - (+ n (ash (loghead 22 (logtail 30 (rm-low-64 page-dir-ptr-table-entry-addr x86))) - 30))))) + (ia32e-la-to-pa-pml4-table (+ n lin-addr) pml4-table-base-addr + wp smep smap ac nxe :r cpl x86)) + (+ n (ash (loghead 22 (logtail 30 (rm-low-64 page-dir-ptr-table-entry-addr x86))) + 30))))) :hints (("Goal" - :in-theory (e/d* (ia32e-la-to-pa-pml4-table - pdpt-base-addr - ia32e-la-to-pa-page-dir-ptr-table-values-for-same-1G-page) - (commutativity-of-+ - not - pml4-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask))))) + :in-theory (e/d* (ia32e-la-to-pa-pml4-table + pdpt-base-addr + ia32e-la-to-pa-page-dir-ptr-table-values-for-same-1G-page) + (commutativity-of-+ + not + pml4-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask))))) (defthmd ia32e-la-to-pa-values-for-same-1G-page ;; This lemma returns the flg and phy-addr values output by @@ -2223,31 +2253,31 @@ (equal pml4-table-base-addr (pml4-table-base-addr x86)) (equal pml4-table-entry-addr (pml4-table-entry-addr lin-addr pml4-table-base-addr)) (equal pml4-table-entry - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list 8 pml4-table-entry-addr) - :r x86)))) + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list 8 pml4-table-entry-addr) + :r x86)))) (equal pdpt-base-addr (pdpt-base-addr lin-addr x86)) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) + (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) (equal page-dir-ptr-table-entry (combine-bytes (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r x86)))) + :r x86)))) (direct-map-p 8 pml4-table-entry-addr :r cpl (double-rewrite x86)) (not (mv-nth 0 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86))) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86)) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 pml4-table-entry-addr) x86)) @@ -2295,26 +2325,26 @@ (and (equal (mv-nth 0 (ia32e-la-to-pa (+ n lin-addr) :r cpl x86)) nil) (equal (mv-nth 1 (ia32e-la-to-pa (+ n lin-addr) :r cpl x86)) - (+ n (ash (loghead 22 (logtail 30 (rm-low-64 page-dir-ptr-table-entry-addr x86))) - 30))))) + (+ n (ash (loghead 22 (logtail 30 (rm-low-64 page-dir-ptr-table-entry-addr x86))) + 30))))) :hints (("Goal" - :in-theory (e/d* (ia32e-la-to-pa - disjoint-p$ - direct-map-p - pdpt-base-addr - pml4-table-base-addr - ia32e-la-to-pa-pml4-table-values-for-same-1G-page) - (commutativity-of-+ - subset-p - (:linear acl2::loghead-upper-bound) - unsigned-byte-p-of-logtail - member-p - member-p-canonical-address-listp - unsigned-byte-p-of-logtail - mv-nth-0-las-to-pas-subset-p - not - pml4-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask))))) + :in-theory (e/d* (ia32e-la-to-pa + disjoint-p$ + direct-map-p + pdpt-base-addr + pml4-table-base-addr + ia32e-la-to-pa-pml4-table-values-for-same-1G-page) + (commutativity-of-+ + subset-p + (:linear acl2::loghead-upper-bound) + unsigned-byte-p-of-logtail + member-p + member-p-canonical-address-listp + unsigned-byte-p-of-logtail + mv-nth-0-las-to-pas-subset-p + not + pml4-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask))))) ;; Now generalizing ia32e-la-to-pa-values-for-same-1G-page to ;; las-to-pas: @@ -2323,9 +2353,9 @@ :enabled t :measure (nfix (- count iteration)) :guard (and (natp count) - (natp iteration) - (<= iteration count) - (integerp lin-addr)) + (natp iteration) + (<= iteration count) + (integerp lin-addr)) :long "An alternative way of creating canonical address lists, this function also gives a different induction scheme that may be preferable to the one suggested by @(see @@ -2333,48 +2363,48 @@ (if (zp (- count iteration)) nil (if (canonical-address-p (+ iteration lin-addr)) - (cons - (+ iteration lin-addr) - (create-canonical-address-list-alt (+ 1 iteration) count lin-addr)) + (cons + (+ iteration lin-addr) + (create-canonical-address-list-alt (+ 1 iteration) count lin-addr)) nil)) /// (defthmd create-canonical-address-list-alt-is-create-canonical-address-list (equal (create-canonical-address-list-alt iteration count lin-addr) - (create-canonical-address-list (- count iteration) (+ iteration lin-addr))))) + (create-canonical-address-list (- count iteration) (+ iteration lin-addr))))) (def-gl-export open-mv-nth-0-las-to-pas-for-same-1G-page-general-1 :hyp (and (< iteration m) - (canonical-address-p lin-addr) - (canonical-address-p (+ -1 lin-addr m)) - (integerp m) - (<= m *2^30*) - (natp iteration) - (equal (loghead 30 lin-addr) 0)) + (canonical-address-p lin-addr) + (canonical-address-p (+ -1 lin-addr m)) + (integerp m) + (<= m *2^30*) + (natp iteration) + (equal (loghead 30 lin-addr) 0)) :concl (equal (loghead 30 (+ iteration lin-addr)) iteration) :g-bindings (gl::auto-bindings (:mix (:nat lin-addr 64) (:nat iteration 64) (:nat m 64)))) (def-gl-export open-mv-nth-0-las-to-pas-for-same-1G-page-general-2 :hyp (and (< iteration m) - (integerp m) - (<= m *2^30*) - (natp iteration)) + (integerp m) + (<= m *2^30*) + (natp iteration)) :concl (unsigned-byte-p 30 iteration) :g-bindings (gl::auto-bindings (:mix (:nat iteration 64) (:nat m 64)))) (def-gl-export open-mv-nth-1-las-to-pas-for-same-1G-page-general-1 :hyp (and (< iteration m) - (canonical-address-p lin-addr) - (canonical-address-p (+ -1 lin-addr m)) - (integerp m) - (<= m 1073741824) - (natp iteration) - (equal (loghead 30 lin-addr) 0)) + (canonical-address-p lin-addr) + (canonical-address-p (+ -1 lin-addr m)) + (integerp m) + (<= m 1073741824) + (natp iteration) + (equal (loghead 30 lin-addr) 0)) :concl (canonical-address-p (+ iteration lin-addr)) :g-bindings (gl::auto-bindings (:mix (:nat lin-addr 64) (:nat iteration 64) (:nat m 64)))) (def-gl-export open-mv-nth-1-las-to-pas-for-same-1G-page-general-2 :hyp (and (canonical-address-p lin-addr) - (equal (loghead 30 lin-addr) 0)) + (equal (loghead 30 lin-addr) 0)) :concl ;; (canonical-address-p (+ -1 *2^30* lin-addr)) (canonical-address-p (+ 1073741823 lin-addr)) @@ -2387,31 +2417,31 @@ (equal pml4-table-base-addr (pml4-table-base-addr x86)) (equal pml4-table-entry-addr (pml4-table-entry-addr lin-addr pml4-table-base-addr)) (equal pml4-table-entry - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list 8 pml4-table-entry-addr) - :r x86)))) + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list 8 pml4-table-entry-addr) + :r x86)))) (equal pdpt-base-addr (pdpt-base-addr lin-addr x86)) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) + (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) (equal page-dir-ptr-table-entry (combine-bytes (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r x86)))) + :r x86)))) (direct-map-p 8 pml4-table-entry-addr :r cpl (double-rewrite x86)) (not (mv-nth 0 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86))) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86)) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 pml4-table-entry-addr) x86)) @@ -2461,29 +2491,29 @@ (x86p x86)) (and (equal (mv-nth 0 (las-to-pas - (create-canonical-address-list-alt iteration m lin-addr) - :r cpl x86)) - nil) + (create-canonical-address-list-alt iteration m lin-addr) + :r cpl x86)) + nil) (equal (mv-nth 1 (las-to-pas - (create-canonical-address-list-alt iteration m lin-addr) - :r cpl x86)) - (addr-range - (+ (- iteration) m) - (+ iteration - (ash (loghead 22 (logtail 30 (rm-low-64 page-dir-ptr-table-entry-addr x86))) - 30)))))) + (create-canonical-address-list-alt iteration m lin-addr) + :r cpl x86)) + (addr-range + (+ (- iteration) m) + (+ iteration + (ash (loghead 22 (logtail 30 (rm-low-64 page-dir-ptr-table-entry-addr x86))) + 30)))))) :hints (("Goal" - :induct (create-canonical-address-list-alt iteration m lin-addr) - :in-theory (e/d* (las-to-pas - ia32e-la-to-pa-values-for-same-1G-page - open-mv-nth-0-las-to-pas-for-same-1G-page-general-1 - open-mv-nth-0-las-to-pas-for-same-1G-page-general-2 - open-mv-nth-1-las-to-pas-for-same-1G-page-general-1) - (not - pml4-table-base-addr - pml4-table-entry-addr - page-dir-ptr-table-entry-addr - page-dir-ptr-table-entry-addr-to-c-program-optimized-form))))) + :induct (create-canonical-address-list-alt iteration m lin-addr) + :in-theory (e/d* (las-to-pas + ia32e-la-to-pa-values-for-same-1G-page + open-mv-nth-0-las-to-pas-for-same-1G-page-general-1 + open-mv-nth-0-las-to-pas-for-same-1G-page-general-2 + open-mv-nth-1-las-to-pas-for-same-1G-page-general-1) + (not + pml4-table-base-addr + pml4-table-entry-addr + page-dir-ptr-table-entry-addr + page-dir-ptr-table-entry-addr-to-c-program-optimized-form))))) (defthmd las-to-pas-values-for-same-1G-page (implies @@ -2492,31 +2522,31 @@ (equal pml4-table-base-addr (pml4-table-base-addr x86)) (equal pml4-table-entry-addr (pml4-table-entry-addr lin-addr pml4-table-base-addr)) (equal pml4-table-entry - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list 8 pml4-table-entry-addr) - :r x86)))) + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list 8 pml4-table-entry-addr) + :r x86)))) (equal pdpt-base-addr (pdpt-base-addr lin-addr x86)) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) + (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) (equal page-dir-ptr-table-entry (combine-bytes (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r x86)))) + :r x86)))) (direct-map-p 8 pml4-table-entry-addr :r cpl (double-rewrite x86)) (not (mv-nth 0 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86))) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86)) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 pml4-table-entry-addr) x86)) @@ -2562,26 +2592,26 @@ (x86p x86)) (and (equal (mv-nth 0 (las-to-pas - (create-canonical-address-list *2^30* lin-addr) - :r cpl x86)) - nil) + (create-canonical-address-list *2^30* lin-addr) + :r cpl x86)) + nil) (equal (mv-nth 1 (las-to-pas - (create-canonical-address-list *2^30* lin-addr) - :r cpl x86)) - (addr-range - *2^30* - (ash (loghead 22 (logtail 30 (rm-low-64 page-dir-ptr-table-entry-addr x86))) - 30))))) + (create-canonical-address-list *2^30* lin-addr) + :r cpl x86)) + (addr-range + *2^30* + (ash (loghead 22 (logtail 30 (rm-low-64 page-dir-ptr-table-entry-addr x86))) + 30))))) :hints (("Goal" - :use ((:instance las-to-pas-values-for-same-1G-page-general - (iteration 0) - (m *2^30*))) - :in-theory (e/d* (create-canonical-address-list-alt-is-create-canonical-address-list) - (not - pml4-table-base-addr - pml4-table-entry-addr - page-dir-ptr-table-entry-addr - page-dir-ptr-table-entry-addr-to-c-program-optimized-form))))) + :use ((:instance las-to-pas-values-for-same-1G-page-general + (iteration 0) + (m *2^30*))) + :in-theory (e/d* (create-canonical-address-list-alt-is-create-canonical-address-list) + (not + pml4-table-base-addr + pml4-table-entry-addr + page-dir-ptr-table-entry-addr + page-dir-ptr-table-entry-addr-to-c-program-optimized-form))))) ;; ====================================================================== @@ -2595,109 +2625,109 @@ ;; corresponding to this lin-addr has been modified --- the new ;; PDPTE is (combine-bytes bytes). (implies (and - (equal p-addrs - (addr-range 8 (page-dir-ptr-table-entry-addr lin-addr base-addr))) - (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list - 8 (page-dir-ptr-table-entry-addr lin-addr base-addr)) - r-w-x x86)))) - (equal cpl (cpl x86)) - - ;; PDPTE is direct mapped. - (direct-map-p - 8 (page-dir-ptr-table-entry-addr lin-addr base-addr) r-w-x cpl (double-rewrite x86)) - (not - (mv-nth - 0 - (las-to-pas (create-canonical-address-list - 8 (page-dir-ptr-table-entry-addr lin-addr base-addr)) - r-w-x cpl x86))) - (disjoint-p$ - (mv-nth - 1 - (las-to-pas (create-canonical-address-list - 8 (page-dir-ptr-table-entry-addr lin-addr base-addr)) - r-w-x cpl x86)) - (all-translation-governing-addresses - (create-canonical-address-list - 8 (page-dir-ptr-table-entry-addr lin-addr base-addr)) - x86)) - - (not - (mv-nth - 0 - (ia32e-la-to-pa-page-dir-ptr-table - lin-addr base-addr u/s-acc r/w-acc x/d-acc - wp smep smap ac nxe r-w-x cpl x86))) - - (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes bytes))) - (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes bytes))) - (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes bytes))) - (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes bytes))) - (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes bytes))) - (equal (page-size page-dir-ptr-table-entry) 1) - (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes bytes) :low 13 :high 29)) - - (equal (len bytes) (len p-addrs)) - (byte-listp bytes) - (canonical-address-p - (+ 7 (page-dir-ptr-table-entry-addr lin-addr base-addr))) - (canonical-address-p lin-addr) - (physical-address-p base-addr) - (equal (loghead 12 base-addr) 0) - (x86p x86)) - (and (equal - (mv-nth 0 (ia32e-la-to-pa-page-dir-ptr-table - lin-addr base-addr u/s-acc r/w-acc x/d-acc - wp smep smap ac nxe r-w-x cpl - (write-to-physical-memory p-addrs bytes x86))) - nil) - (equal (mv-nth 1 (ia32e-la-to-pa-page-dir-ptr-table - lin-addr base-addr u/s-acc r/w-acc x/d-acc - wp smep smap ac nxe r-w-x cpl - (write-to-physical-memory p-addrs bytes x86))) - (logior (loghead 30 lin-addr) - (ash (loghead 22 (logtail 30 (combine-bytes bytes))) 30))))) + (equal p-addrs + (addr-range 8 (page-dir-ptr-table-entry-addr lin-addr base-addr))) + (equal page-dir-ptr-table-entry + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list + 8 (page-dir-ptr-table-entry-addr lin-addr base-addr)) + r-w-x x86)))) + (equal cpl (cpl x86)) + + ;; PDPTE is direct mapped. + (direct-map-p + 8 (page-dir-ptr-table-entry-addr lin-addr base-addr) r-w-x cpl (double-rewrite x86)) + (not + (mv-nth + 0 + (las-to-pas (create-canonical-address-list + 8 (page-dir-ptr-table-entry-addr lin-addr base-addr)) + r-w-x cpl x86))) + (disjoint-p$ + (mv-nth + 1 + (las-to-pas (create-canonical-address-list + 8 (page-dir-ptr-table-entry-addr lin-addr base-addr)) + r-w-x cpl x86)) + (all-translation-governing-addresses + (create-canonical-address-list + 8 (page-dir-ptr-table-entry-addr lin-addr base-addr)) + x86)) + + (not + (mv-nth + 0 + (ia32e-la-to-pa-page-dir-ptr-table + lin-addr base-addr u/s-acc r/w-acc x/d-acc + wp smep smap ac nxe r-w-x cpl x86))) + + (equal (page-present page-dir-ptr-table-entry) + (page-present (combine-bytes bytes))) + (equal (page-read-write page-dir-ptr-table-entry) + (page-read-write (combine-bytes bytes))) + (equal (page-user-supervisor page-dir-ptr-table-entry) + (page-user-supervisor (combine-bytes bytes))) + (equal (page-execute-disable page-dir-ptr-table-entry) + (page-execute-disable (combine-bytes bytes))) + (equal (page-size page-dir-ptr-table-entry) + (page-size (combine-bytes bytes))) + (equal (page-size page-dir-ptr-table-entry) 1) + (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) + (part-select (combine-bytes bytes) :low 13 :high 29)) + + (equal (len bytes) (len p-addrs)) + (byte-listp bytes) + (canonical-address-p + (+ 7 (page-dir-ptr-table-entry-addr lin-addr base-addr))) + (canonical-address-p lin-addr) + (physical-address-p base-addr) + (equal (loghead 12 base-addr) 0) + (x86p x86)) + (and (equal + (mv-nth 0 (ia32e-la-to-pa-page-dir-ptr-table + lin-addr base-addr u/s-acc r/w-acc x/d-acc + wp smep smap ac nxe r-w-x cpl + (write-to-physical-memory p-addrs bytes x86))) + nil) + (equal (mv-nth 1 (ia32e-la-to-pa-page-dir-ptr-table + lin-addr base-addr u/s-acc r/w-acc x/d-acc + wp smep smap ac nxe r-w-x cpl + (write-to-physical-memory p-addrs bytes x86))) + (logior (loghead 30 lin-addr) + (ash (loghead 22 (logtail 30 (combine-bytes bytes))) 30))))) :hints (("Goal" - :do-not-induct t - :use ((:instance rewrite-wm-low-64-to-write-to-physical-memory - (index (page-dir-ptr-table-entry-addr lin-addr base-addr))) - (:instance mv-nth-0-paging-entry-no-page-fault-p-and-similar-entries - (structure-type 2) - (u/s-acc (logand u/s-acc - (page-user-supervisor (combine-bytes bytes)))) - (r/w-acc - (logand r/w-acc - (page-read-write (combine-bytes bytes)))) - (x/d-acc (logand x/d-acc - (page-execute-disable (combine-bytes bytes)))) - (ignored 0) - (cpl (cpl x86)) - (entry-1 (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr lin-addr base-addr)) - r-w-x x86)))) - (entry-2 (combine-bytes bytes)))) - :in-theory (e/d* (disjoint-p - member-p - ia32e-la-to-pa-page-dir-ptr-table - byte-ify-and-combine-bytes) - (mv-nth-0-paging-entry-no-page-fault-p-and-similar-entries - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - wb - bitops::logand-with-negated-bitmask - (:meta acl2::mv-nth-cons-meta) - force (force)))))) + :do-not-induct t + :use ((:instance rewrite-wm-low-64-to-write-to-physical-memory + (index (page-dir-ptr-table-entry-addr lin-addr base-addr))) + (:instance mv-nth-0-paging-entry-no-page-fault-p-and-similar-entries + (structure-type 2) + (u/s-acc (logand u/s-acc + (page-user-supervisor (combine-bytes bytes)))) + (r/w-acc + (logand r/w-acc + (page-read-write (combine-bytes bytes)))) + (x/d-acc (logand x/d-acc + (page-execute-disable (combine-bytes bytes)))) + (ignored 0) + (cpl (cpl x86)) + (entry-1 (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr lin-addr base-addr)) + r-w-x x86)))) + (entry-2 (combine-bytes bytes)))) + :in-theory (e/d* (disjoint-p + member-p + ia32e-la-to-pa-page-dir-ptr-table + byte-ify-and-combine-bytes) + (mv-nth-0-paging-entry-no-page-fault-p-and-similar-entries + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + wb + bitops::logand-with-negated-bitmask + (:meta acl2::mv-nth-cons-meta) + force (force)))))) (defthmd ia32e-la-to-pa-pml4-table-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr ;; Given a 1G page, ia32e-la-to-pa-pml4-table returns the physical @@ -2712,12 +2742,12 @@ (and (equal pml4-table-base-addr (pml4-table-base-addr x86)) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr x86))) + (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr x86))) (equal p-addrs (addr-range 8 page-dir-ptr-table-entry-addr)) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r x86)))) + (combine-bytes + (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r x86)))) (equal cpl (cpl x86)) ;; PML4TE is direct-mapped. @@ -2760,25 +2790,25 @@ ;; Physical addresses of PML4TE and PDPTE are disjoint. (disjoint-p (addr-range 8 (pml4-table-entry-addr lin-addr pml4-table-base-addr)) - (addr-range 8 page-dir-ptr-table-entry-addr)) + (addr-range 8 page-dir-ptr-table-entry-addr)) (not (mv-nth 0 - (ia32e-la-to-pa-pml4-table - lin-addr pml4-table-base-addr wp smep smap ac nxe :r cpl x86))) + (ia32e-la-to-pa-pml4-table + lin-addr pml4-table-base-addr wp smep smap ac nxe :r cpl x86))) (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes bytes))) + (page-present (combine-bytes bytes))) (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes bytes))) + (page-read-write (combine-bytes bytes))) (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes bytes))) + (page-user-supervisor (combine-bytes bytes))) (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes bytes))) + (page-execute-disable (combine-bytes bytes))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes bytes))) + (page-size (combine-bytes bytes))) (equal (page-size page-dir-ptr-table-entry) 1) (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes bytes) :low 13 :high 29)) + (part-select (combine-bytes bytes) :low 13 :high 29)) (equal (len bytes) (len p-addrs)) (byte-listp bytes) @@ -2791,27 +2821,27 @@ (and (equal (mv-nth 0 - (ia32e-la-to-pa-pml4-table - lin-addr pml4-table-base-addr wp smep smap ac nxe :r cpl - (write-to-physical-memory p-addrs bytes x86))) + (ia32e-la-to-pa-pml4-table + lin-addr pml4-table-base-addr wp smep smap ac nxe :r cpl + (write-to-physical-memory p-addrs bytes x86))) nil) (equal (mv-nth 1 - (ia32e-la-to-pa-pml4-table - lin-addr pml4-table-base-addr wp smep smap ac nxe :r cpl - (write-to-physical-memory p-addrs bytes x86))) + (ia32e-la-to-pa-pml4-table + lin-addr pml4-table-base-addr wp smep smap ac nxe :r cpl + (write-to-physical-memory p-addrs bytes x86))) (logior (loghead 30 lin-addr) - (ash (loghead 22 (logtail 30 (combine-bytes bytes))) - 30))))) + (ash (loghead 22 (logtail 30 (combine-bytes bytes))) + 30))))) :hints (("Goal" - :do-not-induct t - :in-theory (e/d* (ia32e-la-to-pa-page-dir-ptr-table-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr - ia32e-la-to-pa-pml4-table - pdpt-base-addr) - (page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - (:meta acl2::mv-nth-cons-meta) - force (force)))))) + :do-not-induct t + :in-theory (e/d* (ia32e-la-to-pa-page-dir-ptr-table-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr + ia32e-la-to-pa-pml4-table + pdpt-base-addr) + (page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + (:meta acl2::mv-nth-cons-meta) + force (force)))))) (defthmd ia32e-la-to-pa-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr ;; Given a 1G page, ia32e-la-to-pa returns the physical address @@ -2822,12 +2852,12 @@ (implies (and (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal p-addrs (addr-range 8 page-dir-ptr-table-entry-addr)) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) ;; PML4TE is direct-mapped. @@ -2886,18 +2916,18 @@ (not (mv-nth 0 (ia32e-la-to-pa lin-addr :r cpl (double-rewrite x86)))) (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes bytes))) + (page-present (combine-bytes bytes))) (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes bytes))) + (page-read-write (combine-bytes bytes))) (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes bytes))) + (page-user-supervisor (combine-bytes bytes))) (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes bytes))) + (page-execute-disable (combine-bytes bytes))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes bytes))) + (page-size (combine-bytes bytes))) (equal (page-size page-dir-ptr-table-entry) 1) (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes bytes) :low 13 :high 29)) + (part-select (combine-bytes bytes) :low 13 :high 29)) (equal (len bytes) (len p-addrs)) (byte-listp bytes) @@ -2907,21 +2937,21 @@ (x86p x86)) (and (equal (mv-nth 0 (ia32e-la-to-pa lin-addr :r cpl (write-to-physical-memory p-addrs bytes x86))) - nil) + nil) (equal (mv-nth 1 (ia32e-la-to-pa lin-addr :r cpl (write-to-physical-memory p-addrs bytes x86))) - (logior (loghead 30 lin-addr) (ash (loghead 22 (logtail 30 (combine-bytes bytes))) 30))))) + (logior (loghead 30 lin-addr) (ash (loghead 22 (logtail 30 (combine-bytes bytes))) 30))))) :hints (("Goal" - :do-not-induct t - :in-theory (e/d* (ia32e-la-to-pa-pml4-table-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr - ia32e-la-to-pa - pml4-table-base-addr - direct-map-p - disjoint-p$) - (page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - (:meta acl2::mv-nth-cons-meta) - not - force (force)))))) + :do-not-induct t + :in-theory (e/d* (ia32e-la-to-pa-pml4-table-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr + ia32e-la-to-pa + pml4-table-base-addr + direct-map-p + disjoint-p$) + (page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + (:meta acl2::mv-nth-cons-meta) + not + force (force)))))) (defthmd ia32e-la-to-pa-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr ;; Given a 1G page, ia32e-la-to-pa returns the physical address @@ -2934,15 +2964,15 @@ ;; Restricting this rule so that it doesn't apply when lin-addr ;; points to a paging entry. (syntaxp (not (and (consp lin-addr) - (or (eq (car lin-addr) 'CAR) - (eq (car lin-addr) 'PML4-TABLE-ENTRY-ADDR$INLINE) - (eq (car lin-addr) 'PAGE-DIR-PTR-TABLE-ENTRY-ADDR$INLINE))))) + (or (eq (car lin-addr) 'CAR) + (eq (car lin-addr) 'PML4-TABLE-ENTRY-ADDR$INLINE) + (eq (car lin-addr) 'PAGE-DIR-PTR-TABLE-ENTRY-ADDR$INLINE))))) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) ;; PML4TE is direct-mapped. @@ -2954,16 +2984,16 @@ 0 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list @@ -3006,30 +3036,30 @@ ;; (addr-range 8 page-dir-ptr-table-entry-addr)) (equal (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - (addr-range 8 page-dir-ptr-table-entry-addr)) + (addr-range 8 page-dir-ptr-table-entry-addr)) (disjoint-p (mv-nth 1 - (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86))) + (las-to-pas + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86))) (all-translation-governing-addresses (strip-cars addr-lst) (double-rewrite x86))) (not (mv-nth 0 (ia32e-la-to-pa lin-addr :r cpl (double-rewrite x86)))) (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes (strip-cdrs addr-lst)))) + (page-present (combine-bytes (strip-cdrs addr-lst)))) (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes (strip-cdrs addr-lst)))) + (page-read-write (combine-bytes (strip-cdrs addr-lst)))) (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) + (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) + (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) 1) (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) + (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) (addr-byte-alistp addr-lst) (canonical-address-p (+ 7 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86))))) @@ -3038,33 +3068,33 @@ (x86p x86)) (and (equal (mv-nth 0 (ia32e-la-to-pa lin-addr :r cpl (mv-nth 1 (wb addr-lst x86)))) - nil) + nil) (equal (mv-nth 1 (ia32e-la-to-pa lin-addr :r cpl (mv-nth 1 (wb addr-lst x86)))) - (logior - (loghead 30 lin-addr) - (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) 30))))) + (logior + (loghead 30 lin-addr) + (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) 30))))) :hints (("Goal" :do-not-induct t :in-theory (e/d* - (ia32e-la-to-pa-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr - wb - pdpt-base-addr - page-dir-ptr-table-entry-addr - pml4-table-base-addr) - (member-p-canonical-address-listp - subset-p - mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p - cdr-mv-nth-1-las-to-pas - unsigned-byte-p-of-combine-bytes - acl2::loghead-identity - mv-nth-0-las-to-pas-subset-p - rewrite-rb-to-rb-alt - member-p-strip-cars-of-remove-duplicate-keys - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - (:meta acl2::mv-nth-cons-meta) - not force (force)))))) + (ia32e-la-to-pa-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr + wb + pdpt-base-addr + page-dir-ptr-table-entry-addr + pml4-table-base-addr) + (member-p-canonical-address-listp + subset-p + mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p + cdr-mv-nth-1-las-to-pas + unsigned-byte-p-of-combine-bytes + acl2::loghead-identity + mv-nth-0-las-to-pas-subset-p + rewrite-rb-to-rb-alt + member-p-strip-cars-of-remove-duplicate-keys + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + (:meta acl2::mv-nth-cons-meta) + not force (force)))))) ;; Now generalizing ;; ia32e-la-to-pa-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr @@ -3072,16 +3102,16 @@ (defthmd mv-nth-0-las-to-pas-cons (equal (mv-nth 0 (las-to-pas (cons e x) r-w-x cpl x86)) - (if (mv-nth 0 (ia32e-la-to-pa e r-w-x cpl x86)) - (mv-nth 0 (ia32e-la-to-pa e r-w-x cpl x86)) - (mv-nth 0 (las-to-pas x r-w-x cpl x86)))) + (if (mv-nth 0 (ia32e-la-to-pa e r-w-x cpl x86)) + (mv-nth 0 (ia32e-la-to-pa e r-w-x cpl x86)) + (mv-nth 0 (las-to-pas x r-w-x cpl x86)))) :hints (("Goal" :in-theory (e/d* (las-to-pas) ())))) (defthmd mv-nth-1-las-to-pas-cons (implies (not (mv-nth 0 (las-to-pas (cons e x) r-w-x cpl x86))) - (equal (mv-nth 1 (las-to-pas (cons e x) r-w-x cpl x86)) - (cons (mv-nth 1 (ia32e-la-to-pa e r-w-x cpl x86)) - (mv-nth 1 (las-to-pas x r-w-x cpl x86))))) + (equal (mv-nth 1 (las-to-pas (cons e x) r-w-x cpl x86)) + (cons (mv-nth 1 (ia32e-la-to-pa e r-w-x cpl x86)) + (mv-nth 1 (las-to-pas x r-w-x cpl x86))))) :hints (("Goal" :in-theory (e/d* (las-to-pas) ())))) (defthmd las-to-pas-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr-general @@ -3092,11 +3122,11 @@ (implies (and (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) ;; PML4TE is direct-mapped. @@ -3108,16 +3138,16 @@ 0 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list @@ -3160,30 +3190,30 @@ ;; (addr-range 8 page-dir-ptr-table-entry-addr)) (equal (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - (addr-range 8 page-dir-ptr-table-entry-addr)) + (addr-range 8 page-dir-ptr-table-entry-addr)) (disjoint-p (mv-nth 1 - (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86))) + (las-to-pas + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86))) (all-translation-governing-addresses (strip-cars addr-lst) (double-rewrite x86))) (not (mv-nth 0 (ia32e-la-to-pa lin-addr :r cpl (double-rewrite x86)))) (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes (strip-cdrs addr-lst)))) + (page-present (combine-bytes (strip-cdrs addr-lst)))) (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes (strip-cdrs addr-lst)))) + (page-read-write (combine-bytes (strip-cdrs addr-lst)))) (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) + (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) + (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) 1) (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) + (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) (addr-byte-alistp addr-lst) (canonical-address-p (+ 7 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86))))) @@ -3202,56 +3232,56 @@ ;; (strip-cdrs addr-lst)). (and (equal (mv-nth 0 (las-to-pas - (create-canonical-address-list-alt iteration m lin-addr) - :r cpl (mv-nth 1 (wb addr-lst x86)))) - nil) + (create-canonical-address-list-alt iteration m lin-addr) + :r cpl (mv-nth 1 (wb addr-lst x86)))) + nil) (equal (mv-nth 1 (las-to-pas - (create-canonical-address-list-alt iteration m lin-addr) - :r cpl (mv-nth 1 (wb addr-lst x86)))) - (addr-range - (+ (- iteration) m) - (+ iteration - (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) 30)))))) + (create-canonical-address-list-alt iteration m lin-addr) + :r cpl (mv-nth 1 (wb addr-lst x86)))) + (addr-range + (+ (- iteration) m) + (+ iteration + (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) 30)))))) :hints (("Goal" - :induct (create-canonical-address-list-alt iteration m lin-addr) - :in-theory (e/d* - ( ;; disjoint-p$ - ;; direct-map-p - page-dir-ptr-table-entry-addr - pdpt-base-addr - mv-nth-0-las-to-pas-cons - mv-nth-1-las-to-pas-cons - open-mv-nth-1-las-to-pas-for-same-1G-page-general-1 - open-mv-nth-0-las-to-pas-for-same-1G-page-general-1 - open-mv-nth-0-las-to-pas-for-same-1G-page-general-2 - ia32e-la-to-pa-values-for-same-1G-page - ia32e-la-to-pa-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr) - (acl2::loghead-identity - acl2::zip-open - member-p-addr-range - not-member-p-addr-range - unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode - direct-map-p-and-wb-disjoint-from-xlation-governing-addrs - len-of-rb-in-system-level-mode - (:linear ash-monotone-2) - unsigned-byte-p-of-combine-bytes - cdr-mv-nth-1-las-to-pas - rewrite-rb-to-rb-alt - mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p - member-p-canonical-address-listp - pml4-table-entry-addr-to-c-program-optimized-form - adding-7-to-pml4-table-entry-addr - rb-wb-disjoint-in-system-level-mode - cdr-create-canonical-address-list - ia32e-la-to-pa-values-and-mv-nth-1-wb-disjoint-from-xlation-gov-addrs - car-mv-nth-1-las-to-pas - mv-nth-1-las-to-pas-subset-p - subset-p-two-create-canonical-address-lists-general - member-p-strip-cars-of-remove-duplicate-keys - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not))))) + :induct (create-canonical-address-list-alt iteration m lin-addr) + :in-theory (e/d* + ( ;; disjoint-p$ + ;; direct-map-p + page-dir-ptr-table-entry-addr + pdpt-base-addr + mv-nth-0-las-to-pas-cons + mv-nth-1-las-to-pas-cons + open-mv-nth-1-las-to-pas-for-same-1G-page-general-1 + open-mv-nth-0-las-to-pas-for-same-1G-page-general-1 + open-mv-nth-0-las-to-pas-for-same-1G-page-general-2 + ia32e-la-to-pa-values-for-same-1G-page + ia32e-la-to-pa-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr) + (acl2::loghead-identity + acl2::zip-open + member-p-addr-range + not-member-p-addr-range + unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode + direct-map-p-and-wb-disjoint-from-xlation-governing-addrs + len-of-rb-in-system-level-mode + (:linear ash-monotone-2) + unsigned-byte-p-of-combine-bytes + cdr-mv-nth-1-las-to-pas + rewrite-rb-to-rb-alt + mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p + member-p-canonical-address-listp + pml4-table-entry-addr-to-c-program-optimized-form + adding-7-to-pml4-table-entry-addr + rb-wb-disjoint-in-system-level-mode + cdr-create-canonical-address-list + ia32e-la-to-pa-values-and-mv-nth-1-wb-disjoint-from-xlation-gov-addrs + car-mv-nth-1-las-to-pas + mv-nth-1-las-to-pas-subset-p + subset-p-two-create-canonical-address-lists-general + member-p-strip-cars-of-remove-duplicate-keys + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not))))) (defthm las-to-pas-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr ;; las-to-pas returns the physical addresses corresponding to linear @@ -3261,11 +3291,11 @@ (implies (and (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) ;; PML4TE is direct-mapped. @@ -3277,16 +3307,16 @@ 0 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list @@ -3329,37 +3359,37 @@ ;; (addr-range 8 page-dir-ptr-table-entry-addr)) (equal (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - ;; (addr-range 8 page-dir-ptr-table-entry-addr) - (mv-nth - 1 - (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86)))) + ;; (addr-range 8 page-dir-ptr-table-entry-addr) + (mv-nth + 1 + (las-to-pas + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86)))) (disjoint-p (mv-nth 1 - (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86))) + (las-to-pas + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86))) (all-translation-governing-addresses (strip-cars addr-lst) (double-rewrite x86))) (not (mv-nth 0 (las-to-pas - (create-canonical-address-list *2^30* lin-addr) - :r cpl (double-rewrite x86)))) + (create-canonical-address-list *2^30* lin-addr) + :r cpl (double-rewrite x86)))) (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes (strip-cdrs addr-lst)))) + (page-present (combine-bytes (strip-cdrs addr-lst)))) (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes (strip-cdrs addr-lst)))) + (page-read-write (combine-bytes (strip-cdrs addr-lst)))) (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) + (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) + (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) 1) (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) + (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) (addr-byte-alistp addr-lst) (canonical-address-p (+ 7 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86))))) @@ -3370,27 +3400,27 @@ (x86p x86)) (and (equal (mv-nth 0 (las-to-pas - (create-canonical-address-list *2^30* lin-addr) - :r cpl (mv-nth 1 (wb addr-lst x86)))) - nil) + (create-canonical-address-list *2^30* lin-addr) + :r cpl (mv-nth 1 (wb addr-lst x86)))) + nil) (equal (mv-nth 1 (las-to-pas - (create-canonical-address-list *2^30* lin-addr) - :r cpl (mv-nth 1 (wb addr-lst x86)))) - (addr-range *2^30* (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) 30))))) + (create-canonical-address-list *2^30* lin-addr) + :r cpl (mv-nth 1 (wb addr-lst x86)))) + (addr-range *2^30* (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) 30))))) :hints (("Goal" - :do-not '(preprocess) - :do-not-induct t - :use ((:instance las-to-pas-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr-general - (m *2^30*) - (iteration 0)) - (:instance open-mv-nth-1-las-to-pas-for-same-1G-page-general-2)) - :in-theory (e/d* (create-canonical-address-list-alt-is-create-canonical-address-list - direct-map-p) - (member-p-strip-cars-of-remove-duplicate-keys - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not))))) + :do-not '(preprocess) + :do-not-induct t + :use ((:instance las-to-pas-values-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr-general + (m *2^30*) + (iteration 0)) + (:instance open-mv-nth-1-las-to-pas-for-same-1G-page-general-2)) + :in-theory (e/d* (create-canonical-address-list-alt-is-create-canonical-address-list + direct-map-p) + (member-p-strip-cars-of-remove-duplicate-keys + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not))))) ;; ====================================================================== @@ -3413,24 +3443,24 @@ (equal pml4-table-entry-addr (pml4-table-entry-addr lin-addr pml4-table-base-addr)) (equal pdpt-base-addr (pdpt-base-addr lin-addr x86)) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) + (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth - 1 - (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r x86)))) + (combine-bytes + (mv-nth + 1 + (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r x86)))) (direct-map-p 8 pml4-table-entry-addr :r cpl (double-rewrite x86)) (not (mv-nth 0 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86))) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86)) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 pml4-table-entry-addr) x86)) @@ -3459,26 +3489,26 @@ (unsigned-byte-p 30 n) (x86p x86)) (equal (translation-governing-addresses (+ n lin-addr) x86) - (translation-governing-addresses lin-addr x86))) + (translation-governing-addresses lin-addr x86))) :hints (("Goal" - :in-theory (e/d* (translation-governing-addresses - translation-governing-addresses-for-pml4-table - translation-governing-addresses-for-page-dir-ptr-table - disjoint-p$ - direct-map-p - pdpt-base-addr - pml4-table-base-addr) - (commutativity-of-+ - subset-p - (:linear acl2::loghead-upper-bound) - unsigned-byte-p-of-logtail - member-p - member-p-canonical-address-listp - unsigned-byte-p-of-logtail - mv-nth-0-las-to-pas-subset-p - not - pml4-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask))))) + :in-theory (e/d* (translation-governing-addresses + translation-governing-addresses-for-pml4-table + translation-governing-addresses-for-page-dir-ptr-table + disjoint-p$ + direct-map-p + pdpt-base-addr + pml4-table-base-addr) + (commutativity-of-+ + subset-p + (:linear acl2::loghead-upper-bound) + unsigned-byte-p-of-logtail + member-p + member-p-canonical-address-listp + unsigned-byte-p-of-logtail + mv-nth-0-las-to-pas-subset-p + not + pml4-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask))))) (local (defun repeat (n x) @@ -3497,22 +3527,22 @@ (equal pdpt-base-addr (pdpt-base-addr lin-addr x86)) (equal page-dir-ptr-table-entry-addr (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth - 1 - (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r x86)))) + (combine-bytes + (mv-nth + 1 + (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r x86)))) (direct-map-p 8 pml4-table-entry-addr :r cpl (double-rewrite x86)) (not (mv-nth 0 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86))) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86)) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 pml4-table-entry-addr) x86)) @@ -3521,14 +3551,14 @@ (mv-nth 0 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl x86))) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl x86)) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) x86)) @@ -3546,15 +3576,15 @@ (all-translation-governing-addresses (create-canonical-address-list-alt iteration m lin-addr) x86) (repeat (- m iteration) (translation-governing-addresses lin-addr x86)))) :hints (("Goal" - :induct (create-canonical-address-list-alt iteration m lin-addr) - :do-not '(preprocess) - :in-theory (e/d* (all-translation-governing-addresses - translation-governing-addresses-for-same-1G-page) - (member-p-strip-cars-of-remove-duplicate-keys - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not)))))) + :induct (create-canonical-address-list-alt iteration m lin-addr) + :do-not '(preprocess) + :in-theory (e/d* (all-translation-governing-addresses + translation-governing-addresses-for-same-1G-page) + (member-p-strip-cars-of-remove-duplicate-keys + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not)))))) (local (defthmd all-translation-governing-addresses-1G-pages @@ -3564,31 +3594,31 @@ (equal pml4-table-base-addr (pml4-table-base-addr x86)) (equal pml4-table-entry-addr (pml4-table-entry-addr lin-addr pml4-table-base-addr)) (equal pml4-table-entry - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list 8 pml4-table-entry-addr) - :r x86)))) + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list 8 pml4-table-entry-addr) + :r x86)))) (equal pdpt-base-addr (pdpt-base-addr lin-addr x86)) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) + (page-dir-ptr-table-entry-addr lin-addr pdpt-base-addr)) (equal page-dir-ptr-table-entry (combine-bytes (mv-nth - 1 - (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r x86)))) + 1 + (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r x86)))) (direct-map-p 8 pml4-table-entry-addr :r cpl (double-rewrite x86)) (not (mv-nth 0 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86))) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl x86)) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 pml4-table-entry-addr) x86)) @@ -3597,14 +3627,14 @@ (mv-nth 0 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl x86))) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl x86))) (disjoint-p$ (mv-nth 1 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl x86)) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl x86)) (all-translation-governing-addresses (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) x86)) @@ -3612,18 +3642,18 @@ (mv-nth 1 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86))) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86))) (mv-nth 1 (las-to-pas - (create-canonical-address-list 8 pml4-table-entry-addr) - :r cpl (double-rewrite x86)))) + (create-canonical-address-list 8 pml4-table-entry-addr) + :r cpl (double-rewrite x86)))) (equal (page-size page-dir-ptr-table-entry) 1) (not (mv-nth 0 (las-to-pas - (create-canonical-address-list *2^30* lin-addr) - :r cpl (double-rewrite x86)))) + (create-canonical-address-list *2^30* lin-addr) + :r cpl (double-rewrite x86)))) (canonical-address-p (+ 7 pml4-table-entry-addr)) (canonical-address-p (+ 7 page-dir-ptr-table-entry-addr)) @@ -3638,15 +3668,15 @@ (all-translation-governing-addresses (create-canonical-address-list m lin-addr) x86) (repeat m (translation-governing-addresses lin-addr x86)))) :hints (("Goal" - :do-not '(preprocess) - :use ((:instance all-translation-governing-addresses-1G-pages-general - (iteration 0))) - :in-theory (e/d* (create-canonical-address-list-alt-is-create-canonical-address-list) - (member-p-strip-cars-of-remove-duplicate-keys - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not)))))) + :do-not '(preprocess) + :use ((:instance all-translation-governing-addresses-1G-pages-general + (iteration 0))) + :in-theory (e/d* (create-canonical-address-list-alt-is-create-canonical-address-list) + (member-p-strip-cars-of-remove-duplicate-keys + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not)))))) ;; Reading the new translation-governing addresses of a lin-addr, @@ -3655,8 +3685,8 @@ (local (defthmd rm-low-64-and-write-to-physical-memory-disjoint-commuted (implies (disjoint-p p-addrs-2 (addr-range 8 p-addr-1)) - (equal (rm-low-64 p-addr-1 (write-to-physical-memory p-addrs-2 bytes x86)) - (rm-low-64 p-addr-1 x86))) + (equal (rm-low-64 p-addr-1 (write-to-physical-memory p-addrs-2 bytes x86)) + (rm-low-64 p-addr-1 x86))) :hints (("Goal" :in-theory (e/d* (disjoint-p-commutative) ()))))) (defthmd translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr @@ -3669,17 +3699,17 @@ ;; points to a paging entry. (and (syntaxp (not (and (consp lin-addr) - (or (eq (car lin-addr) 'car) - (eq (car lin-addr) 'pml4-table-entry-addr$inline) - (eq (car lin-addr) 'page-dir-ptr-table-entry-addr$inline))))) + (or (eq (car lin-addr) 'car) + (eq (car lin-addr) 'pml4-table-entry-addr$inline) + (eq (car lin-addr) 'page-dir-ptr-table-entry-addr$inline))))) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth - 1 - (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth + 1 + (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) (direct-map-p 8 @@ -3690,16 +3720,16 @@ 0 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list @@ -3732,10 +3762,10 @@ 1 (las-to-pas (create-canonical-address-list - 8 (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + 8 (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) :r cpl (double-rewrite x86)))) (equal (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - (addr-range 8 page-dir-ptr-table-entry-addr)) + (addr-range 8 page-dir-ptr-table-entry-addr)) (disjoint-p (mv-nth 1 @@ -3743,9 +3773,9 @@ (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (strip-cars addr-lst) - (double-rewrite x86))) + (double-rewrite x86))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) 1) (addr-byte-alistp addr-lst) (canonical-address-p @@ -3753,53 +3783,53 @@ (canonical-address-p (+ 7 page-dir-ptr-table-entry-addr)) (x86p x86)) (equal (translation-governing-addresses lin-addr (mv-nth 1 (wb addr-lst x86))) - (translation-governing-addresses lin-addr x86))) + (translation-governing-addresses lin-addr x86))) :hints (("Goal" :do-not-induct t :use ((:instance xlate-equiv-entries-and-page-size - (e-1 (rm-low-64 - (pml4-table-entry-addr - lin-addr - (pml4-table-base-addr x86)) - (mv-nth - 2 - (las-to-pas - (strip-cars addr-lst) :w (cpl x86) - (write-to-physical-memory - (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) x86)) - (strip-cdrs addr-lst) x86))))) - (e-2 (rm-low-64 (pml4-table-entry-addr - lin-addr - (pml4-table-base-addr x86)) - x86)))) + (e-1 (rm-low-64 + (pml4-table-entry-addr + lin-addr + (pml4-table-base-addr x86)) + (mv-nth + 2 + (las-to-pas + (strip-cars addr-lst) :w (cpl x86) + (write-to-physical-memory + (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) x86)) + (strip-cdrs addr-lst) x86))))) + (e-2 (rm-low-64 (pml4-table-entry-addr + lin-addr + (pml4-table-base-addr x86)) + x86)))) :in-theory (e/d* - (disjoint-p$ - wb - direct-map-p - pml4-table-base-addr - pdpt-base-addr - translation-governing-addresses - translation-governing-addresses-for-pml4-table - translation-governing-addresses-for-page-dir-ptr-table - rm-low-64-and-write-to-physical-memory-disjoint-commuted) - - (rm-low-64-and-write-to-physical-memory-disjoint - rewrite-rb-to-rb-alt - subset-p - member-p - cdr-mv-nth-1-las-to-pas - mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p - member-p-canonical-address-listp - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt - mv-nth-0-las-to-pas-subset-p - (:linear adding-7-to-pml4-table-entry-addr) - member-p-strip-cars-of-remove-duplicate-keys - pml4-table-entry-addr-to-c-program-optimized-form - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - (:meta acl2::mv-nth-cons-meta) - not force (force)))))) + (disjoint-p$ + wb + direct-map-p + pml4-table-base-addr + pdpt-base-addr + translation-governing-addresses + translation-governing-addresses-for-pml4-table + translation-governing-addresses-for-page-dir-ptr-table + rm-low-64-and-write-to-physical-memory-disjoint-commuted) + + (rm-low-64-and-write-to-physical-memory-disjoint + rewrite-rb-to-rb-alt + subset-p + member-p + cdr-mv-nth-1-las-to-pas + mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p + member-p-canonical-address-listp + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt + mv-nth-0-las-to-pas-subset-p + (:linear adding-7-to-pml4-table-entry-addr) + member-p-strip-cars-of-remove-duplicate-keys + pml4-table-entry-addr-to-c-program-optimized-form + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + (:meta acl2::mv-nth-cons-meta) + not force (force)))))) (local @@ -3807,15 +3837,15 @@ (implies (and (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr - lin-addr - (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr + lin-addr + (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth - 1 - (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth + 1 + (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) (direct-map-p 8 @@ -3825,21 +3855,21 @@ (mv-nth 0 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) - :r cpl (double-rewrite x86)))) + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) - :r cpl (double-rewrite x86))) + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list - 8 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) (double-rewrite x86))) (direct-map-p 8 page-dir-ptr-table-entry-addr :r cpl (double-rewrite x86)) @@ -3848,14 +3878,14 @@ (mv-nth 0 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86)))) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86))) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) (double-rewrite x86))) @@ -3863,26 +3893,26 @@ (mv-nth 1 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86))) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86))) (mv-nth 1 (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) - :r cpl (double-rewrite x86)))) + (create-canonical-address-list + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + :r cpl (double-rewrite x86)))) (equal (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - (addr-range 8 page-dir-ptr-table-entry-addr)) + (addr-range 8 page-dir-ptr-table-entry-addr)) (disjoint-p (mv-nth 1 (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86))) + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86))) (all-translation-governing-addresses (strip-cars addr-lst) (double-rewrite x86))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (addr-byte-alistp addr-lst) (canonical-address-p (+ 7 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86))))) @@ -3897,111 +3927,111 @@ (equal (page-size (rm-low-64 (pml4-table-entry-addr - lin-addr - (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) - (mv-nth 1 (wb addr-lst x86)))) + lin-addr + (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) + (mv-nth 1 (wb addr-lst x86)))) (page-size (rm-low-64 (pml4-table-entry-addr - lin-addr - (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) - x86))) + lin-addr + (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) + x86))) (equal (page-size (rm-low-64 - (page-dir-ptr-table-entry-addr - lin-addr - (ash - (loghead - 40 - (logtail - 12 - (rm-low-64 (pml4-table-entry-addr - lin-addr - (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) - 12)) - x86))) - 12)) - x86)) + (page-dir-ptr-table-entry-addr + lin-addr + (ash + (loghead + 40 + (logtail + 12 + (rm-low-64 (pml4-table-entry-addr + lin-addr + (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) + 12)) + x86))) + 12)) + x86)) (page-size (rm-low-64 - (page-dir-ptr-table-entry-addr - lin-addr - (ash - (loghead - 40 - (logtail - 12 - (rm-low-64 (pml4-table-entry-addr - lin-addr - (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) - x86))) - 12)) - (mv-nth 1 (wb addr-lst x86))))) + (page-dir-ptr-table-entry-addr + lin-addr + (ash + (loghead + 40 + (logtail + 12 + (rm-low-64 (pml4-table-entry-addr + lin-addr + (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) + x86))) + 12)) + (mv-nth 1 (wb addr-lst x86))))) (equal (logtail 12 (rm-low-64 (pml4-table-entry-addr - lin-addr - (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) - (mv-nth 1 (wb addr-lst x86)))) + lin-addr + (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) + (mv-nth 1 (wb addr-lst x86)))) (logtail 12 (rm-low-64 (pml4-table-entry-addr - lin-addr - (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) - x86))))) + lin-addr + (ash (loghead 40 (logtail 12 (xr :ctr *cr3* x86))) 12)) + x86))))) :hints (("Goal" - :do-not-induct t - :use ((:instance xlate-equiv-entries-and-page-size - (e-1 (rm-low-64 - (pml4-table-entry-addr - lin-addr (pml4-table-base-addr x86)) - (mv-nth - 2 - (las-to-pas - (strip-cars addr-lst) :w (cpl x86) - (write-to-physical-memory - (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) x86)) - (strip-cdrs addr-lst) - x86))))) - (e-2 (rm-low-64 - (pml4-table-entry-addr - lin-addr (pml4-table-base-addr x86)) - x86)))) - :in-theory (e/d* (disjoint-p$ - wb - direct-map-p - rm-low-64-and-write-to-physical-memory-disjoint-commuted - pml4-table-base-addr - pdpt-base-addr) - (rm-low-64-and-write-to-physical-memory-disjoint - commutativity-of-+ - remove-duplicate-keys - member-p-strip-cars-of-remove-duplicate-keys - pml4-table-entry-addr-to-c-program-optimized-form - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not - bitops::logand-with-negated-bitmask)))))) + :do-not-induct t + :use ((:instance xlate-equiv-entries-and-page-size + (e-1 (rm-low-64 + (pml4-table-entry-addr + lin-addr (pml4-table-base-addr x86)) + (mv-nth + 2 + (las-to-pas + (strip-cars addr-lst) :w (cpl x86) + (write-to-physical-memory + (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) x86)) + (strip-cdrs addr-lst) + x86))))) + (e-2 (rm-low-64 + (pml4-table-entry-addr + lin-addr (pml4-table-base-addr x86)) + x86)))) + :in-theory (e/d* (disjoint-p$ + wb + direct-map-p + rm-low-64-and-write-to-physical-memory-disjoint-commuted + pml4-table-base-addr + pdpt-base-addr) + (rm-low-64-and-write-to-physical-memory-disjoint + commutativity-of-+ + remove-duplicate-keys + member-p-strip-cars-of-remove-duplicate-keys + pml4-table-entry-addr-to-c-program-optimized-form + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not + bitops::logand-with-negated-bitmask)))))) (defthmd translation-governing-addresses-for-same-1G-page-and-wb-to-page-dir-ptr-table-entry-addr (implies (and (syntaxp (not (and (consp lin-addr) - (or (eq (car lin-addr) 'car) - (eq (car lin-addr) 'pml4-table-entry-addr$inline) - (eq (car lin-addr) 'page-dir-ptr-table-entry-addr$inline))))) + (or (eq (car lin-addr) 'car) + (eq (car lin-addr) 'pml4-table-entry-addr$inline) + (eq (car lin-addr) 'page-dir-ptr-table-entry-addr$inline))))) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth - 1 - (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth + 1 + (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) (direct-map-p 8 @@ -4012,16 +4042,16 @@ 0 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list @@ -4054,10 +4084,10 @@ 1 (las-to-pas (create-canonical-address-list - 8 (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + 8 (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) :r cpl (double-rewrite x86)))) (equal (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - (addr-range 8 page-dir-ptr-table-entry-addr)) + (addr-range 8 page-dir-ptr-table-entry-addr)) (disjoint-p (mv-nth 1 @@ -4065,9 +4095,9 @@ (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (strip-cars addr-lst) - (double-rewrite x86))) + (double-rewrite x86))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) 1) (addr-byte-alistp addr-lst) (canonical-address-p @@ -4081,47 +4111,47 @@ (not (programmer-level-mode x86)) (x86p x86)) (equal (translation-governing-addresses (+ n lin-addr) (mv-nth 1 (wb addr-lst x86))) - (translation-governing-addresses lin-addr x86))) + (translation-governing-addresses lin-addr x86))) :hints (("Goal" - :do-not-induct t - :use ((:instance translation-governing-addresses-for-same-1G-page-and-wb-to-page-dir-ptr-table-entry-addr-helper)) - :in-theory (e/d* (translation-governing-addresses-for-same-1G-page - translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr - translation-governing-addresses - translation-governing-addresses-for-pml4-table - translation-governing-addresses-for-page-dir-ptr-table - pdpt-base-addr - pml4-table-base-addr) - (mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt - subset-p - member-p - mv-nth-0-las-to-pas-subset-p - cdr-mv-nth-1-las-to-pas - mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p - r-w-x-is-irrelevant-for-mv-nth-1-las-to-pas-when-no-errors - member-p-canonical-address-listp - mv-nth-1-las-to-pas-subset-p - car-create-canonical-address-list - consp-of-create-canonical-address-list - commutativity-of-+ - remove-duplicate-keys - member-p-strip-cars-of-remove-duplicate-keys - pml4-table-entry-addr-to-c-program-optimized-form - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not - bitops::logand-with-negated-bitmask))))) + :do-not-induct t + :use ((:instance translation-governing-addresses-for-same-1G-page-and-wb-to-page-dir-ptr-table-entry-addr-helper)) + :in-theory (e/d* (translation-governing-addresses-for-same-1G-page + translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr + translation-governing-addresses + translation-governing-addresses-for-pml4-table + translation-governing-addresses-for-page-dir-ptr-table + pdpt-base-addr + pml4-table-base-addr) + (mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt + subset-p + member-p + mv-nth-0-las-to-pas-subset-p + cdr-mv-nth-1-las-to-pas + mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p + r-w-x-is-irrelevant-for-mv-nth-1-las-to-pas-when-no-errors + member-p-canonical-address-listp + mv-nth-1-las-to-pas-subset-p + car-create-canonical-address-list + consp-of-create-canonical-address-list + commutativity-of-+ + remove-duplicate-keys + member-p-strip-cars-of-remove-duplicate-keys + pml4-table-entry-addr-to-c-program-optimized-form + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not + bitops::logand-with-negated-bitmask))))) (defthmd all-translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr-general (implies (and (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth 1 (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) ;; PML4TE is direct-mapped. @@ -4133,16 +4163,16 @@ 0 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list @@ -4185,30 +4215,30 @@ ;; (addr-range 8 page-dir-ptr-table-entry-addr)) (equal (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) - (addr-range 8 page-dir-ptr-table-entry-addr)) + (addr-range 8 page-dir-ptr-table-entry-addr)) (disjoint-p (mv-nth 1 - (las-to-pas - (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r cpl (double-rewrite x86))) + (las-to-pas + (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r cpl (double-rewrite x86))) (all-translation-governing-addresses (strip-cars addr-lst) (double-rewrite x86))) (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes (strip-cdrs addr-lst)))) + (page-present (combine-bytes (strip-cdrs addr-lst)))) (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes (strip-cdrs addr-lst)))) + (page-read-write (combine-bytes (strip-cdrs addr-lst)))) (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) + (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) + (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) 1) (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) + (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) (addr-byte-alistp addr-lst) (canonical-address-p (+ 7 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86))))) @@ -4227,20 +4257,20 @@ (all-translation-governing-addresses (create-canonical-address-list-alt iteration m lin-addr) x86))) :hints (("Goal" - :induct (create-canonical-address-list-alt iteration m lin-addr) - :do-not '(preprocess) - :in-theory (e/d* (all-translation-governing-addresses - translation-governing-addresses-for-same-1G-page - translation-governing-addresses-for-same-1G-page-and-wb-to-page-dir-ptr-table-entry-addr - translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr - all-translation-governing-addresses-1G-pages-general) - (member-p - subset-p - member-p-strip-cars-of-remove-duplicate-keys - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not))))) + :induct (create-canonical-address-list-alt iteration m lin-addr) + :do-not '(preprocess) + :in-theory (e/d* (all-translation-governing-addresses + translation-governing-addresses-for-same-1G-page + translation-governing-addresses-for-same-1G-page-and-wb-to-page-dir-ptr-table-entry-addr + translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr + all-translation-governing-addresses-1G-pages-general) + (member-p + subset-p + member-p-strip-cars-of-remove-duplicate-keys + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not))))) (defthm all-translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr (implies @@ -4248,18 +4278,18 @@ ;; Restrict this rule so that it fires when lin-addr is either (XR ;; :RGF *RSI* X86) or (XR :RGF *RDI* X86) or lin-addr. (syntaxp (or - (eq lin-addr '(XR ':RGF '6 X86)) - (eq lin-addr '(XR ':RGF '7 X86)) - (eq lin-addr 'lin-addr))) + (eq lin-addr '(XR ':RGF '6 X86)) + (eq lin-addr '(XR ':RGF '7 X86)) + (eq lin-addr 'lin-addr))) (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr - lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr + lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth - 1 - (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth + 1 + (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) (direct-map-p 8 @@ -4270,8 +4300,8 @@ 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list @@ -4299,8 +4329,8 @@ 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86)))) (equal (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86))) @@ -4318,18 +4348,18 @@ (all-translation-governing-addresses (strip-cars addr-lst) (double-rewrite x86))) (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes (strip-cdrs addr-lst)))) + (page-present (combine-bytes (strip-cdrs addr-lst)))) (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes (strip-cdrs addr-lst)))) + (page-read-write (combine-bytes (strip-cdrs addr-lst)))) (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) + (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) + (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) 1) (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) + (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) (addr-byte-alistp addr-lst) (canonical-address-p (+ 7 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86))))) (canonical-address-p (+ 7 page-dir-ptr-table-entry-addr)) @@ -4343,26 +4373,26 @@ (all-translation-governing-addresses (create-canonical-address-list m lin-addr) (double-rewrite x86)))) :hints (("Goal" - :do-not-induct t - :do-not '(preprocess) - :use ((:instance all-translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr-general - (iteration 0))) - :in-theory (e/d* (create-canonical-address-list-alt-is-create-canonical-address-list - direct-map-p - las-to-pas) - (all-translation-governing-addresses - mv-nth-0-las-to-pas-subset-p - subset-p - mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p - member-p - rewrite-rb-to-rb-alt - rb-and-rm-low-64-for-direct-map - translation-governing-addresses-for-same-1G-page - member-p-strip-cars-of-remove-duplicate-keys - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not))))) + :do-not-induct t + :do-not '(preprocess) + :use ((:instance all-translation-governing-addresses-1G-pages-and-wb-to-page-dir-ptr-table-entry-addr-general + (iteration 0))) + :in-theory (e/d* (create-canonical-address-list-alt-is-create-canonical-address-list + direct-map-p + las-to-pas) + (all-translation-governing-addresses + mv-nth-0-las-to-pas-subset-p + subset-p + mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p + member-p + rewrite-rb-to-rb-alt + rb-and-rm-low-64-for-direct-map + translation-governing-addresses-for-same-1G-page + member-p-strip-cars-of-remove-duplicate-keys + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not))))) ;; ====================================================================== @@ -4372,14 +4402,14 @@ (implies (and (equal page-dir-ptr-table-entry-addr - (page-dir-ptr-table-entry-addr - lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) + (page-dir-ptr-table-entry-addr + lin-addr (pdpt-base-addr lin-addr (double-rewrite x86)))) (equal page-dir-ptr-table-entry - (combine-bytes - (mv-nth - 1 - (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) - :r (double-rewrite x86))))) + (combine-bytes + (mv-nth + 1 + (rb (create-canonical-address-list 8 page-dir-ptr-table-entry-addr) + :r (double-rewrite x86))))) (equal cpl (cpl x86)) (direct-map-p @@ -4390,16 +4420,16 @@ 0 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86)))) :r cpl (double-rewrite x86))) (all-translation-governing-addresses (create-canonical-address-list @@ -4427,8 +4457,8 @@ 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) + 8 + (pml4-table-entry-addr lin-addr (pml4-table-base-addr x86))) :r cpl (double-rewrite x86)))) (equal @@ -4448,13 +4478,13 @@ (all-translation-governing-addresses (strip-cars addr-lst) (double-rewrite x86))) (not (mv-nth 0 - (las-to-pas (create-canonical-address-list *2^30* lin-addr) - :r cpl (double-rewrite x86)))) + (las-to-pas (create-canonical-address-list *2^30* lin-addr) + :r cpl (double-rewrite x86)))) (disjoint-p$ (addr-range *2^30* (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) - 30)) + 30)) (open-qword-paddr-list (gather-all-paging-structure-qword-addresses (double-rewrite x86)))) @@ -4462,22 +4492,22 @@ (addr-range *2^30* (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) - 30)) + 30)) (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86)))) (equal (page-present page-dir-ptr-table-entry) - (page-present (combine-bytes (strip-cdrs addr-lst)))) + (page-present (combine-bytes (strip-cdrs addr-lst)))) (equal (page-read-write page-dir-ptr-table-entry) - (page-read-write (combine-bytes (strip-cdrs addr-lst)))) + (page-read-write (combine-bytes (strip-cdrs addr-lst)))) (equal (page-user-supervisor page-dir-ptr-table-entry) - (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) + (page-user-supervisor (combine-bytes (strip-cdrs addr-lst)))) (equal (page-execute-disable page-dir-ptr-table-entry) - (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) + (page-execute-disable (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) - (page-size (combine-bytes (strip-cdrs addr-lst)))) + (page-size (combine-bytes (strip-cdrs addr-lst)))) (equal (page-size page-dir-ptr-table-entry) 1) (equal (part-select page-dir-ptr-table-entry :low 13 :high 29) - (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) + (part-select (combine-bytes (strip-cdrs addr-lst)) :low 13 :high 29)) (addr-byte-alistp addr-lst) (canonical-address-p (+ 7 (pml4-table-entry-addr lin-addr (pml4-table-base-addr (double-rewrite x86))))) @@ -4488,32 +4518,32 @@ (x86p x86)) (and (equal (mv-nth 0 (rb (create-canonical-address-list *2^30* lin-addr) :r (mv-nth 1 (wb addr-lst x86)))) - nil) + nil) (equal (mv-nth 1 (rb - (create-canonical-address-list *2^30* lin-addr) - :r (mv-nth 1 (wb addr-lst x86)))) - (read-from-physical-memory - (addr-range *2^30* - (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) - 30)) - (double-rewrite x86))))) + (create-canonical-address-list *2^30* lin-addr) + :r (mv-nth 1 (wb addr-lst x86)))) + (read-from-physical-memory + (addr-range *2^30* + (ash (loghead 22 (logtail 30 (combine-bytes (strip-cdrs addr-lst)))) + 30)) + (double-rewrite x86))))) :hints (("Goal" - :do-not-induct t - :in-theory (e/d* (rb) - (subset-p - mv-nth-0-las-to-pas-subset-p - member-p - unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode - unsigned-byte-p-of-combine-bytes - disjoint-p-subset-p - cdr-mv-nth-1-las-to-pas - mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p - member-p-canonical-address-listp - member-p-strip-cars-of-remove-duplicate-keys - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - bitops::logand-with-negated-bitmask - force (force) - not))))) + :do-not-induct t + :in-theory (e/d* (rb) + (subset-p + mv-nth-0-las-to-pas-subset-p + member-p + unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode + unsigned-byte-p-of-combine-bytes + disjoint-p-subset-p + cdr-mv-nth-1-las-to-pas + mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p + member-p-canonical-address-listp + member-p-strip-cars-of-remove-duplicate-keys + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + bitops::logand-with-negated-bitmask + force (force) + not))))) ;; ====================================================================== @@ -4531,8 +4561,8 @@ (create-canonical-address-list 8 (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) :w (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) @@ -4548,12 +4578,12 @@ (create-canonical-address-list 8 (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) :w (cpl x86) x86)) (mv-nth 1 - (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) x86))) + (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r (cpl x86) x86))) ;; The stack is disjoint from the source physical ;; addresses. @@ -4564,27 +4594,27 @@ (create-canonical-address-list 8 (+ -24 (xr :rgf *rsp* x86))) :w (cpl x86) x86)) (mv-nth 1 - (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) x86))) + (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r (cpl x86) x86))) ;; Source physical addresses are disjoint from the paging ;; structures' physical addresses. (disjoint-p$ (mv-nth 1 (las-to-pas (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r (cpl x86) x86)) + :r (cpl x86) x86)) (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86))) ;; The source PDPTE physical addresses are disjoint from ;; the source PML4TE physical addresses. (disjoint-p$ (mv-nth 1 - (las-to-pas (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r 0 x86)) + (las-to-pas (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r 0 x86)) (mv-nth 1 (las-to-pas @@ -4604,43 +4634,43 @@ (defthmd source-data-from-initial-state-in-terms-of-read-from-physical-memory-and-addr-range (implies (and (rewire_dst_to_src-effects-preconditions x86) - (source-data-preconditions x86)) - (equal - (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r x86)) - (read-from-physical-memory - (addr-range - *2^30* (ash (loghead 22 - (logtail - 30 - (rm-low-64 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) - x86))) - 30)) - x86))) + (source-data-preconditions x86)) + (equal + (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r x86)) + (read-from-physical-memory + (addr-range + *2^30* (ash (loghead 22 + (logtail + 30 + (rm-low-64 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) + x86))) + 30)) + x86))) :hints (("Goal" - :do-not-induct t - :in-theory (e/d* - (page-size - las-to-pas-values-for-same-1G-page - source-data-from-initial-state-in-terms-of-read-from-physical-memory-and-las-to-pas) - (subset-p - member-p - mv-nth-0-las-to-pas-subset-p - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt - two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas - len-of-rb-in-system-level-mode - rewrite-rb-to-rb-alt - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 - unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode - mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs - (:meta acl2::mv-nth-cons-meta) - create-canonical-address-list - mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free - acl2::loghead-identity))))) + :do-not-induct t + :in-theory (e/d* + (page-size + las-to-pas-values-for-same-1G-page + source-data-from-initial-state-in-terms-of-read-from-physical-memory-and-las-to-pas) + (subset-p + member-p + mv-nth-0-las-to-pas-subset-p + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt + two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas + len-of-rb-in-system-level-mode + rewrite-rb-to-rb-alt + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 + unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode + mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs + (:meta acl2::mv-nth-cons-meta) + create-canonical-address-list + mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free + acl2::loghead-identity))))) ;; ====================================================================== @@ -4666,13 +4696,13 @@ (direct-map-p 8 (page-dir-ptr-table-entry-addr (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) :r (cpl x86) x86) ;; Destination PML4TE is direct-mapped. (direct-map-p 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86)) - :r (cpl x86) x86) + (pml4-table-entry-addr (xr :rgf *rsi* x86) + (pml4-table-base-addr x86)) + :r (cpl x86) x86) ;; The destination PML4TE physical addresses are disjoint from the ;; translation-governing addresses of the destination PDPTE. @@ -4680,15 +4710,15 @@ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) - :r (cpl x86) x86)) + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) + (pml4-table-base-addr x86))) + :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 (page-dir-ptr-table-entry-addr (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) x86)) ;; Destination PDPTE physical addresses are disjoint from the ;; destination PML4TE physical addresses. @@ -4696,11 +4726,11 @@ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :w (cpl x86) x86)) + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :w (cpl x86) x86)) (mv-nth 1 (las-to-pas @@ -4715,11 +4745,11 @@ (addr-range *2^30* (ash (loghead 22 - (logtail 30 - (rm-low-64 (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) - 30)) + (logtail 30 + (rm-low-64 (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) + 30)) (mv-nth 1 (las-to-pas (create-canonical-address-list 8 (+ -24 (xr :rgf *rsp* x86))) :w (cpl x86) x86))) @@ -4730,12 +4760,12 @@ (addr-range *2^30* (ash (loghead 22 - (logtail - 30 - (rm-low-64 (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) - 30)) + (logtail + 30 + (rm-low-64 (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) + 30)) (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86))))) (defun-nx throwaway-destination-data-preconditions (x86) @@ -4747,25 +4777,25 @@ (addr-range *2^30* (ash (loghead 22 - (logtail - 30 - (rm-low-64 (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) - 30)) + (logtail + 30 + (rm-low-64 (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) + 30)) (addr-range 8 (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86)))) + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86)))) ;; This should follow from ;; destination-PDPTE-and-destination-PML4TE-no-interfere-p ;; (disjoint-p$ issue) and direct map of destination PDPTE. (disjoint-p (addr-range 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) (all-translation-governing-addresses (create-canonical-address-list 8 @@ -4776,14 +4806,14 @@ ;; issue) and direct map of destination PDPTE. (disjoint-p (addr-range 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) (all-translation-governing-addresses (create-canonical-address-list 8 (pml4-table-entry-addr (xr :rgf *rdi* x86) - (pml4-table-base-addr x86))) + (pml4-table-base-addr x86))) x86)) ;; This should follow from @@ -4791,9 +4821,9 @@ ;; issue) and direct map of destination PDPTE. (disjoint-p (addr-range 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) (all-translation-governing-addresses (create-canonical-address-list 8 @@ -4811,13 +4841,13 @@ (create-canonical-address-list 8 (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) + (pml4-table-base-addr x86))) :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) + (pml4-table-base-addr x86))) x86)) ;; disjoint-p$ issue @@ -4829,7 +4859,7 @@ (create-canonical-address-list 8 (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) + (pml4-table-base-addr x86))) :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list @@ -4848,13 +4878,13 @@ (create-canonical-address-list 8 (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) + (pml4-table-base-addr x86))) :r (cpl x86) x86)) (all-translation-governing-addresses (create-canonical-address-list 8 (pml4-table-entry-addr (xr :rgf *rdi* x86) - (pml4-table-base-addr x86))) + (pml4-table-base-addr x86))) x86)) @@ -4868,10 +4898,10 @@ (mv-nth 1 (las-to-pas (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) - :r (cpl x86) x86))) + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) + (pml4-table-base-addr x86))) + :r (cpl x86) x86))) ;; disjoint-p$ issue ;; Follows from destination-PDPTE-and-stack-no-interfere-p. @@ -4887,506 +4917,506 @@ (create-canonical-address-list 8 (page-dir-ptr-table-entry-addr (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) :r (cpl x86) x86))))) (local (defthmd destination-pdpte-is-in-all-paging-structures (implies (and - (x86-state-okp x86) - (destination-addresses-ok-p x86) - (destination-pml4te-ok-p x86) - (direct-map-p - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86)) - :r (cpl x86) x86)) - (subset-p - (addr-range - 8 (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86)))) + (x86-state-okp x86) + (destination-addresses-ok-p x86) + (destination-pml4te-ok-p x86) + (direct-map-p + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) + (pml4-table-base-addr x86)) + :r (cpl x86) x86)) + (subset-p + (addr-range + 8 (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86)))) :hints (("Goal" - :hands-off (disjoint-p) - :in-theory (e/d* (direct-map-p pdpt-base-addr page-size) - (page-dir-ptr-table-entry-addr - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - canonical-address-p-page-dir-ptr-table-entry-addr-to-c-program-optimized-form)))))) + :hands-off (disjoint-p) + :in-theory (e/d* (direct-map-p pdpt-base-addr page-size) + (page-dir-ptr-table-entry-addr + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + canonical-address-p-page-dir-ptr-table-entry-addr-to-c-program-optimized-form)))))) (local (defthmd throwaway-destination-data-preconditions-lemma-helper (implies (and - (x86-state-okp x86) - (destination-addresses-ok-p x86) - (destination-pml4te-ok-p x86) - (direct-map-p - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86)) - :r (cpl x86) x86) - (disjoint-p$ - (addr-range - *2^30* - (ash (loghead 22 - (logtail - 30 - (rm-low-64 (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) - 30)) - (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86)))) - (disjoint-p - (addr-range - *2^30* - (ash (loghead 22 - (logtail - 30 - (rm-low-64 (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) - 30)) - (addr-range - 8 (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))))) + (x86-state-okp x86) + (destination-addresses-ok-p x86) + (destination-pml4te-ok-p x86) + (direct-map-p + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) + (pml4-table-base-addr x86)) + :r (cpl x86) x86) + (disjoint-p$ + (addr-range + *2^30* + (ash (loghead 22 + (logtail + 30 + (rm-low-64 (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) + 30)) + (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86)))) + (disjoint-p + (addr-range + *2^30* + (ash (loghead 22 + (logtail + 30 + (rm-low-64 (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) + 30)) + (addr-range + 8 (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))))) :hints (("Goal" - :hands-off (disjoint-p) - :use ((:instance destination-pdpte-is-in-all-paging-structures) - (:instance disjoint-p-subset-p - (x (addr-range - *2^30* - (ash (loghead 22 - (logtail - 30 - (rm-low-64 (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) - 30))) - (y (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86))) - (a (addr-range - *2^30* - (ash (loghead 22 - (logtail - 30 - (rm-low-64 (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) - 30))) - (b (addr-range - 8 (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86)))))) - :in-theory (e/d* (disjoint-p$ - subset-p) - (disjoint-p-subset-p - page-dir-ptr-table-entry-addr - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - canonical-address-p-page-dir-ptr-table-entry-addr-to-c-program-optimized-form)))))) + :hands-off (disjoint-p) + :use ((:instance destination-pdpte-is-in-all-paging-structures) + (:instance disjoint-p-subset-p + (x (addr-range + *2^30* + (ash (loghead 22 + (logtail + 30 + (rm-low-64 (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) + 30))) + (y (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86))) + (a (addr-range + *2^30* + (ash (loghead 22 + (logtail + 30 + (rm-low-64 (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) x86))) + 30))) + (b (addr-range + 8 (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86)))))) + :in-theory (e/d* (disjoint-p$ + subset-p) + (disjoint-p-subset-p + page-dir-ptr-table-entry-addr + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + canonical-address-p-page-dir-ptr-table-entry-addr-to-c-program-optimized-form)))))) (local (defthmd throwaway-destination-data-preconditions-lemma (implies (and (rewire_dst_to_src-effects-preconditions x86) - (destination-data-preconditions x86)) - (throwaway-destination-data-preconditions x86)) + (destination-data-preconditions x86)) + (throwaway-destination-data-preconditions x86)) :hints (("Goal" - :hands-off (disjoint-p) - :use ((:instance throwaway-destination-data-preconditions-lemma-helper)) - :in-theory (e/d* (direct-map-p - disjoint-p$) - ((:rewrite mv-nth-0-las-to-pas-subset-p) - (:definition subset-p) - (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) - (:rewrite len-of-rb-in-system-level-mode) - (:rewrite acl2::loghead-identity) - (:definition member-p) - (:rewrite page-dir-ptr-table-entry-addr-to-c-program-optimized-form) - (:rewrite subset-p-two-create-canonical-address-lists-general) - (:rewrite unsigned-byte-p-of-combine-bytes) - (:rewrite member-p-canonical-address-listp) - (:linear adding-7-to-page-dir-ptr-table-entry-addr) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:linear *physical-address-size*p-page-dir-ptr-table-entry-addr) - (:linear size-of-combine-bytes) - (:linear unsigned-byte-p-of-combine-bytes) - (:rewrite cdr-create-canonical-address-list) - (:definition no-duplicates-p) - (:rewrite consp-mv-nth-1-las-to-pas) - (:rewrite member-p-of-not-a-consp) - (:definition create-canonical-address-list) - (:rewrite loghead-of-non-integerp) - (:rewrite default-+-2) - (:type-prescription acl2::|x < y => 0 < -x+y|) - (:rewrite acl2::equal-of-booleans-rewrite) - (:linear rgfi-is-i64p . 2) - (:linear rip-is-i48p . 2) - (:rewrite bitops::unsigned-byte-p-when-unsigned-byte-p-less) - (:rewrite loghead-negative) - (:linear rip-is-i48p . 1) - (:type-prescription subset-p) - (:rewrite default-+-1) - (:linear rgfi-is-i64p . 1) - (:type-prescription member-p) - (:rewrite default-<-2) - (:type-prescription pdpt-base-addr) - (:rewrite default-<-1) - (:rewrite consp-of-create-canonical-address-list) - (:rewrite car-create-canonical-address-list) - (:meta acl2::cancel_plus-equal-correct) - (:meta acl2::cancel_times-equal-correct) - (:rewrite canonical-address-p-limits-thm-3) - (:rewrite subset-p-cdr-y) - (:rewrite member-p-cdr) - (:rewrite canonical-address-p-limits-thm-2) - (:meta acl2::cancel_plus-lessp-correct) - (:rewrite open-mv-nth-1-las-to-pas-for-same-1g-page-general-1) - (:rewrite canonical-address-p-limits-thm-0) - (:linear adding-7-to-pml4-table-entry-addr) - (:rewrite acl2::consp-when-member-equal-of-atom-listp) - (:rewrite member-p-of-subset-is-member-p-of-superset) - (:type-prescription adding-7-to-page-dir-ptr-table-entry-addr) - (:rewrite canonical-address-p-limits-thm-1) - (:rewrite member-p-and-mult-8-qword-paddr-listp) - (:rewrite default-cdr) - (:rewrite default-car) - (:linear *physical-address-size*p-pml4-table-entry-addr) - (:type-prescription booleanp) - (:rewrite subset-p-cdr-x) - (:linear ash-monotone-2) - (:rewrite rationalp-implies-acl2-numberp) - (:type-prescription consp-mv-nth-1-las-to-pas) - (:rewrite acl2::ash-0) - (:rewrite cdr-mv-nth-1-las-to-pas) - (:rewrite acl2::equal-constant-+) - (:definition combine-bytes) - (:type-prescription adding-7-to-pml4-table-entry-addr) - (:rewrite - mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) - (:rewrite acl2::zip-open) - (:type-prescription len) - (:rewrite rb-and-rm-low-64-for-direct-map) - (:rewrite car-mv-nth-1-las-to-pas) - (:definition open-qword-paddr-list) - (:rewrite rewrite-rb-to-rb-alt) - (:rewrite len-of-create-canonical-address-list) - (:definition addr-range) - (:definition byte-listp) - (:rewrite acl2::member-of-cons) - (:definition binary-append) - (:rewrite acl2::ifix-when-not-integerp) - (:definition len) - (:meta acl2::mv-nth-cons-meta) - (:linear acl2::expt->-1) - (:rewrite acl2::append-when-not-consp) - (:type-prescription bitops::ash-natp-type) - (:linear member-p-pos-value) - (:linear member-p-pos-1-value) - (:linear acl2::index-of-<-len) - (:rewrite - mv-nth-1-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) - (:definition n08p$inline) - (:rewrite mv-nth-1-las-to-pas-when-error) - (:rewrite commutativity-of-+) - (:linear mv-nth-1-idiv-spec) - (:linear mv-nth-1-div-spec) - (:rewrite neg-addr-range=nil) - (:rewrite bitops::logbitp-nonzero-of-bit) - (:rewrite right-shift-to-logtail) - (:type-prescription combine-bytes) - (:type-prescription ifix) - (:rewrite car-addr-range) - (:type-prescription zip) - (:type-prescription gather-all-paging-structure-qword-addresses) - (:rewrite unsigned-byte-p-of-logtail) - (:rewrite unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode) - (:linear combine-bytes-size-for-rm64-programmer-level-mode) - (:rewrite acl2::subsetp-member . 2) - (:rewrite acl2::subsetp-member . 1) - (:rewrite acl2::logtail-identity) - (:rewrite cdr-addr-range) - (:rewrite ia32e-la-to-pa-in-programmer-level-mode) - (:rewrite canonical-address-p-rip) - (:type-prescription n64p-rm-low-64) - (:rewrite - mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) - (:rewrite mv-nth-1-ia32e-la-to-pa-when-error) - (:rewrite bitops::logbitp-when-bitmaskp) - (:type-prescription signed-byte-p) - (:type-prescription n52p-mv-nth-1-ia32e-la-to-pa) - (:rewrite acl2::logext-identity) - (:rewrite open-mv-nth-0-las-to-pas-for-same-1g-page-general-2) - (:rewrite acl2::expt-with-violated-guards) - (:rewrite no-duplicates-p-and-append) - (:type-prescription bitp) - (:type-prescription acl2::bitmaskp$inline) - (:rewrite loghead-30-of-1g-aligned-lin-addr-+-n-2) - (:rewrite rm-low-64-in-programmer-level-mode) - (:type-prescription natp) - (:rewrite bitops::signed-byte-p-when-unsigned-byte-p-smaller) - (:rewrite bitops::signed-byte-p-when-signed-byte-p-smaller) - (:rewrite bitops::signed-byte-p-monotonicity) - (:type-prescription member-equal) - (:linear acl2::expt-is-increasing-for-base>1) - (:definition member-equal) - (:rewrite subset-p-cons-member-p-lemma) - (:rewrite r-w-x-is-irrelevant-for-mv-nth-1-ia32e-la-to-pa-when-no-errors) - (:rewrite not-member-p-when-disjoint-p) - (:rewrite member-p-start-rip-of-create-canonical-address-list) - (:rewrite bitops::normalize-logbitp-when-mods-equal) - (:rewrite bitops::logbitp-of-negative-const) - (:rewrite bitops::logbitp-of-mask) - (:rewrite bitops::logbitp-of-const) - (:rewrite greater-logbitp-of-unsigned-byte-p . 1) - (:meta bitops::open-logbitp-of-const-lite-meta) - (:rewrite - xlate-equiv-structures-and-logtail-30-rm-low-64-with-page-dir-ptr-table-entry-addr) - (:rewrite - all-mem-except-paging-structures-equal-aux-and-rm-low-64-from-rest-of-memory) - (:rewrite - all-mem-except-paging-structures-equal-and-rm-low-64-from-rest-of-memory) - (:linear bitops::expt-2-lower-bound-by-logbitp))))))) + :hands-off (disjoint-p) + :use ((:instance throwaway-destination-data-preconditions-lemma-helper)) + :in-theory (e/d* (direct-map-p + disjoint-p$) + ((:rewrite mv-nth-0-las-to-pas-subset-p) + (:definition subset-p) + (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) + (:rewrite len-of-rb-in-system-level-mode) + (:rewrite acl2::loghead-identity) + (:definition member-p) + (:rewrite page-dir-ptr-table-entry-addr-to-c-program-optimized-form) + (:rewrite subset-p-two-create-canonical-address-lists-general) + (:rewrite unsigned-byte-p-of-combine-bytes) + (:rewrite member-p-canonical-address-listp) + (:linear adding-7-to-page-dir-ptr-table-entry-addr) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:linear *physical-address-size*p-page-dir-ptr-table-entry-addr) + (:linear size-of-combine-bytes) + (:linear unsigned-byte-p-of-combine-bytes) + (:rewrite cdr-create-canonical-address-list) + (:definition no-duplicates-p) + (:rewrite consp-mv-nth-1-las-to-pas) + (:rewrite member-p-of-not-a-consp) + (:definition create-canonical-address-list) + (:rewrite loghead-of-non-integerp) + (:rewrite default-+-2) + (:type-prescription acl2::|x < y => 0 < -x+y|) + (:rewrite acl2::equal-of-booleans-rewrite) + (:linear rgfi-is-i64p . 2) + (:linear rip-is-i48p . 2) + (:rewrite bitops::unsigned-byte-p-when-unsigned-byte-p-less) + (:rewrite loghead-negative) + (:linear rip-is-i48p . 1) + (:type-prescription subset-p) + (:rewrite default-+-1) + (:linear rgfi-is-i64p . 1) + (:type-prescription member-p) + (:rewrite default-<-2) + (:type-prescription pdpt-base-addr) + (:rewrite default-<-1) + (:rewrite consp-of-create-canonical-address-list) + (:rewrite car-create-canonical-address-list) + (:meta acl2::cancel_plus-equal-correct) + (:meta acl2::cancel_times-equal-correct) + (:rewrite canonical-address-p-limits-thm-3) + (:rewrite subset-p-cdr-y) + (:rewrite member-p-cdr) + (:rewrite canonical-address-p-limits-thm-2) + (:meta acl2::cancel_plus-lessp-correct) + (:rewrite open-mv-nth-1-las-to-pas-for-same-1g-page-general-1) + (:rewrite canonical-address-p-limits-thm-0) + (:linear adding-7-to-pml4-table-entry-addr) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite member-p-of-subset-is-member-p-of-superset) + (:type-prescription adding-7-to-page-dir-ptr-table-entry-addr) + (:rewrite canonical-address-p-limits-thm-1) + (:rewrite member-p-and-mult-8-qword-paddr-listp) + (:rewrite default-cdr) + (:rewrite default-car) + (:linear *physical-address-size*p-pml4-table-entry-addr) + (:type-prescription booleanp) + (:rewrite subset-p-cdr-x) + (:linear ash-monotone-2) + (:rewrite rationalp-implies-acl2-numberp) + (:type-prescription consp-mv-nth-1-las-to-pas) + (:rewrite acl2::ash-0) + (:rewrite cdr-mv-nth-1-las-to-pas) + (:rewrite acl2::equal-constant-+) + (:definition combine-bytes) + (:type-prescription adding-7-to-pml4-table-entry-addr) + (:rewrite + mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) + (:rewrite acl2::zip-open) + (:type-prescription len) + (:rewrite rb-and-rm-low-64-for-direct-map) + (:rewrite car-mv-nth-1-las-to-pas) + (:definition open-qword-paddr-list) + (:rewrite rewrite-rb-to-rb-alt) + (:rewrite len-of-create-canonical-address-list) + (:definition addr-range) + (:definition byte-listp) + (:rewrite acl2::member-of-cons) + (:definition binary-append) + (:rewrite acl2::ifix-when-not-integerp) + (:definition len) + (:meta acl2::mv-nth-cons-meta) + (:linear acl2::expt->-1) + (:rewrite acl2::append-when-not-consp) + (:type-prescription bitops::ash-natp-type) + (:linear member-p-pos-value) + (:linear member-p-pos-1-value) + (:linear acl2::index-of-<-len) + (:rewrite + mv-nth-1-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) + (:definition n08p$inline) + (:rewrite mv-nth-1-las-to-pas-when-error) + (:rewrite commutativity-of-+) + (:linear mv-nth-1-idiv-spec) + (:linear mv-nth-1-div-spec) + (:rewrite neg-addr-range=nil) + (:rewrite bitops::logbitp-nonzero-of-bit) + (:rewrite right-shift-to-logtail) + (:type-prescription combine-bytes) + (:type-prescription ifix) + (:rewrite car-addr-range) + (:type-prescription zip) + (:type-prescription gather-all-paging-structure-qword-addresses) + (:rewrite unsigned-byte-p-of-logtail) + (:rewrite unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode) + ;; (:linear combine-bytes-size-for-rm64-programmer-level-mode) + (:rewrite acl2::subsetp-member . 2) + (:rewrite acl2::subsetp-member . 1) + (:rewrite acl2::logtail-identity) + (:rewrite cdr-addr-range) + (:rewrite ia32e-la-to-pa-in-programmer-level-mode) + (:rewrite canonical-address-p-rip) + (:type-prescription n64p-rm-low-64) + (:rewrite + mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) + (:rewrite mv-nth-1-ia32e-la-to-pa-when-error) + (:rewrite bitops::logbitp-when-bitmaskp) + (:type-prescription signed-byte-p) + (:type-prescription n52p-mv-nth-1-ia32e-la-to-pa) + (:rewrite acl2::logext-identity) + (:rewrite open-mv-nth-0-las-to-pas-for-same-1g-page-general-2) + (:rewrite acl2::expt-with-violated-guards) + (:rewrite no-duplicates-p-and-append) + (:type-prescription bitp) + (:type-prescription acl2::bitmaskp$inline) + (:rewrite loghead-30-of-1g-aligned-lin-addr-+-n-2) + (:rewrite rm-low-64-in-programmer-level-mode) + (:type-prescription natp) + (:rewrite bitops::signed-byte-p-when-unsigned-byte-p-smaller) + (:rewrite bitops::signed-byte-p-when-signed-byte-p-smaller) + (:rewrite bitops::signed-byte-p-monotonicity) + (:type-prescription member-equal) + (:linear acl2::expt-is-increasing-for-base>1) + (:definition member-equal) + (:rewrite subset-p-cons-member-p-lemma) + (:rewrite r-w-x-is-irrelevant-for-mv-nth-1-ia32e-la-to-pa-when-no-errors) + (:rewrite not-member-p-when-disjoint-p) + (:rewrite member-p-start-rip-of-create-canonical-address-list) + (:rewrite bitops::normalize-logbitp-when-mods-equal) + (:rewrite bitops::logbitp-of-negative-const) + (:rewrite bitops::logbitp-of-mask) + (:rewrite bitops::logbitp-of-const) + (:rewrite greater-logbitp-of-unsigned-byte-p . 1) + (:meta bitops::open-logbitp-of-const-lite-meta) + (:rewrite + xlate-equiv-structures-and-logtail-30-rm-low-64-with-page-dir-ptr-table-entry-addr) + (:rewrite + all-mem-except-paging-structures-equal-aux-and-rm-low-64-from-rest-of-memory) + (:rewrite + all-mem-except-paging-structures-equal-and-rm-low-64-from-rest-of-memory) + (:linear bitops::expt-2-lower-bound-by-logbitp))))))) (defthmd pdpte-base-addr-from-final-state-helper (implies (and - (rewire_dst_to_src-effects-preconditions x86) - (throwaway-destination-data-preconditions x86) - (destination-data-preconditions x86)) - - (equal - (pdpt-base-addr - (xr :rgf *rsi* x86) - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list 6 - (+ 184 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list 40 - (+ 144 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 3 - (+ 140 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) - :r - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 32 - (+ 108 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 18 - (+ 86 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 40 - (+ 46 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 4 - (+ 38 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr - (xr :rgf *rdi* x86) - (pml4-table-base-addr x86))) - :r - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 25 - (+ 13 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (+ -24 (xr :rgf *rsp* x86))) - :r - 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 5 - (+ 8 (xr :rip 0 x86))) - :x - 0 - (mv-nth - 1 - (wb - (create-addr-bytes-alist - (create-canonical-address-list - 8 - (+ -24 (xr :rgf *rsp* x86))) - (byte-ify 8 (xr :ctr 3 x86))) - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (xr :rip 0 x86)) - :x - 0 - x86))))))))))))))))))))))))))))))))) - (pdpt-base-addr - (xr :rgf *rsi* x86) - x86))) + (rewire_dst_to_src-effects-preconditions x86) + (throwaway-destination-data-preconditions x86) + (destination-data-preconditions x86)) + + (equal + (pdpt-base-addr + (xr :rgf *rsi* x86) + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list 6 + (+ 184 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list 40 + (+ 144 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 3 + (+ 140 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr (xr :rgf *rsi* x86) + (pml4-table-base-addr x86))) + :r + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 32 + (+ 108 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 18 + (+ 86 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 40 + (+ 46 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 4 + (+ 38 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr + (xr :rgf *rdi* x86) + (pml4-table-base-addr x86))) + :r + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 25 + (+ 13 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (+ -24 (xr :rgf *rsp* x86))) + :r + 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 5 + (+ 8 (xr :rip 0 x86))) + :x + 0 + (mv-nth + 1 + (wb + (create-addr-bytes-alist + (create-canonical-address-list + 8 + (+ -24 (xr :rgf *rsp* x86))) + (byte-ify 8 (xr :ctr 3 x86))) + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (xr :rip 0 x86)) + :x + 0 + x86))))))))))))))))))))))))))))))))) + (pdpt-base-addr + (xr :rgf *rsi* x86) + x86))) :hints (("Goal" - :in-theory (e/d* - (page-size - pml4-table-base-addr-from-final-state - destination-pdpt-base-addr-from-final-state - - source-pml4-table-entry-from-final-state - source-pdpt-base-addr-from-final-state - source-addresses-from-final-state - destination-pdpt-base-addr-from-final-state - destination-pml4-table-entry-from-final-state - disjoint-p-all-translation-governing-addresses-subset-p - pdpt-base-addr) - - (rewire_dst_to_src-disable - - - read-from-physical-memory - rewrite-rb-to-rb-alt - page-dir-ptr-table-entry-addr-to-c-program-optimized-form - unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 - (:meta acl2::mv-nth-cons-meta) - - (:rewrite mv-nth-0-las-to-pas-subset-p) - (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt) - (:definition subset-p) - (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) - (:rewrite member-p-canonical-address-listp) - (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) - (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs) - (:type-prescription member-p) - (:rewrite open-mv-nth-1-las-to-pas-for-same-1g-page-general-1) - (:rewrite acl2::loghead-identity) - (:definition create-canonical-address-list) - (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) - (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) - (:rewrite canonical-address-p-rip) - (:rewrite xr-page-structure-marking-mode-mv-nth-2-las-to-pas) - (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) - (:definition int-lists-in-seq-p) - (:rewrite rm-low-64-in-programmer-level-mode) - (:rewrite right-shift-to-logtail) - (:rewrite - all-mem-except-paging-structures-equal-aux-and-rm-low-64-from-rest-of-memory) - (:rewrite - all-mem-except-paging-structures-equal-and-rm-low-64-from-rest-of-memory) - (:rewrite - xlate-equiv-structures-and-logtail-12-rm-low-64-with-pml4-table-entry-addr) - (:type-prescription member-p-physical-address-p-physical-address-listp) - (:type-prescription acl2::|x < y => 0 < y-x|) - (:rewrite - mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) - (:type-prescription member-p-physical-address-p) - (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) - (:rewrite acl2::cdr-of-append-when-consp) - (:type-prescription binary-append) - (:rewrite - all-translation-governing-addresses-1g-pages-and-wb-to-page-dir-ptr-table-entry-addr) - (:rewrite - int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:rewrite acl2::consp-of-append) - (:type-prescription int-lists-in-seq-p) - (:rewrite int-lists-in-seq-p-and-append) - (:rewrite acl2::car-of-append) - (:linear n64p-rm-low-64) - (:rewrite bitops::logand-with-bitmask) - (:rewrite acl2::right-cancellation-for-+) - (:rewrite - canonical-address-p-pml4-table-entry-addr-to-c-program-optimized-form) - (:type-prescription acl2::bitmaskp$inline) - (:rewrite unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode) - (:rewrite open-mv-nth-0-las-to-pas-for-same-1g-page-general-2) - (:rewrite loghead-30-of-1g-aligned-lin-addr-+-n-2) - (:rewrite ctri-is-n64p)))))) + :in-theory (e/d* + (page-size + pml4-table-base-addr-from-final-state + destination-pdpt-base-addr-from-final-state + + source-pml4-table-entry-from-final-state + source-pdpt-base-addr-from-final-state + source-addresses-from-final-state + destination-pdpt-base-addr-from-final-state + destination-pml4-table-entry-from-final-state + disjoint-p-all-translation-governing-addresses-subset-p + pdpt-base-addr) + + (rewire_dst_to_src-disable + + + read-from-physical-memory + rewrite-rb-to-rb-alt + page-dir-ptr-table-entry-addr-to-c-program-optimized-form + unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 + (:meta acl2::mv-nth-cons-meta) + + (:rewrite mv-nth-0-las-to-pas-subset-p) + (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt) + (:definition subset-p) + (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) + (:rewrite member-p-canonical-address-listp) + (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) + (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs) + (:type-prescription member-p) + (:rewrite open-mv-nth-1-las-to-pas-for-same-1g-page-general-1) + (:rewrite acl2::loghead-identity) + (:definition create-canonical-address-list) + (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) + (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) + (:rewrite canonical-address-p-rip) + (:rewrite xr-page-structure-marking-mode-mv-nth-2-las-to-pas) + (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) + (:definition int-lists-in-seq-p) + (:rewrite rm-low-64-in-programmer-level-mode) + (:rewrite right-shift-to-logtail) + (:rewrite + all-mem-except-paging-structures-equal-aux-and-rm-low-64-from-rest-of-memory) + (:rewrite + all-mem-except-paging-structures-equal-and-rm-low-64-from-rest-of-memory) + (:rewrite + xlate-equiv-structures-and-logtail-12-rm-low-64-with-pml4-table-entry-addr) + (:type-prescription member-p-physical-address-p-physical-address-listp) + (:type-prescription acl2::|x < y => 0 < y-x|) + (:rewrite + mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) + (:type-prescription member-p-physical-address-p) + (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) + (:rewrite acl2::cdr-of-append-when-consp) + (:type-prescription binary-append) + (:rewrite + all-translation-governing-addresses-1g-pages-and-wb-to-page-dir-ptr-table-entry-addr) + (:rewrite + int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:rewrite acl2::consp-of-append) + (:type-prescription int-lists-in-seq-p) + (:rewrite int-lists-in-seq-p-and-append) + (:rewrite acl2::car-of-append) + (:linear n64p-rm-low-64) + (:rewrite bitops::logand-with-bitmask) + (:rewrite acl2::right-cancellation-for-+) + (:rewrite + canonical-address-p-pml4-table-entry-addr-to-c-program-optimized-form) + (:type-prescription acl2::bitmaskp$inline) + (:rewrite unsigned-byte-p-of-combine-bytes-and-rb-in-system-level-mode) + (:rewrite open-mv-nth-0-las-to-pas-for-same-1g-page-general-2) + (:rewrite loghead-30-of-1g-aligned-lin-addr-+-n-2) + (:rewrite ctri-is-n64p)))))) (def-gl-export entry-attributes-unchanged-when-destination-PDPTE-modified :hyp (and (unsigned-byte-p 64 dest-pdpte) - (unsigned-byte-p 64 src-pdpte)) + (unsigned-byte-p 64 src-pdpte)) :concl (and - (equal (page-present (logior (logand 18442240475155922943 dest-pdpte) - (logand 4503598553628672 src-pdpte))) - (page-present dest-pdpte)) - (equal (page-read-write (logior (logand 18442240475155922943 dest-pdpte) - (logand 4503598553628672 src-pdpte))) - (page-read-write dest-pdpte)) - (equal (page-user-supervisor (logior (logand 18442240475155922943 dest-pdpte) - (logand 4503598553628672 src-pdpte))) - (page-user-supervisor dest-pdpte)) - (equal (page-execute-disable (logior (logand 18442240475155922943 dest-pdpte) - (logand 4503598553628672 src-pdpte))) - (page-execute-disable dest-pdpte)) - (equal (page-size (logior (logand 18442240475155922943 dest-pdpte) - (logand 4503598553628672 src-pdpte))) - (page-size dest-pdpte))) + (equal (page-present (logior (logand 18442240475155922943 dest-pdpte) + (logand 4503598553628672 src-pdpte))) + (page-present dest-pdpte)) + (equal (page-read-write (logior (logand 18442240475155922943 dest-pdpte) + (logand 4503598553628672 src-pdpte))) + (page-read-write dest-pdpte)) + (equal (page-user-supervisor (logior (logand 18442240475155922943 dest-pdpte) + (logand 4503598553628672 src-pdpte))) + (page-user-supervisor dest-pdpte)) + (equal (page-execute-disable (logior (logand 18442240475155922943 dest-pdpte) + (logand 4503598553628672 src-pdpte))) + (page-execute-disable dest-pdpte)) + (equal (page-size (logior (logand 18442240475155922943 dest-pdpte) + (logand 4503598553628672 src-pdpte))) + (page-size dest-pdpte))) :g-bindings (gl::auto-bindings (:mix (:nat src-pdpte 64) (:nat dest-pdpte 64)))) @@ -5395,13 +5425,13 @@ ;; xlate-equiv-memory-and-pml4-table-base-addr and ;; xlate-equiv-memory-with-mv-nth-2-las-to-pas. (equal (pml4-table-base-addr (mv-nth 2 (las-to-pas l-addrs r-w-x cpl x86))) - (pml4-table-base-addr (double-rewrite x86)))) + (pml4-table-base-addr (double-rewrite x86)))) (defthmd destination-data-from-final-state-in-terms-of-read-from-physical-memory-and-addr-range (implies (and (rewire_dst_to_src-effects-preconditions x86) - (throwaway-destination-data-preconditions x86) - (destination-data-preconditions x86)) + (throwaway-destination-data-preconditions x86) + (destination-data-preconditions x86)) (equal (mv-nth 1 @@ -5414,13 +5444,13 @@ *2^30* (ash (loghead - 22 - (logtail - 30 - (rm-low-64 - (page-dir-ptr-table-entry-addr (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86)) - x86))) + 22 + (logtail + 30 + (rm-low-64 + (page-dir-ptr-table-entry-addr (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86)) + x86))) 30)) x86))) :hints @@ -5527,58 +5557,58 @@ (defthmd no-errors-during-program-execution ;; Derived from ms-fault-programmer-level-and-marking-mode-from-final-state. (implies (rewire_dst_to_src-effects-preconditions x86) - (and (equal (xr :ms 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) - (equal (xr :fault 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) - (equal (xr :programmer-level-mode 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) - (equal (xr :page-structure-marking-mode 0 (x86-run (rewire_dst_to_src-clk) x86)) t))) + (and (equal (xr :ms 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) + (equal (xr :fault 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) + (equal (xr :programmer-level-mode 0 (x86-run (rewire_dst_to_src-clk) x86)) nil) + (equal (xr :page-structure-marking-mode 0 (x86-run (rewire_dst_to_src-clk) x86)) t))) :hints (("Goal" - :use ((:instance ms-fault-programmer-level-and-marking-mode-from-final-state)) - :in-theory (theory 'minimal-theory)))) + :use ((:instance ms-fault-programmer-level-and-marking-mode-from-final-state)) + :in-theory (theory 'minimal-theory)))) ;; 2. Destination data in final state == source data in initial state, ;; i.e., copy was done successfully. (defthm destination-data-in-final-state-==-source-data-in-initial-state (implies (and - (rewire_dst_to_src-effects-preconditions x86) - (source-data-preconditions x86) - (destination-data-preconditions x86)) - (equal - ;; Destination, after the copy: - (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rsi* x86)) - :r (x86-run (rewire_dst_to_src-clk) x86))) - ;; Source, before the copy: - (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r x86)))) + (rewire_dst_to_src-effects-preconditions x86) + (source-data-preconditions x86) + (destination-data-preconditions x86)) + (equal + ;; Destination, after the copy: + (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rsi* x86)) + :r (x86-run (rewire_dst_to_src-clk) x86))) + ;; Source, before the copy: + (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r x86)))) :hints (("Goal" - :do-not '(preprocess) - :do-not-induct t - :hands-off (x86-run) - :use ((:instance destination-data-from-final-state-in-terms-of-read-from-physical-memory-and-addr-range) - (:instance source-data-from-initial-state-in-terms-of-read-from-physical-memory-and-addr-range) - (:instance throwaway-destination-data-preconditions-lemma)) - :in-theory (union-theories - '() - (theory 'minimal-theory))))) + :do-not '(preprocess) + :do-not-induct t + :hands-off (x86-run) + :use ((:instance destination-data-from-final-state-in-terms-of-read-from-physical-memory-and-addr-range) + (:instance source-data-from-initial-state-in-terms-of-read-from-physical-memory-and-addr-range) + (:instance throwaway-destination-data-preconditions-lemma)) + :in-theory (union-theories + '() + (theory 'minimal-theory))))) ;; 3. Source data in the final state === source data in the initial ;; state, i.e., the source data is unmodified. (defthm source-data-in-final-state-==-source-data-in-initial-state (implies (and (rewire_dst_to_src-effects-preconditions x86) - (source-data-preconditions x86)) - - (equal - (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r - (x86-run (rewire_dst_to_src-clk) x86))) - (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) - :r x86)))) + (source-data-preconditions x86)) + + (equal + (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r + (x86-run (rewire_dst_to_src-clk) x86))) + (mv-nth 1 (rb (create-canonical-address-list *2^30* (xr :rgf *rdi* x86)) + :r x86)))) :hints (("Goal" - :use ((:instance source-data-from-final-state-in-terms-of-rb)) - :in-theory (union-theories - '(source-data-preconditions) - (theory 'minimal-theory))))) + :use ((:instance source-data-from-final-state-in-terms-of-rb)) + :in-theory (union-theories + '(source-data-preconditions) + (theory 'minimal-theory))))) ;; 4. Program unmodified in the final state: @@ -5594,13 +5624,13 @@ (gather-all-paging-structure-qword-addresses (double-rewrite x86)))) (disjoint-p$ (mv-nth 1 - (las-to-pas (create-canonical-address-list 8 lin-addr) - :w (cpl x86) (double-rewrite x86))) + (las-to-pas (create-canonical-address-list 8 lin-addr) + :w (cpl x86) (double-rewrite x86))) (all-translation-governing-addresses l-addrs (double-rewrite x86))) (disjoint-p$ (mv-nth 1 - (las-to-pas (create-canonical-address-list 8 lin-addr) - :w (cpl x86) (double-rewrite x86))) + (las-to-pas (create-canonical-address-list 8 lin-addr) + :w (cpl x86) (double-rewrite x86))) (mv-nth 1 (las-to-pas l-addrs :x (cpl x86) (double-rewrite x86)))) (physical-address-p lin-addr) (equal (loghead 3 lin-addr) 0) @@ -5611,831 +5641,831 @@ (program-at-alt l-addrs bytes (mv-nth 1 - (wb (create-addr-bytes-alist (create-canonical-address-list 8 lin-addr) - (byte-ify 8 value)) - x86))) + (wb (create-addr-bytes-alist (create-canonical-address-list 8 lin-addr) + (byte-ify 8 value)) + x86))) (program-at-alt l-addrs bytes (double-rewrite x86)))) :hints (("Goal" :do-not-induct t :use ((:instance disjointness-of-las-to-pas-from-wb-to-subset-of-paging-structures-general - (l-addrs-subset l-addrs) - (r-w-x :x) - (cpl (cpl x86)) - (x86-1 x86) - (x86-2 x86))) + (l-addrs-subset l-addrs) + (r-w-x :x) + (cpl (cpl x86)) + (x86-1 x86) + (x86-2 x86))) :in-theory (e/d* (program-at-alt program-at disjoint-p$ subset-p subset-p-reflexive program-at-alt) - (rewrite-program-at-to-program-at-alt))))) + (rewrite-program-at-to-program-at-alt))))) (local (defthmd program-in-final-state-==-program-in-initial-state-helper (implies (rewire_dst_to_src-effects-preconditions x86) - (equal - (program-at-alt - (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - *rewire_dst_to_src* - ;; (x86-run (rewire_dst_to_src-clk) x86) - (xw - :rgf *rax* 1 - (xw - :rgf *rcx* - (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86)) - (xw - :rgf *rdx* - (logand - 4503598553628672 - (logior - (logand - -4503598553628673 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86))))) - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))) - (xw - :rgf *rsp* (+ 8 (xr :rgf *rsp* x86)) - (xw - :rgf *rsi* 0 - (xw - :rgf *rdi* - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (xw - :rgf *r8* 1099511627775 - (xw - :rgf *r9* - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (xw - :rip 0 - (logext - 64 - (combine-bytes - (mv-nth 1 - (rb (create-canonical-address-list 8 (xr :rgf *rsp* x86)) - :r x86)))) - (xw - :undef 0 (+ 46 (nfix (xr :undef 0 x86))) - (!flgi - *cf* - (bool->bit - (< - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (logior - (logand - 18442240475155922943 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86)))))))) - (!flgi - *pf* - (pf-spec64 - (loghead - 64 - (+ - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (- - (logand - 4503598553628672 - (logior - (logand - -4503598553628673 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86))))) - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))))))) - (!flgi - *af* - (sub-af-spec64 - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (logior - (logand - 18442240475155922943 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))) - (!flgi - *zf* 1 - (!flgi - *sf* - (sf-spec64 - (loghead - 64 - (+ - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (- - (logand - 4503598553628672 - (logior - (logand - -4503598553628673 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86))))) - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))))))) - (!flgi - *of* - (of-spec64 - (+ - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))) - (- - (logand - 4503598553628672 - (logior - (logand - -4503598553628673 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86))))) - (logand - 4503598553628672 - (logext - 64 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86)))))))))) - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list 8 (xr :rgf *rsp* x86)) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 40 (+ 206 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 15 (+ 190 (xr :rip 0 x86))) - :x 0 - (mv-nth - 1 - (wb - (create-addr-bytes-alist - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - (byte-ify - 8 - (logior - (logand - 18442240475155922943 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r x86)))) - (logand - 4503598553628672 - (combine-bytes - (mv-nth - 1 - (rb - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r x86))))))) - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 6 (+ 184 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rsi* x86) - (pdpt-base-addr (xr :rgf *rsi* x86) x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 40 (+ 144 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 3 (+ 140 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr - (xr :rgf *rsi* x86) - (pml4-table-base-addr x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 32 (+ 108 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 18 (+ 86 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (page-dir-ptr-table-entry-addr - (xr :rgf *rdi* x86) - (pdpt-base-addr (xr :rgf *rdi* x86) x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 40 (+ 46 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 4 (+ 38 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (pml4-table-entry-addr - (xr :rgf *rdi* x86) - (pml4-table-base-addr x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 25 (+ 13 (xr :rip 0 x86))) - :x 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 - (+ -24 (xr :rgf *rsp* x86))) - :r 0 - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 5 (+ 8 (xr :rip 0 x86))) - :x 0 - (mv-nth - 1 - (wb - (create-addr-bytes-alist - (create-canonical-address-list - 8 - (+ -24 (xr :rgf *rsp* x86))) - (byte-ify - 8 - (xr :ctr *cr3* x86))) - (mv-nth - 2 - (las-to-pas - (create-canonical-address-list - 8 (xr :rip 0 x86)) - :x 0 - x86))))))))))))))))))))))))))))))))))))))))))))))))))))))))) - (program-at (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - *rewire_dst_to_src* x86))) + (equal + (program-at-alt + (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + *rewire_dst_to_src* + ;; (x86-run (rewire_dst_to_src-clk) x86) + (xw + :rgf *rax* 1 + (xw + :rgf *rcx* + (pml4-table-entry-addr (xr :rgf *rsi* x86) (pml4-table-base-addr x86)) + (xw + :rgf *rdx* + (logand + 4503598553628672 + (logior + (logand + -4503598553628673 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86))))) + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))) + (xw + :rgf *rsp* (+ 8 (xr :rgf *rsp* x86)) + (xw + :rgf *rsi* 0 + (xw + :rgf *rdi* + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (xw + :rgf *r8* 1099511627775 + (xw + :rgf *r9* + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (xw + :rip 0 + (logext + 64 + (combine-bytes + (mv-nth 1 + (rb (create-canonical-address-list 8 (xr :rgf *rsp* x86)) + :r x86)))) + (xw + :undef 0 (+ 46 (nfix (xr :undef 0 x86))) + (!flgi + *cf* + (bool->bit + (< + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (logior + (logand + 18442240475155922943 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86)))))))) + (!flgi + *pf* + (pf-spec64 + (loghead + 64 + (+ + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (- + (logand + 4503598553628672 + (logior + (logand + -4503598553628673 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86))))) + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))))))) + (!flgi + *af* + (sub-af-spec64 + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (logior + (logand + 18442240475155922943 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))) + (!flgi + *zf* 1 + (!flgi + *sf* + (sf-spec64 + (loghead + 64 + (+ + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (- + (logand + 4503598553628672 + (logior + (logand + -4503598553628673 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86))))) + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))))))) + (!flgi + *of* + (of-spec64 + (+ + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))) + (- + (logand + 4503598553628672 + (logior + (logand + -4503598553628673 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86))))) + (logand + 4503598553628672 + (logext + 64 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86)))))))))) + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list 8 (xr :rgf *rsp* x86)) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 40 (+ 206 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 15 (+ 190 (xr :rip 0 x86))) + :x 0 + (mv-nth + 1 + (wb + (create-addr-bytes-alist + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + (byte-ify + 8 + (logior + (logand + 18442240475155922943 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r x86)))) + (logand + 4503598553628672 + (combine-bytes + (mv-nth + 1 + (rb + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r x86))))))) + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 6 (+ 184 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rsi* x86) + (pdpt-base-addr (xr :rgf *rsi* x86) x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 40 (+ 144 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 3 (+ 140 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr + (xr :rgf *rsi* x86) + (pml4-table-base-addr x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 32 (+ 108 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 18 (+ 86 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (page-dir-ptr-table-entry-addr + (xr :rgf *rdi* x86) + (pdpt-base-addr (xr :rgf *rdi* x86) x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 40 (+ 46 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 4 (+ 38 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (pml4-table-entry-addr + (xr :rgf *rdi* x86) + (pml4-table-base-addr x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 25 (+ 13 (xr :rip 0 x86))) + :x 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 + (+ -24 (xr :rgf *rsp* x86))) + :r 0 + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 5 (+ 8 (xr :rip 0 x86))) + :x 0 + (mv-nth + 1 + (wb + (create-addr-bytes-alist + (create-canonical-address-list + 8 + (+ -24 (xr :rgf *rsp* x86))) + (byte-ify + 8 + (xr :ctr *cr3* x86))) + (mv-nth + 2 + (las-to-pas + (create-canonical-address-list + 8 (xr :rip 0 x86)) + :x 0 + x86))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + (program-at (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + *rewire_dst_to_src* x86))) :hints (("Goal" - :hands-off (x86-run) - :in-theory (e/d* (page-size) - ((:rewrite mv-nth-0-las-to-pas-subset-p) - (:definition subset-p) - (:definition member-p) - (:rewrite rewrite-rb-to-rb-alt) - (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs) - (:rewrite subset-p-two-create-canonical-address-lists-general) - (:rewrite member-p-canonical-address-listp) - (:rewrite page-dir-ptr-table-entry-addr-to-c-program-optimized-form) - (:rewrite len-of-rb-in-system-level-mode) - (:linear adding-7-to-page-dir-ptr-table-entry-addr) - (:rewrite acl2::loghead-identity) - (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) - (:linear *physical-address-size*p-page-dir-ptr-table-entry-addr) - (:rewrite cdr-mv-nth-1-las-to-pas) - (:rewrite - mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) - (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt) - (:rewrite disjoint-p-subset-p) - (:rewrite greater-logbitp-of-unsigned-byte-p . 2) - (:rewrite cdr-create-canonical-address-list) - (:rewrite unsigned-byte-p-of-combine-bytes) - (:definition create-canonical-address-list) - (:linear size-of-combine-bytes) - (:linear unsigned-byte-p-of-combine-bytes) - (:rewrite default-+-2) - (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) - (:rewrite - infer-disjointness-with-all-translation-governing-addresses-from-gather-all-paging-structure-qword-addresses-with-disjoint-p$) - (:rewrite loghead-of-non-integerp) - (:type-prescription acl2::|x < y => 0 < -x+y|) - (:rewrite acl2::equal-of-booleans-rewrite) - (:linear rip-is-i48p . 2) - (:type-prescription member-p) - (:linear rip-is-i48p . 1) - (:linear rgfi-is-i64p . 2) - (:rewrite default-<-1) - (:rewrite default-+-1) - (:rewrite canonical-address-p-limits-thm-0) - (:linear rgfi-is-i64p . 1) - (:rewrite default-<-2) - (:rewrite bitops::unsigned-byte-p-when-unsigned-byte-p-less) - (:rewrite loghead-negative) - (:rewrite consp-of-create-canonical-address-list) - (:rewrite car-create-canonical-address-list) - (:type-prescription pdpt-base-addr) - (:rewrite canonical-address-p-limits-thm-3) - (:definition no-duplicates-p) - (:rewrite member-p-cdr) - (:rewrite consp-mv-nth-1-las-to-pas) - (:rewrite member-p-of-not-a-consp) - (:meta acl2::cancel_plus-equal-correct) - (:meta acl2::cancel_times-equal-correct) - (:rewrite subset-p-cdr-y) - (:meta acl2::cancel_plus-lessp-correct) - (:rewrite canonical-address-p-limits-thm-1) - (:rewrite member-p-of-subset-is-member-p-of-superset) - (:rewrite acl2::consp-when-member-equal-of-atom-listp) - (:rewrite rationalp-implies-acl2-numberp) - (:linear adding-7-to-pml4-table-entry-addr) - (:type-prescription adding-7-to-page-dir-ptr-table-entry-addr) - (:definition create-addr-bytes-alist) - (:rewrite member-p-and-mult-8-qword-paddr-listp) - (:rewrite mv-nth-1-las-to-pas-subset-p) - (:type-prescription booleanp) - (:rewrite default-car) - (:rewrite default-cdr) - (:definition combine-bytes) - (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-15*-when-low-12-bits-=-4081) - (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-=-4090) - (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-=-4089) - (:rewrite acl2::ash-0) - (:linear *physical-address-size*p-pml4-table-entry-addr) - (:rewrite - mv-nth-1-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) - (:rewrite acl2::zip-open) - (:rewrite acl2::equal-constant-+) - (:rewrite acl2::difference-unsigned-byte-p) - (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-15*-when-low-12-bits-<-4081) - (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-<-4093) - (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-<-4089) - (:linear - ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-!=-all-ones) - (:definition nthcdr) - (:definition nth) - (:type-prescription adding-7-to-pml4-table-entry-addr) - (:rewrite subset-p-cdr-x) - (:linear ash-monotone-2) - (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) - (:rewrite create-canonical-address-list-1) - (:rewrite car-mv-nth-1-las-to-pas) - (:definition byte-listp) - (:definition int-lists-in-seq-p) - (:type-prescription bitops::logand-natp-type-2) - (:meta acl2::mv-nth-cons-meta) - (:linear bitops::upper-bound-of-logand . 2) - (:linear bitops::logand->=-0-linear-2) - (:definition binary-append) - (:rewrite xr-page-structure-marking-mode-mv-nth-2-las-to-pas) - (:rewrite consp-byte-ify) - (:linear n52p-mv-nth-1-ia32e-la-to-pa) - (:rewrite acl2::cdr-of-append-when-consp) - (:linear <=-logior) - (:type-prescription bitops::logior-natp-type) - (:definition open-qword-paddr-list) - (:rewrite ia32e-la-to-pa-in-programmer-level-mode) - (:rewrite bitops::basic-unsigned-byte-p-of-+) - (:type-prescription byte-ify) - (:type-prescription n52p-mv-nth-1-ia32e-la-to-pa) - (:linear acl2::logext-bounds) - (:type-prescription acl2::logext-type) - (:rewrite mv-nth-1-ia32e-la-to-pa-when-error) - (:rewrite acl2::append-when-not-consp) - (:type-prescription consp-mv-nth-1-las-to-pas) - (:rewrite acl2::member-of-cons) - (:rewrite acl2::logext-identity) - (:definition n08p$inline) - (:rewrite acl2::natp-when-integerp) - (:rewrite member-p-start-rip-of-create-canonical-address-list) - (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) - (:rewrite acl2::natp-rw) - (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) - (:linear bitops::logand-<-0-linear) - (:rewrite mv-nth-1-las-to-pas-when-error) - (:rewrite acl2::ifix-when-not-integerp) - (:linear acl2::expt->-1) - (:rewrite acl2::logtail-identity) - (:type-prescription bitops::logand-natp-type-1) - (:definition len) - (:rewrite wb-not-consp-addr-lst) - (:linear bitops::logior->=-0-linear) - (:linear bitops::logior-<-0-linear-1) - (:definition addr-range) - (:linear member-p-pos-value) - (:linear member-p-pos-1-value) - (:linear acl2::index-of-<-len) - (:rewrite right-shift-to-logtail) - (:rewrite r-w-x-is-irrelevant-for-mv-nth-1-ia32e-la-to-pa-when-no-errors) - (:type-prescription signed-byte-p) - (:rewrite default-unary-minus) - (:rewrite canonical-address-p-rip) - (:type-prescription binary-logand) - (:type-prescription true-listp-addr-range) - (:type-prescription consp-addr-range) - (:rewrite acl2::car-of-append) - (:definition acons) - (:rewrite acl2::natp-when-gte-0) - (:linear bitops::logior-<-0-linear-2) - (:linear mv-nth-1-idiv-spec) - (:linear mv-nth-1-div-spec) - (:type-prescription acl2::|x < y => 0 < y-x|) - (:rewrite acl2::commutativity-2-of-+) - (:rewrite bitops::logbitp-nonzero-of-bit) - (:rewrite bitops::logand-with-negated-bitmask) - (:rewrite bitops::logand-with-bitmask) - (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) - (:rewrite - int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) - (:type-prescription zip) - (:type-prescription rm-low-64-logand-logior-helper-1) - (:rewrite negative-logand-to-positive-logand-with-integerp-x) - (:rewrite weed-out-irrelevant-logand-when-first-operand-constant) - (:rewrite logand-redundant) - (:rewrite bitops::signed-byte-p-when-unsigned-byte-p-smaller) - (:rewrite bitops::signed-byte-p-when-signed-byte-p-smaller) - (:rewrite bitops::signed-byte-p-monotonicity) - (:rewrite acl2::consp-of-append) - (:type-prescription addr-byte-alistp-create-addr-bytes-alist) - (:type-prescription combine-bytes) - (:rewrite - mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) - (:rewrite car-addr-range) - (:linear bitops::upper-bound-of-logand . 1) - (:linear bitops::logand->=-0-linear-1) - (:rewrite acl2::commutativity-of-append-under-set-equiv) - (:rewrite consp-create-addr-bytes-alist) - (:type-prescription n64p$inline) - (:rewrite acl2::append-atom-under-list-equiv) - (:type-prescription gather-all-paging-structure-qword-addresses) - (:type-prescription binary-logior) - (:rewrite neg-addr-range=nil) - (:rewrite acl2::signed-byte-p-logops) - (:rewrite unsigned-byte-p-64-of-dest-pdpte-modified-value) - (:type-prescription acl2::bitmaskp$inline) - (:type-prescription consp-append) - (:rewrite acl2::subsetp-member . 2) - (:rewrite acl2::subsetp-member . 1) - (:linear combine-bytes-size-for-rm64-programmer-level-mode) - (:rewrite bitops::unsigned-byte-p-of-minus-when-signed-byte-p) - (:rewrite cdr-addr-range) - (:rewrite acl2::distributivity-of-minus-over-+) - (:type-prescription int-lists-in-seq-p) - (:type-prescription n01p-page-size) - (:rewrite bitops::logbitp-when-bitmaskp) - (:rewrite int-lists-in-seq-p-and-append) - (:type-prescription consp-create-addr-bytes-alist) - (:type-prescription bitp) - (:type-prescription all-translation-governing-addresses) - (:rewrite acl2::expt-with-violated-guards) - (:type-prescription consp-create-addr-bytes-alist-in-terms-of-len) - (:rewrite acl2::append-of-cons) - (:linear rm-low-64-logand-logior-helper-1) - (:type-prescription open-qword-paddr-list) - (:type-prescription acl2::true-listp-append) - (:type-prescription binary-append) - (:rewrite bitops::normalize-logbitp-when-mods-equal) - (:rewrite bitops::logbitp-of-negative-const) - (:rewrite bitops::logbitp-of-mask) - (:rewrite bitops::logbitp-of-const) - (:meta bitops::open-logbitp-of-const-lite-meta) - (:type-prescription natp) - (:type-prescription member-equal) - (:rewrite greater-logbitp-of-unsigned-byte-p . 1) - (:linear acl2::expt-is-increasing-for-base>1) - (:definition member-equal) - (:definition n64p$inline) - (:type-prescription true-listp-create-addr-bytes-alist) - (:rewrite no-duplicates-p-and-append) - (:rewrite inverse-of-+) - (:linear bitops::expt-2-lower-bound-by-logbitp) - (:linear ctri-is-n64p) - (:rewrite subset-p-cons-member-p-lemma) - (:rewrite not-member-p-when-disjoint-p) - (:rewrite constant-upper-bound-of-logior-for-naturals) - (:linear bitops::upper-bound-of-logior-for-naturals) - (:type-prescription member-p-physical-address-p-physical-address-listp) - (:type-prescription member-p-physical-address-p) - (:rewrite bitops::signed-byte-p-of-logext) - (:rewrite acl2::signed-byte-p-logext) - (:rewrite car-cons))))))) + :hands-off (x86-run) + :in-theory (e/d* (page-size) + ((:rewrite mv-nth-0-las-to-pas-subset-p) + (:definition subset-p) + (:definition member-p) + (:rewrite rewrite-rb-to-rb-alt) + (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs) + (:rewrite subset-p-two-create-canonical-address-lists-general) + (:rewrite member-p-canonical-address-listp) + (:rewrite page-dir-ptr-table-entry-addr-to-c-program-optimized-form) + (:rewrite len-of-rb-in-system-level-mode) + (:linear adding-7-to-page-dir-ptr-table-entry-addr) + (:rewrite acl2::loghead-identity) + (:rewrite mv-nth-0-las-to-pas-subset-p-with-l-addrs-from-bind-free) + (:linear *physical-address-size*p-page-dir-ptr-table-entry-addr) + (:rewrite cdr-mv-nth-1-las-to-pas) + (:rewrite + mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) + (:rewrite mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs-alt) + (:rewrite disjoint-p-subset-p) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:rewrite cdr-create-canonical-address-list) + (:rewrite unsigned-byte-p-of-combine-bytes) + (:definition create-canonical-address-list) + (:linear size-of-combine-bytes) + (:linear unsigned-byte-p-of-combine-bytes) + (:rewrite default-+-2) + (:rewrite two-mv-nth-1-las-to-pas-subset-p-disjoint-from-las-to-pas) + (:rewrite + infer-disjointness-with-all-translation-governing-addresses-from-gather-all-paging-structure-qword-addresses-with-disjoint-p$) + (:rewrite loghead-of-non-integerp) + (:type-prescription acl2::|x < y => 0 < -x+y|) + (:rewrite acl2::equal-of-booleans-rewrite) + (:linear rip-is-i48p . 2) + (:type-prescription member-p) + (:linear rip-is-i48p . 1) + (:linear rgfi-is-i64p . 2) + (:rewrite default-<-1) + (:rewrite default-+-1) + (:rewrite canonical-address-p-limits-thm-0) + (:linear rgfi-is-i64p . 1) + (:rewrite default-<-2) + (:rewrite bitops::unsigned-byte-p-when-unsigned-byte-p-less) + (:rewrite loghead-negative) + (:rewrite consp-of-create-canonical-address-list) + (:rewrite car-create-canonical-address-list) + (:type-prescription pdpt-base-addr) + (:rewrite canonical-address-p-limits-thm-3) + (:definition no-duplicates-p) + (:rewrite member-p-cdr) + (:rewrite consp-mv-nth-1-las-to-pas) + (:rewrite member-p-of-not-a-consp) + (:meta acl2::cancel_plus-equal-correct) + (:meta acl2::cancel_times-equal-correct) + (:rewrite subset-p-cdr-y) + (:meta acl2::cancel_plus-lessp-correct) + (:rewrite canonical-address-p-limits-thm-1) + (:rewrite member-p-of-subset-is-member-p-of-superset) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite rationalp-implies-acl2-numberp) + (:linear adding-7-to-pml4-table-entry-addr) + (:type-prescription adding-7-to-page-dir-ptr-table-entry-addr) + (:definition create-addr-bytes-alist) + (:rewrite member-p-and-mult-8-qword-paddr-listp) + (:rewrite mv-nth-1-las-to-pas-subset-p) + (:type-prescription booleanp) + (:rewrite default-car) + (:rewrite default-cdr) + (:definition combine-bytes) + (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-15*-when-low-12-bits-=-4081) + (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-=-4090) + (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-=-4089) + (:rewrite acl2::ash-0) + (:linear *physical-address-size*p-pml4-table-entry-addr) + (:rewrite + mv-nth-1-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) + (:rewrite acl2::zip-open) + (:rewrite acl2::equal-constant-+) + (:rewrite acl2::difference-unsigned-byte-p) + (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-15*-when-low-12-bits-<-4081) + (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-<-4093) + (:linear ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-<-4089) + (:linear + ia32e-la-to-pa-<-*mem-size-in-bytes-1*-when-low-12-bits-!=-all-ones) + (:definition nthcdr) + (:definition nth) + (:type-prescription adding-7-to-pml4-table-entry-addr) + (:rewrite subset-p-cdr-x) + (:linear ash-monotone-2) + (:rewrite combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence) + (:rewrite create-canonical-address-list-1) + (:rewrite car-mv-nth-1-las-to-pas) + (:definition byte-listp) + (:definition int-lists-in-seq-p) + (:type-prescription bitops::logand-natp-type-2) + (:meta acl2::mv-nth-cons-meta) + (:linear bitops::upper-bound-of-logand . 2) + (:linear bitops::logand->=-0-linear-2) + (:definition binary-append) + (:rewrite xr-page-structure-marking-mode-mv-nth-2-las-to-pas) + (:rewrite consp-byte-ify) + (:linear n52p-mv-nth-1-ia32e-la-to-pa) + (:rewrite acl2::cdr-of-append-when-consp) + (:linear <=-logior) + (:type-prescription bitops::logior-natp-type) + (:definition open-qword-paddr-list) + (:rewrite ia32e-la-to-pa-in-programmer-level-mode) + (:rewrite bitops::basic-unsigned-byte-p-of-+) + (:type-prescription byte-ify) + (:type-prescription n52p-mv-nth-1-ia32e-la-to-pa) + (:linear acl2::logext-bounds) + (:type-prescription acl2::logext-type) + (:rewrite mv-nth-1-ia32e-la-to-pa-when-error) + (:rewrite acl2::append-when-not-consp) + (:type-prescription consp-mv-nth-1-las-to-pas) + (:rewrite acl2::member-of-cons) + (:rewrite acl2::logext-identity) + (:definition n08p$inline) + (:rewrite acl2::natp-when-integerp) + (:rewrite member-p-start-rip-of-create-canonical-address-list) + (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) + (:rewrite acl2::natp-rw) + (:rewrite r/x-is-irrelevant-for-mv-nth-2-las-to-pas-when-no-errors) + (:linear bitops::logand-<-0-linear) + (:rewrite mv-nth-1-las-to-pas-when-error) + (:rewrite acl2::ifix-when-not-integerp) + (:linear acl2::expt->-1) + (:rewrite acl2::logtail-identity) + (:type-prescription bitops::logand-natp-type-1) + (:definition len) + (:rewrite wb-not-consp-addr-lst) + (:linear bitops::logior->=-0-linear) + (:linear bitops::logior-<-0-linear-1) + (:definition addr-range) + (:linear member-p-pos-value) + (:linear member-p-pos-1-value) + (:linear acl2::index-of-<-len) + (:rewrite right-shift-to-logtail) + (:rewrite r-w-x-is-irrelevant-for-mv-nth-1-ia32e-la-to-pa-when-no-errors) + (:type-prescription signed-byte-p) + (:rewrite default-unary-minus) + (:rewrite canonical-address-p-rip) + (:type-prescription binary-logand) + (:type-prescription true-listp-addr-range) + (:type-prescription consp-addr-range) + (:rewrite acl2::car-of-append) + (:definition acons) + (:rewrite acl2::natp-when-gte-0) + (:linear bitops::logior-<-0-linear-2) + (:linear mv-nth-1-idiv-spec) + (:linear mv-nth-1-div-spec) + (:type-prescription acl2::|x < y => 0 < y-x|) + (:rewrite acl2::commutativity-2-of-+) + (:rewrite bitops::logbitp-nonzero-of-bit) + (:rewrite bitops::logand-with-negated-bitmask) + (:rewrite bitops::logand-with-bitmask) + (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) + (:rewrite + int-lists-in-seq-p-and-append-with-create-canonical-address-list-2) + (:type-prescription zip) + (:type-prescription rm-low-64-logand-logior-helper-1) + (:rewrite negative-logand-to-positive-logand-with-integerp-x) + (:rewrite weed-out-irrelevant-logand-when-first-operand-constant) + (:rewrite logand-redundant) + (:rewrite bitops::signed-byte-p-when-unsigned-byte-p-smaller) + (:rewrite bitops::signed-byte-p-when-signed-byte-p-smaller) + (:rewrite bitops::signed-byte-p-monotonicity) + (:rewrite acl2::consp-of-append) + (:type-prescription addr-byte-alistp-create-addr-bytes-alist) + (:type-prescription combine-bytes) + (:rewrite + mv-nth-1-rb-and-xlate-equiv-memory-disjoint-from-paging-structures) + (:rewrite car-addr-range) + (:linear bitops::upper-bound-of-logand . 1) + (:linear bitops::logand->=-0-linear-1) + (:rewrite acl2::commutativity-of-append-under-set-equiv) + (:rewrite consp-create-addr-bytes-alist) + (:type-prescription n64p$inline) + (:rewrite acl2::append-atom-under-list-equiv) + (:type-prescription gather-all-paging-structure-qword-addresses) + (:type-prescription binary-logior) + (:rewrite neg-addr-range=nil) + (:rewrite acl2::signed-byte-p-logops) + (:rewrite unsigned-byte-p-64-of-dest-pdpte-modified-value) + (:type-prescription acl2::bitmaskp$inline) + (:type-prescription consp-append) + (:rewrite acl2::subsetp-member . 2) + (:rewrite acl2::subsetp-member . 1) + ;; (:linear combine-bytes-size-for-rm64-programmer-level-mode) + (:rewrite bitops::unsigned-byte-p-of-minus-when-signed-byte-p) + (:rewrite cdr-addr-range) + (:rewrite acl2::distributivity-of-minus-over-+) + (:type-prescription int-lists-in-seq-p) + (:type-prescription n01p-page-size) + (:rewrite bitops::logbitp-when-bitmaskp) + (:rewrite int-lists-in-seq-p-and-append) + (:type-prescription consp-create-addr-bytes-alist) + (:type-prescription bitp) + (:type-prescription all-translation-governing-addresses) + (:rewrite acl2::expt-with-violated-guards) + (:type-prescription consp-create-addr-bytes-alist-in-terms-of-len) + (:rewrite acl2::append-of-cons) + (:linear rm-low-64-logand-logior-helper-1) + (:type-prescription open-qword-paddr-list) + (:type-prescription acl2::true-listp-append) + (:type-prescription binary-append) + (:rewrite bitops::normalize-logbitp-when-mods-equal) + (:rewrite bitops::logbitp-of-negative-const) + (:rewrite bitops::logbitp-of-mask) + (:rewrite bitops::logbitp-of-const) + (:meta bitops::open-logbitp-of-const-lite-meta) + (:type-prescription natp) + (:type-prescription member-equal) + (:rewrite greater-logbitp-of-unsigned-byte-p . 1) + (:linear acl2::expt-is-increasing-for-base>1) + (:definition member-equal) + (:definition n64p$inline) + (:type-prescription true-listp-create-addr-bytes-alist) + (:rewrite no-duplicates-p-and-append) + (:rewrite inverse-of-+) + (:linear bitops::expt-2-lower-bound-by-logbitp) + (:linear ctri-is-n64p) + (:rewrite subset-p-cons-member-p-lemma) + (:rewrite not-member-p-when-disjoint-p) + (:rewrite constant-upper-bound-of-logior-for-naturals) + (:linear bitops::upper-bound-of-logior-for-naturals) + (:type-prescription member-p-physical-address-p-physical-address-listp) + (:type-prescription member-p-physical-address-p) + (:rewrite bitops::signed-byte-p-of-logext) + (:rewrite acl2::signed-byte-p-logext) + (:rewrite car-cons))))))) (defthm program-at-alt-in-final-state-==-program-at-in-initial-state (implies (rewire_dst_to_src-effects-preconditions x86) - (equal - (program-at-alt - (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - *rewire_dst_to_src* - (x86-run (rewire_dst_to_src-clk) x86)) - (program-at (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - *rewire_dst_to_src* x86))) + (equal + (program-at-alt + (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + *rewire_dst_to_src* + (x86-run (rewire_dst_to_src-clk) x86)) + (program-at (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + *rewire_dst_to_src* x86))) :hints (("Goal" - :hands-off (x86-run) - :in-theory (e/d* (program-in-final-state-==-program-in-initial-state-helper) - (rewire_dst_to_src-effects-preconditions)) - :use ((:instance rewire_dst_to_src-effects) - (:instance program-in-final-state-==-program-in-initial-state-helper))))) + :hands-off (x86-run) + :in-theory (e/d* (program-in-final-state-==-program-in-initial-state-helper) + (rewire_dst_to_src-effects-preconditions)) + :use ((:instance rewire_dst_to_src-effects) + (:instance program-in-final-state-==-program-in-initial-state-helper))))) (defthmd cpl-in-final-state (implies (rewire_dst_to_src-effects-preconditions x86) - (equal - (xr :seg-visible 1 (x86-run (rewire_dst_to_src-clk) x86)) - (xr :seg-visible 1 x86))) + (equal + (xr :seg-visible 1 (x86-run (rewire_dst_to_src-clk) x86)) + (xr :seg-visible 1 x86))) :hints (("Goal" - :do-not '(preprocess) - :use ((:instance rewire_dst_to_src-effects) - (:instance fault-from-final-state)) - :hands-off (x86-run) - :in-theory (e/d* - (rewire_dst_to_src-effects-preconditions-and-ms-fault-programmer-level-and-marking-mode-fields) - (rewire_dst_to_src-effects-preconditions))))) + :do-not '(preprocess) + :use ((:instance rewire_dst_to_src-effects) + (:instance fault-from-final-state)) + :hands-off (x86-run) + :in-theory (e/d* + (rewire_dst_to_src-effects-preconditions-and-ms-fault-programmer-level-and-marking-mode-fields) + (rewire_dst_to_src-effects-preconditions))))) (local (defthmd program-at-alt-in-final-state-==-program-at-in-final-state (implies (rewire_dst_to_src-effects-preconditions x86) - (equal - (program-at-alt - (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - *rewire_dst_to_src* - (x86-run (rewire_dst_to_src-clk) x86)) - (program-at - (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - *rewire_dst_to_src* - (x86-run (rewire_dst_to_src-clk) x86)))) + (equal + (program-at-alt + (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + *rewire_dst_to_src* + (x86-run (rewire_dst_to_src-clk) x86)) + (program-at + (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + *rewire_dst_to_src* + (x86-run (rewire_dst_to_src-clk) x86)))) :hints (("Goal" - :hands-off (x86-run) - :use ((:instance no-errors-during-program-execution) - (:instance program-at-alt-in-final-state-==-program-at-in-final-state-helper-1) - (:instance program-at-alt-in-final-state-==-program-at-in-final-state-helper-3)) - :in-theory (e/d* (cpl-in-final-state - program-at-alt - disjoint-p$) - (rewrite-program-at-to-program-at-alt - rewire_dst_to_src-effects-preconditions)))))) + :hands-off (x86-run) + :use ((:instance no-errors-during-program-execution) + (:instance program-at-alt-in-final-state-==-program-at-in-final-state-helper-1) + (:instance program-at-alt-in-final-state-==-program-at-in-final-state-helper-3)) + :in-theory (e/d* (cpl-in-final-state + program-at-alt + disjoint-p$) + (rewrite-program-at-to-program-at-alt + rewire_dst_to_src-effects-preconditions)))))) (defthm program-in-final-state-==-program-in-initial-state (implies (rewire_dst_to_src-effects-preconditions x86) - (equal - (program-at - (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - *rewire_dst_to_src* - (x86-run (rewire_dst_to_src-clk) x86)) - (program-at (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) - *rewire_dst_to_src* x86))) + (equal + (program-at + (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + *rewire_dst_to_src* + (x86-run (rewire_dst_to_src-clk) x86)) + (program-at (create-canonical-address-list *rewire_dst_to_src-len* (xr :rip 0 x86)) + *rewire_dst_to_src* x86))) :hints (("Goal" - :hands-off (x86-run) - :in-theory (e/d* () - (rewire_dst_to_src-effects-preconditions - force (force))) - :use ((:instance program-at-alt-in-final-state-==-program-at-in-initial-state) - (:instance program-at-alt-in-final-state-==-program-at-in-final-state))))) + :hands-off (x86-run) + :in-theory (e/d* () + (rewire_dst_to_src-effects-preconditions + force (force))) + :use ((:instance program-at-alt-in-final-state-==-program-at-in-initial-state) + (:instance program-at-alt-in-final-state-==-program-at-in-final-state))))) ;; !! TODO: How much stack was used? diff --git a/books/projects/x86isa/proofs/zeroCopy/non-marking-mode/zeroCopy.lisp b/books/projects/x86isa/proofs/zeroCopy/non-marking-mode/zeroCopy.lisp index d32a169b032..e0258355ef3 100644 --- a/books/projects/x86isa/proofs/zeroCopy/non-marking-mode/zeroCopy.lisp +++ b/books/projects/x86isa/proofs/zeroCopy/non-marking-mode/zeroCopy.lisp @@ -804,7 +804,7 @@ (:rewrite acl2::nfix-when-not-natp) (:rewrite acl2::nfix-when-natp) (:rewrite constant-upper-bound-of-logior-for-naturals) - (:linear combine-bytes-size-for-rm64-programmer-level-mode) + ;; (:linear combine-bytes-size-for-rm64-programmer-level-mode) (:rewrite acl2::natp-when-integerp) (:rewrite acl2::natp-when-gte-0) (:rewrite 4k-aligned-physical-address-helper) @@ -1409,6 +1409,34 @@ (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) + (def-gl-export rm64-direct-map-helper + :hyp (and (n08p a) (n08p b) (n08p c) (n08p d) + (n08p e) (n08p f) (n08p g) (n08p h)) + :concl (equal + (logior + a + (ash (logior + b + (ash (logior + c + (ash (logior + d + (ash (logior + e + (ash (logior f (ash (logior g (ash h 8)) 8)) + 8)) + 8)) + 8)) + 8)) + 8)) + (logior a (ash b 8) + (ash (logior c (ash d 8)) 16) + (ash (logior e (ash f 8) (ash (logior g (ash h 8)) 16)) 32))) + :g-bindings + (gl::auto-bindings + (:mix (:nat a 8) (:nat b 8) (:nat c 8) (:nat d 8) + (:nat e 8) (:nat f 8) (:nat g 8) (:nat h 8)))) + (defthm rb-and-rm-low-64-for-direct-map (implies (and (equal @@ -1433,7 +1461,8 @@ rb-and-rm-low-64-for-direct-map-helper) ())))) - (in-theory (e/d () (rb-and-rm-low-64-for-direct-map-helper)))) + (in-theory (e/d () (rb-and-rm-low-64-for-direct-map-helper + rm64-direct-map-helper)))) (defthm ia32e-la-to-pa-page-dir-ptr-table-values-1G-pages-and-write-to-page-dir-ptr-table-entry-addr (b* ((p-addrs (addr-range 8 (page-dir-ptr-table-entry-addr lin-addr base-addr))) From 18867f1acaed49f16ce57f6bcb01de297e6f4f94 Mon Sep 17 00:00:00 2001 From: Shilpi Goel Date: Thu, 21 Jul 2016 20:58:38 -0500 Subject: [PATCH 07/70] x86isa: Fixed broken wordCount proof --- .../projects/x86isa/proofs/wordCount/wc.lisp | 2633 ++++++++++++----- 1 file changed, 1889 insertions(+), 744 deletions(-) diff --git a/books/projects/x86isa/proofs/wordCount/wc.lisp b/books/projects/x86isa/proofs/wordCount/wc.lisp index cabf0de733c..6dd72bb5755 100644 --- a/books/projects/x86isa/proofs/wordCount/wc.lisp +++ b/books/projects/x86isa/proofs/wordCount/wc.lisp @@ -427,119 +427,6 @@ (in-theory (e/d* (subset-p) (env-assumptions i64p))) -(i-am-here) - -(in-theory (e/d* () - ((:DEFINITION CREATE-ADDR-BYTES-ALIST) - (:TYPE-PRESCRIPTION XW) - (:DEFINITION CREATE-CANONICAL-ADDRESS-LIST) - (:REWRITE DEFAULT-+-2) - (:REWRITE DEFAULT-+-1) - (:DEFINITION ACONS) - (:REWRITE CONS-AND-CREATE-ADDR-BYTES-ALIST) - (:REWRITE GET-PREFIXES-OPENER-LEMMA-GROUP-4-PREFIX) - (:REWRITE GET-PREFIXES-OPENER-LEMMA-GROUP-3-PREFIX) - (:REWRITE GET-PREFIXES-OPENER-LEMMA-GROUP-2-PREFIX) - (:REWRITE GET-PREFIXES-OPENER-LEMMA-GROUP-1-PREFIX) - (:TYPE-PRESCRIPTION ACL2::|x < y => 0 < -x+y|) - (:DEFINITION BINARY-APPEND) - (:REWRITE ACL2::APPEND-WHEN-NOT-CONSP) - ;; (:REWRITE CDR-CREATE-CANONICAL-ADDRESS-LIST) - ;; (:REWRITE CANONICAL-ADDRESS-P-LIMITS-THM-0) - (:REWRITE ACL2::CDR-OF-APPEND-WHEN-CONSP) - ;; (:REWRITE CONSP-CREATE-ADDR-BYTES-ALIST) - (:REWRITE WB-NOT-CONSP-ADDR-LST) - ;; (:REWRITE CONSP-OF-CREATE-CANONICAL-ADDRESS-LIST) - (:TYPE-PRESCRIPTION CONSP-APPEND) - ;; (:REWRITE LOOP-PRECONDITIONS-WEIRD-RBP-RSP) - ;; (:REWRITE CANONICAL-ADDRESS-P-LIMITS-THM-1) - (:REWRITE ACL2::LOGHEAD-IDENTITY) - (:REWRITE ACL2::CONSP-WHEN-MEMBER-EQUAL-OF-ATOM-LISTP) - (:TYPE-PRESCRIPTION BITOPS::LOGTAIL-NATP) - ;; (:REWRITE COMBINE-BYTES-OF-RB-OF-1-ADDRESS-IN-PROGRAMMER-LEVEL-MODE) - (:REWRITE SUBSET-P-CDR-Y) - (:TYPE-PRESCRIPTION TRUE-LISTP-CREATE-CANONICAL-ADDRESS-LIST) - (:TYPE-PRESCRIPTION ACL2::|x < y => 0 < y-x|) - (:TYPE-PRESCRIPTION NATP-GET-PREFIXES) - ;; (:REWRITE DISJOINT-P-TWO-CREATE-CANONICAL-ADDRESS-LISTS-THM-0) - (:REWRITE CAR-CREATE-CANONICAL-ADDRESS-LIST) - (:TYPE-PRESCRIPTION CONSP-CREATE-ADDR-BYTES-ALIST) - ;; (:REWRITE DISJOINT-P-TWO-CREATE-CANONICAL-ADDRESS-LISTS-THM-1) - (:REWRITE LOGHEAD-OF-NON-INTEGERP) - (:REWRITE ACL2::CAR-OF-APPEND) - (:REWRITE ACL2::EQUAL-OF-BOOLEANS-REWRITE) - (:LINEAR RGFI-IS-I64P . 1) - (:LINEAR RGFI-IS-I64P . 2) - ;; (:REWRITE RB-IN-TERMS-OF-NTH-AND-POS) - (:REWRITE ACL2::CONSP-OF-APPEND) - (:REWRITE DEFAULT-<-1) - (:TYPE-PRESCRIPTION BYTE-IFY) - (:TYPE-PRESCRIPTION CONSP-CREATE-ADDR-BYTES-ALIST-IN-TERMS-OF-LEN) - (:REWRITE ACL2::LOGTAIL-IDENTITY) - (:REWRITE GREATER-LOGBITP-OF-UNSIGNED-BYTE-P . 2) - (:REWRITE BITOPS::UNSIGNED-BYTE-P-WHEN-UNSIGNED-BYTE-P-LESS) - (:REWRITE DEFAULT-UNARY-MINUS) - (:TYPE-PRESCRIPTION ACL2::TRUE-LISTP-APPEND) - (:TYPE-PRESCRIPTION BINARY-APPEND) - (:TYPE-PRESCRIPTION MSRI-IS-N64P) - (:REWRITE LOGHEAD-ZERO-SMALLER) - (:REWRITE DEFAULT-<-2) - (:DEFINITION LEN) - (:REWRITE ZF-SPEC-THM) - (:REWRITE UNSIGNED-BYTE-P-OF-LOGTAIL) - (:LINEAR RIP-IS-I48P . 2) - (:REWRITE PROGRAMMER-LEVEL-MODE-RM08-NO-ERROR) - (:REWRITE ACL2::EQUAL-CONSTANT-+) - (:LINEAR RIP-IS-I48P . 1) - (:REWRITE ACL2::ZP-WHEN-INTEGERP) - (:TYPE-PRESCRIPTION TRUE-LISTP-CREATE-ADDR-BYTES-ALIST) - (:REWRITE ACL2::IFIX-WHEN-NOT-INTEGERP) - (:REWRITE BITOPS::LOGBITP-NONZERO-OF-BIT) - (:REWRITE ACL2::COMMUTATIVITY-2-OF-+) - (:REWRITE RM08-VALUE-WHEN-ERROR) - (:REWRITE ACL2::DIFFERENCE-UNSIGNED-BYTE-P) - (:LINEAR MEMBER-P-POS-VALUE) - (:LINEAR MEMBER-P-POS-1-VALUE) - (:LINEAR ACL2::INDEX-OF-<-LEN) - (:REWRITE CONSP-BYTE-IFY) - (:REWRITE ACL2::ZP-WHEN-GT-0) - (:REWRITE RIGHT-SHIFT-TO-LOGTAIL) - (:TYPE-PRESCRIPTION BOOLEANP) - (:TYPE-PRESCRIPTION ACL2::BOOL->BIT$INLINE) - (:REWRITE BITOPS::BASIC-UNSIGNED-BYTE-P-OF-+) - (:REWRITE BITOPS::LOGBITP-WHEN-BITMASKP) - (:LINEAR MSRI-IS-N64P) - (:TYPE-PRESCRIPTION ADDR-BYTE-ALISTP-CREATE-ADDR-BYTES-ALIST) - (:REWRITE BITOPS::LOGTAIL-OF-LOGTAIL) - (:TYPE-PRESCRIPTION BITP) - (:TYPE-PRESCRIPTION ACL2::BITMASKP$INLINE) - ;; (:REWRITE GET-PREFIXES-OPENER-LEMMA-ZERO-CNT) - (:REWRITE N43P-GET-PREFIXES) - ;; (:REWRITE XW-XW-INTRA-SIMPLE-FIELD-SHADOW-WRITES) - ;; (:REWRITE X86-RUN-HALTED) - (:TYPE-PRESCRIPTION X86-DECODE-SIB-P) - (:TYPE-PRESCRIPTION ACL2::EXPT-TYPE-PRESCRIPTION-POSITIVE) - (:TYPE-PRESCRIPTION ACL2::EXPT-TYPE-PRESCRIPTION-NONZERO) - (:TYPE-PRESCRIPTION ACL2::EXPT-TYPE-PRESCRIPTION-INTEGERP) - (:REWRITE BITOPS::NORMALIZE-LOGBITP-WHEN-MODS-EQUAL) - (:REWRITE BITOPS::LOGBITP-OF-NEGATIVE-CONST) - (:REWRITE BITOPS::LOGBITP-OF-MASK) - (:REWRITE BITOPS::LOGBITP-OF-CONST) - (:REWRITE GREATER-LOGBITP-OF-UNSIGNED-BYTE-P . 1) - ;; (:REWRITE DISJOINT-P-SUBSET-P) - (:META BITOPS::OPEN-LOGBITP-OF-CONST-LITE-META) - (:TYPE-PRESCRIPTION N43P$INLINE) - ;; (:REWRITE X86-RUN-OPENER-NOT-MS-NOT-FAULT-ZP-N) - ))) - -(acl2::why x86-run-opener-not-ms-not-zp-n) -(acl2::why x86-fetch-decode-execute-opener) -(acl2::why get-prefixes-opener-lemma-no-prefix-byte) -(acl2::why rb-in-terms-of-nth-and-pos) -(acl2::why program-at-wb-disjoint) -(acl2::why member-p-canonical-address-listp) -(acl2::why rb-wb-disjoint) - (defthm effects-to-gc-no-call ;; push %rbp @@ -678,7 +565,13 @@ append-and-create-addr-bytes-alist cons-and-create-addr-bytes-alist append-and-addr-byte-alistp - force (force)))))) + las-to-pas-values-and-!flgi + las-to-pas + default-+-2 + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) ;; ---------------------------------------------------------------------- ;; Main: before the call to the GC procedure: Projection Theorems: @@ -816,7 +709,10 @@ :r (x86-run (gc-clk-main-before-call) x86))) (byte-ify 4 0))) - :hints (("Goal" :in-theory (e/d* () ())))) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-to-gc-variables-nc (implies (and (bind-free '((addr . addr)) (addr)) @@ -825,7 +721,11 @@ (create-canonical-address-list 4 (+ -20 (xr :rgf *rsp* x86))) :r (x86-run (gc-clk-main-before-call) x86))) - (byte-ify 4 0)))) + (byte-ify 4 0))) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-to-gc-variables-nw (implies (and (bind-free '((addr . addr)) (addr)) @@ -834,7 +734,11 @@ (create-canonical-address-list 4 (+ -24 (xr :rgf *rsp* x86))) :r (x86-run (gc-clk-main-before-call) x86))) - (byte-ify 4 0)))) + (byte-ify 4 0))) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-to-gc-variables-nl (implies (and (bind-free '((addr . addr)) (addr)) @@ -843,7 +747,11 @@ (create-canonical-address-list 4 (+ -28 (xr :rgf *rsp* x86))) :r (x86-run (gc-clk-main-before-call) x86))) - (byte-ify 4 0)))) + (byte-ify 4 0))) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) ;;====================================================================== ;; -------------------------------------------------------------------- @@ -859,175 +767,175 @@ ;; env-assumptions: (encapsulate - () - - (local (in-theory (e/d* (take nthcdr) ()))) - - (local - (encapsulate - () - - (local (include-book "std/lists/take" :dir :system)) - - (local - (defthm len-grab-bytes-when-string-non-empty-helper-1 - (implies (and (byte-listp bytes-of-obj) - (< obj-offset (len bytes-of-obj)) - (< 0 (len bytes-of-obj))) - (and (byte-listp (nthcdr obj-offset bytes-of-obj)) - (< 0 (len (nthcdr obj-offset bytes-of-obj))))))) - - (local - (defthm len-grab-bytes-when-string-non-empty-helper-2 - (implies (and (byte-listp bytes-of-obj) - (< obj-offset (len bytes-of-obj)) - (< 0 (len bytes-of-obj))) - (byte-listp (take 1 (nthcdr obj-offset - bytes-of-obj)))) - :hints (("Goal" :in-theory (e/d* () (take-byte-listp)) - :use ((:instance take-byte-listp - (xs (nthcdr obj-offset bytes-of-obj)) - (n 1))))))) - - (defthmd len-grab-bytes-when-string-non-empty - (implies (and (byte-listp bytes-of-obj) - (< obj-offset (len bytes-of-obj)) - (< 0 (len bytes-of-obj))) - (and (nthcdr obj-offset bytes-of-obj) - (< 0 (len (nthcdr obj-offset bytes-of-obj))) - (byte-listp (nthcdr obj-offset bytes-of-obj)) - (take 1 (nthcdr obj-offset bytes-of-obj)) - (true-listp (take 1 (nthcdr obj-offset bytes-of-obj))) - (byte-listp (take 1 (nthcdr obj-offset bytes-of-obj))) - - (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj))) - (equal (len (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))) 1) - (byte-listp (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))) - (true-listp (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))) - (unsigned-byte-p 8 (car (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj))))))) - :hints (("Goal" :in-theory (e/d* (grab-bytes - unsigned-byte-p) - (len-grab-bytes-when-string-non-empty-helper-2)) - :use ((:instance len-grab-bytes-when-string-non-empty-helper-2))))) - - )) ;; End of local encapsulate - - (defthm byte-listp-of-bytes-of-obj-from-environment-assumptions - (b* ((file-des-field (read-x86-file-des 0 x86)) - (obj-name (cdr (assoc :name file-des-field))) - (obj-contents-field (read-x86-file-contents obj-name x86)) - (obj-contents (cdr (assoc :contents obj-contents-field))) - (bytes-of-obj (string-to-bytes obj-contents))) - (implies - ;; (and (file-descriptor-fieldp file-des-field) - ;; (file-contents-fieldp obj-contents-field)) - (and (env-assumptions x86) - (x86p x86)) - (byte-listp bytes-of-obj))) - :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) - (take nthcdr))))) - - - (defthm byte-listp-and-consp-of-take-from-environment-assumptions - (b* ((file-des-field (read-x86-file-des 0 x86)) - (obj-offset (cdr (assoc :offset file-des-field))) - (obj-name (cdr (assoc :name file-des-field))) - (obj-contents-field (read-x86-file-contents obj-name x86)) - (obj-contents (cdr (assoc :contents obj-contents-field))) - (bytes-of-obj (string-to-bytes obj-contents))) - (implies - ;; (and (file-descriptor-fieldp file-des-field) - ;; (file-contents-fieldp obj-contents-field)) - (and (env-assumptions x86) - (x86p x86)) - (and (byte-listp (take 1 (nthcdr obj-offset bytes-of-obj))) - (consp (take 1 (nthcdr obj-offset bytes-of-obj)))))) - :hints (("Goal" :in-theory (e/d* (env-assumptions) - (take nthcdr))))) - - (defthm byte-listp-of-grab-bytes-from-environment-assumptions - (b* ((file-des-field (read-x86-file-des 0 x86)) - (obj-offset (cdr (assoc :offset file-des-field))) - (obj-name (cdr (assoc :name file-des-field))) - (obj-contents-field (read-x86-file-contents obj-name x86)) - (obj-contents (cdr (assoc :contents obj-contents-field))) - (bytes-of-obj (string-to-bytes obj-contents))) - (implies - ;; (and (file-descriptor-fieldp file-des-field) - ;; (file-contents-fieldp obj-contents-field)) - (and (env-assumptions x86) - (x86p x86)) - (byte-listp (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))))) - :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) - (take nthcdr))))) - - (defthm non-nil-grab-bytes-of-take-1-from-environment-assumptions - (b* ((file-des-field (read-x86-file-des 0 x86)) - (obj-offset (cdr (assoc :offset file-des-field))) - (obj-name (cdr (assoc :name file-des-field))) - (obj-contents-field (read-x86-file-contents obj-name x86)) - (obj-contents (cdr (assoc :contents obj-contents-field))) - (bytes-of-obj (string-to-bytes obj-contents))) - (implies - ;; (and (file-descriptor-fieldp file-des-field) - ;; (file-contents-fieldp obj-contents-field) - ;; (< obj-offset (len bytes-of-obj))) - (and (env-assumptions x86) - (x86p x86)) - (and (nthcdr obj-offset bytes-of-obj) - (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))))) - :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) - (take nthcdr acl2::take-of-1 acl2::take-of-zero))))) - - (defthm len-of-grab-bytes-take-1-from-environment-assumptions - (b* ((file-des-field (read-x86-file-des 0 x86)) - (obj-offset (cdr (assoc :offset file-des-field))) - (obj-name (cdr (assoc :name file-des-field))) - (obj-contents-field (read-x86-file-contents obj-name x86)) - (obj-contents (cdr (assoc :contents obj-contents-field))) - (bytes-of-obj (string-to-bytes obj-contents))) - (implies - ;; (and (file-descriptor-fieldp file-des-field) - ;; (file-contents-fieldp obj-contents-field) - ;; (< obj-offset (len bytes-of-obj))) - (and (env-assumptions x86) - (x86p x86)) - (equal (len (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))) 1))) - :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) - (take nthcdr acl2::take-of-zero acl2::take-of-1))))) - - (defthm n08p-of-car-grab-bytes-from-environment-assumptions - (b* ((file-des-field (read-x86-file-des 0 x86)) - (obj-offset (cdr (assoc :offset file-des-field))) - (obj-name (cdr (assoc :name file-des-field))) - (obj-contents-field (read-x86-file-contents obj-name x86)) - (obj-contents (cdr (assoc :contents obj-contents-field))) - (bytes-of-obj (string-to-bytes obj-contents))) - (implies - ;; (and (file-descriptor-fieldp file-des-field) - ;; (file-contents-fieldp obj-contents-field) - ;; (< obj-offset (len bytes-of-obj))) - (and (env-assumptions x86) - (x86p x86)) - (unsigned-byte-p 8 (car (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj))))))) - :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) - (take nthcdr acl2::take-of-1 acl2::take-of-zero))))) - - (defthm len-of-nthcdr-of-object-from-environment-assumptions - (implies (and (file-descriptor-fieldp (read-x86-file-des 0 x86)) - (equal obj-offset (cdr (assoc :offset (read-x86-file-des 0 x86)))) - (equal obj-name (cdr (assoc :name (read-x86-file-des 0 x86)))) - (equal obj-contents-field (read-x86-file-contents obj-name x86)) - (file-contents-fieldp obj-contents-field) - (equal obj-contents (cdr (assoc :contents obj-contents-field))) - (equal bytes-of-obj (string-to-bytes obj-contents)) - (< obj-offset (len bytes-of-obj))) - (< 0 (len (nthcdr obj-offset bytes-of-obj)))) - :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) - (take nthcdr acl2::take-of-zero acl2::take-of-1)))) - :rule-classes (:linear :rewrite)) - - ) ;; End of encapsulate + () + + (local (in-theory (e/d* (take nthcdr) ()))) + + (local + (encapsulate + () + + (local (include-book "std/lists/take" :dir :system)) + + (local + (defthm len-grab-bytes-when-string-non-empty-helper-1 + (implies (and (byte-listp bytes-of-obj) + (< obj-offset (len bytes-of-obj)) + (< 0 (len bytes-of-obj))) + (and (byte-listp (nthcdr obj-offset bytes-of-obj)) + (< 0 (len (nthcdr obj-offset bytes-of-obj))))))) + + (local + (defthm len-grab-bytes-when-string-non-empty-helper-2 + (implies (and (byte-listp bytes-of-obj) + (< obj-offset (len bytes-of-obj)) + (< 0 (len bytes-of-obj))) + (byte-listp (take 1 (nthcdr obj-offset + bytes-of-obj)))) + :hints (("Goal" :in-theory (e/d* () (take-byte-listp)) + :use ((:instance take-byte-listp + (xs (nthcdr obj-offset bytes-of-obj)) + (n 1))))))) + + (defthmd len-grab-bytes-when-string-non-empty + (implies (and (byte-listp bytes-of-obj) + (< obj-offset (len bytes-of-obj)) + (< 0 (len bytes-of-obj))) + (and (nthcdr obj-offset bytes-of-obj) + (< 0 (len (nthcdr obj-offset bytes-of-obj))) + (byte-listp (nthcdr obj-offset bytes-of-obj)) + (take 1 (nthcdr obj-offset bytes-of-obj)) + (true-listp (take 1 (nthcdr obj-offset bytes-of-obj))) + (byte-listp (take 1 (nthcdr obj-offset bytes-of-obj))) + + (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj))) + (equal (len (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))) 1) + (byte-listp (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))) + (true-listp (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))) + (unsigned-byte-p 8 (car (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj))))))) + :hints (("Goal" :in-theory (e/d* (grab-bytes + unsigned-byte-p) + (len-grab-bytes-when-string-non-empty-helper-2)) + :use ((:instance len-grab-bytes-when-string-non-empty-helper-2))))) + + )) ;; End of local encapsulate + + (defthm byte-listp-of-bytes-of-obj-from-environment-assumptions + (b* ((file-des-field (read-x86-file-des 0 x86)) + (obj-name (cdr (assoc :name file-des-field))) + (obj-contents-field (read-x86-file-contents obj-name x86)) + (obj-contents (cdr (assoc :contents obj-contents-field))) + (bytes-of-obj (string-to-bytes obj-contents))) + (implies + ;; (and (file-descriptor-fieldp file-des-field) + ;; (file-contents-fieldp obj-contents-field)) + (and (env-assumptions x86) + (x86p x86)) + (byte-listp bytes-of-obj))) + :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) + (take nthcdr))))) + + + (defthm byte-listp-and-consp-of-take-from-environment-assumptions + (b* ((file-des-field (read-x86-file-des 0 x86)) + (obj-offset (cdr (assoc :offset file-des-field))) + (obj-name (cdr (assoc :name file-des-field))) + (obj-contents-field (read-x86-file-contents obj-name x86)) + (obj-contents (cdr (assoc :contents obj-contents-field))) + (bytes-of-obj (string-to-bytes obj-contents))) + (implies + ;; (and (file-descriptor-fieldp file-des-field) + ;; (file-contents-fieldp obj-contents-field)) + (and (env-assumptions x86) + (x86p x86)) + (and (byte-listp (take 1 (nthcdr obj-offset bytes-of-obj))) + (consp (take 1 (nthcdr obj-offset bytes-of-obj)))))) + :hints (("Goal" :in-theory (e/d* (env-assumptions) + (take nthcdr))))) + + (defthm byte-listp-of-grab-bytes-from-environment-assumptions + (b* ((file-des-field (read-x86-file-des 0 x86)) + (obj-offset (cdr (assoc :offset file-des-field))) + (obj-name (cdr (assoc :name file-des-field))) + (obj-contents-field (read-x86-file-contents obj-name x86)) + (obj-contents (cdr (assoc :contents obj-contents-field))) + (bytes-of-obj (string-to-bytes obj-contents))) + (implies + ;; (and (file-descriptor-fieldp file-des-field) + ;; (file-contents-fieldp obj-contents-field)) + (and (env-assumptions x86) + (x86p x86)) + (byte-listp (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))))) + :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) + (take nthcdr))))) + + (defthm non-nil-grab-bytes-of-take-1-from-environment-assumptions + (b* ((file-des-field (read-x86-file-des 0 x86)) + (obj-offset (cdr (assoc :offset file-des-field))) + (obj-name (cdr (assoc :name file-des-field))) + (obj-contents-field (read-x86-file-contents obj-name x86)) + (obj-contents (cdr (assoc :contents obj-contents-field))) + (bytes-of-obj (string-to-bytes obj-contents))) + (implies + ;; (and (file-descriptor-fieldp file-des-field) + ;; (file-contents-fieldp obj-contents-field) + ;; (< obj-offset (len bytes-of-obj))) + (and (env-assumptions x86) + (x86p x86)) + (and (nthcdr obj-offset bytes-of-obj) + (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))))) + :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) + (take nthcdr acl2::take-of-1 acl2::take-of-zero))))) + + (defthm len-of-grab-bytes-take-1-from-environment-assumptions + (b* ((file-des-field (read-x86-file-des 0 x86)) + (obj-offset (cdr (assoc :offset file-des-field))) + (obj-name (cdr (assoc :name file-des-field))) + (obj-contents-field (read-x86-file-contents obj-name x86)) + (obj-contents (cdr (assoc :contents obj-contents-field))) + (bytes-of-obj (string-to-bytes obj-contents))) + (implies + ;; (and (file-descriptor-fieldp file-des-field) + ;; (file-contents-fieldp obj-contents-field) + ;; (< obj-offset (len bytes-of-obj))) + (and (env-assumptions x86) + (x86p x86)) + (equal (len (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj)))) 1))) + :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) + (take nthcdr acl2::take-of-zero acl2::take-of-1))))) + + (defthm n08p-of-car-grab-bytes-from-environment-assumptions + (b* ((file-des-field (read-x86-file-des 0 x86)) + (obj-offset (cdr (assoc :offset file-des-field))) + (obj-name (cdr (assoc :name file-des-field))) + (obj-contents-field (read-x86-file-contents obj-name x86)) + (obj-contents (cdr (assoc :contents obj-contents-field))) + (bytes-of-obj (string-to-bytes obj-contents))) + (implies + ;; (and (file-descriptor-fieldp file-des-field) + ;; (file-contents-fieldp obj-contents-field) + ;; (< obj-offset (len bytes-of-obj))) + (and (env-assumptions x86) + (x86p x86)) + (unsigned-byte-p 8 (car (grab-bytes (take 1 (nthcdr obj-offset bytes-of-obj))))))) + :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) + (take nthcdr acl2::take-of-1 acl2::take-of-zero))))) + + (defthm len-of-nthcdr-of-object-from-environment-assumptions + (implies (and (file-descriptor-fieldp (read-x86-file-des 0 x86)) + (equal obj-offset (cdr (assoc :offset (read-x86-file-des 0 x86)))) + (equal obj-name (cdr (assoc :name (read-x86-file-des 0 x86)))) + (equal obj-contents-field (read-x86-file-contents obj-name x86)) + (file-contents-fieldp obj-contents-field) + (equal obj-contents (cdr (assoc :contents obj-contents-field))) + (equal bytes-of-obj (string-to-bytes obj-contents)) + (< obj-offset (len bytes-of-obj))) + (< 0 (len (nthcdr obj-offset bytes-of-obj)))) + :hints (("Goal" :in-theory (e/d* (len-grab-bytes-when-string-non-empty env-assumptions) + (take nthcdr acl2::take-of-zero acl2::take-of-1)))) + :rule-classes (:linear :rewrite)) + + ) ;; End of encapsulate (local (in-theory (e/d* () (acl2::take-of-1 acl2::take-of-zero take nthcdr)))) @@ -1226,8 +1134,7 @@ (!FLGI *SF* 0 (!FLGI *OF* 0 X86)))))))))))))))))))))))) :hints (("Goal" :do-not '(preprocess) - :in-theory (e/d* ( - syscall-read + :in-theory (e/d* (syscall-read syscall-read-logic x86-syscall-read syscall-write @@ -1277,8 +1184,16 @@ ;; Flags write-user-rflags) - (wb-remove-duplicate-writes - force (force)))))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) ;; ---------------------------------------------------------------------- ;; Call GC + GC Procedure: Projection Theorems: @@ -1523,7 +1438,17 @@ effects-call-gc-ms-projection effects-call-gc-fault-projection loop-preconditions) - (x86-run-plus))))) + (x86-run-plus + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) (defthm effects-eof-encountered @@ -2210,7 +2135,17 @@ loop-preconditions gc-clk-no-eof) - (x86-run-plus))))) + (x86-run-plus + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) ;;---------------------------------------------------------------------- ;; EOF Not Encountered: Projection Theorems: @@ -2308,7 +2243,12 @@ :contents (read-x86-file-contents (cdr (assoc-equal :name (read-x86-file-des 0 x86))) x86)))))))))))) - :hints (("Goal" :use ((:instance loop-preconditions-fwd-chaining-essentials))))) + :hints (("Goal" + :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp)) + :use ((:instance loop-preconditions-fwd-chaining-essentials))))) (defthmd effects-eof-not-encountered-prelim-gc-byte-projection-size (implies (and (bind-free '((addr . addr)) (addr)) @@ -2326,7 +2266,10 @@ :in-theory (e/d* (remove-loghead-from-byte-ify combine-bytes-and-byte-ify-inequality-lemma) (effects-eof-not-encountered-prelim - n08p-of-car-grab-bytes-from-environment-assumptions))))) + n08p-of-car-grab-bytes-from-environment-assumptions + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-eof-not-encountered-prelim-word-state-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -2454,7 +2397,6 @@ :hints (("Goal" :in-theory (e/d* (x86-run-plus-1) (x86-run-plus))))) - (defthmd programmer-level-mode-permissions-dont-matter ;; [Shilpi]: This thing won't be true once I incorporate the ;; memory-permissions map into the programmer-level mode, unless I make sure @@ -2465,16 +2407,26 @@ (equal (mv-nth 1 (rb addresses :x x86)) (mv-nth 1 (rb addresses :r x86)))) :hints (("Goal" :in-theory (e/d* (rb rm08) - (rb-1-accumulator-thm))) - ("Subgoal *1/6" - :use ((:instance rb-1-accumulator-thm - (acc (list (mv-nth 1 (rvm08 (car addresses) x86)))) - (addresses (cdr addresses)) - (r-w-x :x)) - (:instance rb-1-accumulator-thm - (acc (list (mv-nth 1 (rvm08 (car addresses) x86)))) - (addresses (cdr addresses)) - (r-w-x :r)))))) + (rb-1-accumulator-thm + rm08-to-rb + (:meta acl2::mv-nth-cons-meta)))) + (if + ;; Apply to all subgoals under a top-level induction. + (and (consp (car id)) + (< 1 (len (car id)))) + '(:in-theory (e/d* (rb rm08) + (rm08-to-rb + rb-1-accumulator-thm + (:meta acl2::mv-nth-cons-meta))) + :use ((:instance rb-1-accumulator-thm + (acc (list (mv-nth 1 (rvm08 (car addresses) x86)))) + (addresses (cdr addresses)) + (r-w-x :x)) + (:instance rb-1-accumulator-thm + (acc (list (mv-nth 1 (rvm08 (car addresses) x86)))) + (addresses (cdr addresses)) + (r-w-x :r)))) + nil))) (defthmd effects-newline-encountered-limited @@ -2593,7 +2545,17 @@ two-byte-opcode-decode-and-execute x86-effective-addr x86-run-plus-1) - (x86-run-plus))))) + (x86-run-plus + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) (defthmd effects-newline-encountered-1 @@ -2871,7 +2833,11 @@ (loop-preconditions addr x86) (equal (get-char (offset x86) (input x86)) *newline*)) (equal (combine-bytes (word-state x86 (x86-run (gc-clk-newline) x86))) - *out*))) + *out*)) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-newline-encountered-variables-state-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -2890,7 +2856,9 @@ (loghead 32 (+ 1 (combine-bytes (nc x86 x86)))))) :hints (("Goal" :in-theory (e/d* (programmer-level-mode-permissions-dont-matter) - (force (force)))))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-newline-encountered-variables-nc-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -2906,7 +2874,11 @@ (implies (and (loop-preconditions addr x86) (equal (get-char (offset x86) (input x86)) *newline*)) (equal (nw x86 (x86-run (gc-clk-newline) x86)) - (nw x86 x86)))) + (nw x86 x86))) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-newline-encountered-variables-nw-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -2925,7 +2897,9 @@ (loghead 32 (+ 1 (combine-bytes (nl x86 x86)))))) :hints (("Goal" :in-theory (e/d* (programmer-level-mode-permissions-dont-matter) - (force (force)))))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-newline-encountered-variables-nl-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -3044,7 +3018,17 @@ two-byte-opcode-decode-and-execute x86-effective-addr x86-run-plus-1) - (x86-run-plus))))) + (x86-run-plus + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) (defthmd effects-space-encountered-1 @@ -3308,7 +3292,11 @@ (loop-preconditions addr x86) (equal (get-char (offset x86) (input x86)) *space*)) (equal (combine-bytes (word-state x86 (x86-run (gc-clk-space) x86))) - *out*))) + *out*)) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-space-encountered-variables-state-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -3326,7 +3314,9 @@ (loghead 32 (+ 1 (combine-bytes (nc x86 x86)))))) :hints (("Goal" :in-theory (e/d* (programmer-level-mode-permissions-dont-matter) - (force (force)))))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-space-encountered-variables-nc-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -3474,7 +3464,17 @@ two-byte-opcode-decode-and-execute x86-effective-addr x86-run-plus-1) - (x86-run-plus))))) + (x86-run-plus + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) (defthmd effects-tab-encountered-1 @@ -3739,7 +3739,11 @@ (loop-preconditions addr x86) (equal (get-char (offset x86) (input x86)) *tab*)) (equal (combine-bytes (word-state x86 (x86-run (gc-clk-tab) x86))) - *out*))) + *out*)) + :hints (("Goal" :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-tab-encountered-variables-state-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -3757,7 +3761,9 @@ (loghead 32 (+ 1 (combine-bytes (nc x86 x86)))))) :hints (("Goal" :in-theory (e/d* (programmer-level-mode-permissions-dont-matter) - (force (force)))))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp))))) (defthmd effects-tab-encountered-variables-nc-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -3803,45 +3809,45 @@ ;;********************************************************************** (encapsulate - () - - (local (include-book "arithmetic-5/top" :dir :system)) - - (defthm effects-newline-not-encountered-helper-1 - (implies (and (not (equal char *newline*)) ;; 10 - (unsigned-byte-p 8 char)) - (equal (equal (loghead 32 (+ -10 (logext 32 char))) 0) nil)) - :hints (("Goal" :in-theory (e/d* (loghead) ())))) - - (defthm effects-newline-not-encountered-helper-2 - (implies (and (not (equal char *newline*)) ;; 10 - (unsigned-byte-p 32 char)) - (equal (equal (loghead 32 (+ -10 char)) 0) nil)) - :hints (("Goal" :in-theory (e/d* (loghead) ())))) - - (defthm effects-space-not-encountered-helper-1 - (implies (and (not (equal char *space*)) ;; 32 - (unsigned-byte-p 8 char)) - (equal (equal (loghead 32 (+ -32 (logext 32 char))) 0) nil)) - :hints (("Goal" :in-theory (e/d* (loghead) ())))) - - (defthm effects-space-not-encountered-helper-2 - (implies (and (not (equal char *space*)) ;; 32 - (unsigned-byte-p 32 char)) - (equal (equal (loghead 32 (+ -32 char)) 0) nil)) - :hints (("Goal" :in-theory (e/d* (loghead) ())))) - - (defthm effects-tab-not-encountered-helper-1 - (implies (and (not (equal char *tab*)) ;; 9 - (unsigned-byte-p 8 char)) - (equal (equal (loghead 32 (+ -9 (logext 32 char))) 0) nil)) - :hints (("Goal" :in-theory (e/d* (loghead) ())))) - - (defthm effects-tab-not-encountered-helper-2 - (implies (and (not (equal char *tab*)) ;; 9 - (unsigned-byte-p 32 char)) - (equal (equal (loghead 32 (+ -9 char)) 0) nil)) - :hints (("Goal" :in-theory (e/d* (loghead) ()))))) + () + + (local (include-book "arithmetic-5/top" :dir :system)) + + (defthm effects-newline-not-encountered-helper-1 + (implies (and (not (equal char *newline*)) ;; 10 + (unsigned-byte-p 8 char)) + (equal (equal (loghead 32 (+ -10 (logext 32 char))) 0) nil)) + :hints (("Goal" :in-theory (e/d* (loghead) ())))) + + (defthm effects-newline-not-encountered-helper-2 + (implies (and (not (equal char *newline*)) ;; 10 + (unsigned-byte-p 32 char)) + (equal (equal (loghead 32 (+ -10 char)) 0) nil)) + :hints (("Goal" :in-theory (e/d* (loghead) ())))) + + (defthm effects-space-not-encountered-helper-1 + (implies (and (not (equal char *space*)) ;; 32 + (unsigned-byte-p 8 char)) + (equal (equal (loghead 32 (+ -32 (logext 32 char))) 0) nil)) + :hints (("Goal" :in-theory (e/d* (loghead) ())))) + + (defthm effects-space-not-encountered-helper-2 + (implies (and (not (equal char *space*)) ;; 32 + (unsigned-byte-p 32 char)) + (equal (equal (loghead 32 (+ -32 char)) 0) nil)) + :hints (("Goal" :in-theory (e/d* (loghead) ())))) + + (defthm effects-tab-not-encountered-helper-1 + (implies (and (not (equal char *tab*)) ;; 9 + (unsigned-byte-p 8 char)) + (equal (equal (loghead 32 (+ -9 (logext 32 char))) 0) nil)) + :hints (("Goal" :in-theory (e/d* (loghead) ())))) + + (defthm effects-tab-not-encountered-helper-2 + (implies (and (not (equal char *tab*)) ;; 9 + (unsigned-byte-p 32 char)) + (equal (equal (loghead 32 (+ -9 char)) 0) nil)) + :hints (("Goal" :in-theory (e/d* (loghead) ()))))) (defthmd effects-other-char-encountered-state-out-limited ;; callq @@ -4053,7 +4059,17 @@ x86-run-plus-1) (x86-run-plus byte-ify - (byte-ify)))))) + (byte-ify) + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) (local (defthm combine-bytes-with-byte-ify-4-inequality-lemma @@ -4370,7 +4386,18 @@ (xr :rgf *rbp* x86))) :hints (("Goal" :in-theory (e/d* () (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + (:rewrite disjoint-p-append-2) + (:definition subset-p) + (:rewrite subset-p-of-append-1) + (:rewrite rb-wb-disjoint) + (:rewrite disjoint-p-subset-p) + (:rewrite member-p-strip-cars-of-remove-duplicate-keys) + (:definition strip-cars) + (:rewrite subset-p-of-append-2) + (:rewrite member-p-append) + (:rewrite consp-create-addr-bytes-alist) + (:rewrite member-p-and-strip-cars-of-remove-duplicate-keys)))))) (defthmd effects-other-char-encountered-state-out-rsp-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -4383,8 +4410,19 @@ (equal (xr :rgf *rsp* (x86-run (gc-clk-otherwise-out) x86)) (xr :rgf *rsp* x86))) :hints (("Goal" :in-theory (e/d* () - (word-state - loop-preconditions-forward-chain-addresses-info))))) + (word-state + loop-preconditions-forward-chain-addresses-info + (:rewrite disjoint-p-append-2) + (:definition subset-p) + (:rewrite subset-p-of-append-1) + (:rewrite rb-wb-disjoint) + (:rewrite disjoint-p-subset-p) + (:rewrite member-p-strip-cars-of-remove-duplicate-keys) + (:definition strip-cars) + (:rewrite subset-p-of-append-2) + (:rewrite member-p-append) + (:rewrite consp-create-addr-bytes-alist) + (:rewrite member-p-and-strip-cars-of-remove-duplicate-keys)))))) (defthmd x86p-effects-other-char-encountered-state-out (implies (and (bind-free '((addr . addr)) (addr)) @@ -4412,7 +4450,160 @@ (equal (ia32_efer-slice :ia32_efer-lma (xr :msr *ia32_efer-idx* (x86-run (gc-clk-otherwise-out) x86))) 1))) :hints (("Goal" - :in-theory (e/d* () (word-state combine-bytes)) + :in-theory (e/d* () + (word-state + combine-bytes + (:rewrite disjoint-p-append-2) + (:definition subset-p) + (:rewrite subset-p-of-append-1) + (:rewrite rb-wb-disjoint) + (:rewrite disjoint-p-subset-p) + (:rewrite member-p-strip-cars-of-remove-duplicate-keys) + (:definition strip-cars) + (:rewrite subset-p-of-append-2) + (:rewrite member-p-append) + (:rewrite consp-create-addr-bytes-alist) + (:rewrite member-p-and-strip-cars-of-remove-duplicate-keys) + (:definition acl2::take-redefinition) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite consp-create-addr-bytes-alist-in-terms-of-len) + (:rewrite wb-not-consp-addr-lst) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite acl2::take-when-atom) + (:definition binary-append) + (:rewrite acl2::zp-when-gt-0) + (:definition assoc-equal) + (:rewrite default-+-2) + (:rewrite default-+-1) + (:type-prescription string-to-bytes) + (:rewrite acl2::zp-open) + (:rewrite acl2::zp-when-integerp) + (:rewrite default-<-2) + (:rewrite cdr-create-canonical-address-list) + (:definition create-canonical-address-list) + (:rewrite canonical-address-p-limits-thm-3) + (:rewrite acl2::equal-of-booleans-rewrite) + (:rewrite acl2::cdr-of-append-when-consp) + (:rewrite consp-of-create-canonical-address-list) + (:rewrite default-<-1) + (:type-prescription consp-append) + (:linear member-p-pos-value) + (:linear member-p-pos-1-value) + (:linear acl2::index-of-<-len) + (:rewrite loghead-of-non-integerp) + (:rewrite acl2::loghead-identity) + (:rewrite car-create-canonical-address-list) + (:rewrite acl2::append-atom-under-list-equiv) + (:rewrite loghead-zero-smaller) + (:type-prescription nfix) + (:rewrite acl2::car-of-append) + (:type-prescription acl2::|x < y => 0 < -x+y|) + (:rewrite bitops::basic-unsigned-byte-p-of-+) + (:rewrite unsigned-byte-p-of-combine-bytes) + (:rewrite acl2::equal-constant-+) + (:rewrite rb-returns-byte-listp) + (:rewrite wb-returns-x86p) + (:rewrite consp-byte-ify) + (:type-prescription natp-combine-bytes) + (:rewrite rb-wb-subset) + (:rewrite strip-cars-of-create-addr-bytes-alist) + (:rewrite zf-spec-thm) + (:linear acl2::loghead-upper-bound) + (:type-prescription bitops::logtail-natp) + (:rewrite acl2::nth-implies-consp-nthcdr) + (:type-prescription acl2::bool->bit$inline) + (:type-prescription acl2::logext-type) + (:type-prescription rb-returns-byte-listp) + (:type-prescription rb-returns-true-listp) + (:rewrite acl2::logtail-identity) + (:definition put-assoc-equal) + (:type-prescription addr-byte-alistp-create-addr-bytes-alist) + (:rewrite acl2::logext-identity) + (:rewrite acl2::consp-of-append) + (:type-prescription n08p-element-of-byte-listp) + (:rewrite len-of-rb-in-system-level-mode) + (:type-prescription consp-create-addr-bytes-alist) + (:meta acl2::mv-nth-cons-meta) + (:definition las-to-pas) + (:rewrite last-is-eof-but-first-is-not-eof-=>-at-least-two-elements) + (:type-prescription byte-listp-append) + (:rewrite len-of-nthcdr-byte-listp) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:definition page-structure-marking-mode$inline) + (:type-prescription true-listp) + (:rewrite bitops::logbitp-nonzero-of-bit) + (:rewrite bitops::logbitp-when-bitmaskp) + (:rewrite bitops::logsquash-cancel) + (:rewrite bitops::normalize-logbitp-when-mods-equal) + (:rewrite bitops::logbitp-of-negative-const) + (:rewrite bitops::logbitp-of-mask) + (:rewrite bitops::logbitp-of-const) + (:rewrite greater-logbitp-of-unsigned-byte-p . 1) + (:meta bitops::open-logbitp-of-const-lite-meta) + (:rewrite bitops::logsquash-of-loghead-zero) + (:type-prescription nth-of-nat-listp-within-bounds) + (:rewrite create-canonical-address-list-1) + (:type-prescription last) + (:type-prescription byte-listp-of-string-to-bytes) + (:rewrite xr-page-structure-marking-mode-mv-nth-1-wb) + (:rewrite canonical-address-p-limits-thm-1) + (:rewrite canonical-address-p-limits-thm-0) + (:type-prescription file-contents-fieldp-implies-stringp-contents) + (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) + (:rewrite len-of-rb-in-programmer-level-mode) + (:type-prescription acl2::|x < y => 0 < y-x|) + (:type-prescription unsigned-byte-p) + (:type-prescription file-contents-fieldp) + (:rewrite xr-and-ia32e-la-to-pa-in-non-marking-mode) + (:rewrite mv-nth-2-ia32e-la-to-pa-system-level-non-marking-mode) + (:rewrite xr-ia32e-la-to-pa) + (:type-prescription consp-create-addr-bytes-alist-in-terms-of-len) + (:definition last) + (:rewrite negative-logand-to-positive-logand-with-integerp-x) + (:rewrite xr-programmer-level-mode-mv-nth-1-wb) + (:rewrite xr-seg-visible-mv-nth-1-wb) + (:rewrite bitops::logand-with-negated-bitmask) + (:rewrite bitops::logand-with-bitmask) + (:rewrite rationalp-implies-acl2-numberp) + (:rewrite weed-out-irrelevant-logand-when-first-operand-constant) + (:rewrite logand-redundant) + (:rewrite bitops::unsigned-byte-p-when-unsigned-byte-p-less) + (:type-prescription zp) + (:type-prescription msri-is-n64p) + (:type-prescription true-listp-create-addr-bytes-alist) + (:type-prescription booleanp) + (:linear len-of-nthcdr-of-object-from-environment-assumptions) + (:linear unsigned-byte-p-of-combine-bytes) + (:linear size-of-combine-bytes) + (:type-prescription rflags-is-n32p) + (:type-prescription seg-visiblei-is-n16p) + (:type-prescription booleanp-page-structure-marking-mode-type) + (:type-prescription acl2::bitmaskp$inline) + (:rewrite acl2::difference-unsigned-byte-p) + (:type-prescription subset-p) + (:type-prescription signed-byte-p) + (:type-prescription bitp) + (:type-prescription bitops::ash-natp-type) + (:rewrite acl2::ifix-when-not-integerp) + (:rewrite acl2::ifix-when-integerp) + (:linear msri-is-n64p) + (:rewrite unsigned-byte-p-of-logtail) + (:rewrite subset-p-cdr-y) + (:type-prescription acl2::expt-type-prescription-positive) + (:type-prescription acl2::expt-type-prescription-nonzero) + (:type-prescription acl2::expt-type-prescription-integerp) + (:rewrite bitops::signed-byte-p-when-unsigned-byte-p-smaller) + (:rewrite bitops::signed-byte-p-when-signed-byte-p-smaller) + (:rewrite bitops::signed-byte-p-monotonicity) + (:linear rflags-is-n32p) + (:rewrite unsigned-byte-p-of-loghead) + (:rewrite acl2::unsigned-byte-p-loghead))) :use ((:instance loop-preconditions-fwd-chaining-essentials))))) (defthmd effects-other-char-encountered-state-out-rip-projection @@ -4424,7 +4615,150 @@ (not (equal (get-char (offset x86) (input x86)) *tab*)) (equal (combine-bytes (word-state x86 x86)) *out*)) (equal (xr :rip 0 (x86-run (gc-clk-otherwise-out) x86)) (+ 145 addr))) - :hints (("Goal" :in-theory (e/d* () (word-state subset-p))))) + :hints (("Goal" :in-theory (e/d* () + ((:definition acl2::take-redefinition) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite acl2::take-when-atom) + (:rewrite acl2::zp-when-gt-0) + (:rewrite default-+-2) + (:definition assoc-equal) + (:definition binary-append) + (:rewrite default-+-1) + (:rewrite acl2::zp-open) + (:rewrite acl2::zp-when-integerp) + (:type-prescription consp-append) + (:rewrite default-<-2) + (:rewrite cdr-create-canonical-address-list) + (:definition create-canonical-address-list) + (:rewrite acl2::cdr-of-append-when-consp) + (:rewrite canonical-address-p-limits-thm-3) + (:rewrite acl2::equal-of-booleans-rewrite) + (:rewrite consp-of-create-canonical-address-list) + (:rewrite default-<-1) + (:rewrite wb-not-consp-addr-lst) + (:rewrite consp-create-addr-bytes-alist) + (:linear member-p-pos-value) + (:linear member-p-pos-1-value) + (:linear acl2::index-of-<-len) + (:definition combine-bytes) + (:rewrite acl2::append-atom-under-list-equiv) + (:rewrite acl2::ash-0) + (:rewrite car-create-canonical-address-list) + (:rewrite acl2::zip-open) + (:rewrite loghead-of-non-integerp) + (:rewrite acl2::loghead-identity) + (:rewrite rb-wb-subset) + (:rewrite loghead-zero-smaller) + (:type-prescription acl2::|x < y => 0 < -x+y|) + (:type-prescription nfix) + (:rewrite acl2::car-of-append) + (:type-prescription consp-create-addr-bytes-alist) + (:rewrite subset-p-of-append-2) + (:rewrite acl2::equal-constant-+) + (:rewrite acl2::nth-implies-consp-nthcdr) + (:linear unsigned-byte-p-of-combine-bytes) + (:linear size-of-combine-bytes) + (:rewrite consp-byte-ify) + (:type-prescription rb-returns-true-listp) + (:type-prescription n08p-element-of-byte-listp) + (:rewrite bitops::basic-unsigned-byte-p-of-+) + (:type-prescription unsigned-byte-p) + (:rewrite unsigned-byte-p-of-combine-bytes) + (:rewrite subset-p-two-create-canonical-address-lists-general) + (:type-prescription true-listp) + (:type-prescription rb-returns-byte-listp) + (:rewrite acl2::consp-of-append) + (:rewrite last-is-eof-but-first-is-not-eof-=>-at-least-two-elements) + (:rewrite len-of-rb-in-system-level-mode) + (:rewrite len-of-nthcdr-byte-listp) + (:type-prescription nth-of-nat-listp-within-bounds) + (:rewrite bitops::unsigned-byte-p-when-unsigned-byte-p-less) + (:type-prescription byte-listp-of-string-to-bytes) + (:type-prescription last) + (:definition las-to-pas) + (:type-prescription bitops::logtail-natp) + (:type-prescription file-contents-fieldp-implies-stringp-contents) + (:type-prescription acl2::bool->bit$inline) + (:rewrite right-shift-to-logtail) + (:meta acl2::mv-nth-cons-meta) + (:type-prescription acl2::|x < y => 0 < y-x|) + (:rewrite subset-p-cons-2) + (:rewrite disjoint-p-subset-p) + (:type-prescription subset-p) + (:type-prescription acl2::logext-type) + (:rewrite len-of-rb-in-programmer-level-mode) + (:rewrite zf-spec-thm) + (:rewrite acl2::logext-identity) + (:rewrite acl2::logtail-identity) + (:linear acl2::loghead-upper-bound) + (:rewrite create-canonical-address-list-1) + (:definition put-assoc-equal) + (:type-prescription file-contents-fieldp) + (:type-prescription zip) + (:type-prescription ifix) + (:rewrite subset-p-cdr-y) + (:definition bitops::part-select-width-low$inline) + (:type-prescription consp-create-addr-bytes-alist-in-terms-of-len) + (:rewrite greater-logbitp-of-unsigned-byte-p . 2) + (:definition last) + (:rewrite bitops::logsquash-cancel) + (:rewrite bitops::logbitp-nonzero-of-bit) + (:rewrite bitops::logsquash-of-loghead-zero) + (:rewrite bitops::logbitp-when-bitmaskp) + (:rewrite rationalp-implies-acl2-numberp) + (:rewrite bitops::normalize-logbitp-when-mods-equal) + (:rewrite bitops::logbitp-of-negative-const) + (:rewrite bitops::logbitp-of-mask) + (:rewrite bitops::logbitp-of-const) + (:rewrite greater-logbitp-of-unsigned-byte-p . 1) + (:meta bitops::open-logbitp-of-const-lite-meta) + (:rewrite negative-logand-to-positive-logand-with-integerp-x) + (:rewrite bitops::logtail-of-0-i) + (:rewrite canonical-address-p-limits-thm-1) + (:rewrite canonical-address-p-limits-thm-0) + (:rewrite bitops::logand-with-negated-bitmask) + (:rewrite bitops::logand-with-bitmask) + (:rewrite xr-!flgi-undefined) + (:rewrite weed-out-irrelevant-logand-when-first-operand-constant) + (:rewrite logand-redundant) + (:type-prescription true-listp-create-addr-bytes-alist) + (:type-prescription booleanp) + (:linear len-of-nthcdr-of-object-from-environment-assumptions) + (:type-prescription zp) + (:type-prescription seg-visiblei-is-n16p) + (:rewrite mv-nth-2-ia32e-la-to-pa-system-level-non-marking-mode) + (:type-prescription natp) + (:rewrite acl2::difference-unsigned-byte-p) + (:type-prescription rflags-is-n32p) + (:type-prescription bitops::ash-natp-type) + (:rewrite acl2::ifix-when-not-integerp) + (:rewrite acl2::ifix-when-integerp) + (:definition page-structure-marking-mode$inline) + (:rewrite not-member-p-canonical-address-listp-when-disjoint-p) + (:type-prescription signed-byte-p) + (:type-prescription booleanp-page-structure-marking-mode-type) + (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) + (:type-prescription acl2::bitmaskp$inline) + (:rewrite unsigned-byte-p-of-logtail) + (:rewrite bitops::signed-byte-p-when-unsigned-byte-p-smaller) + (:rewrite bitops::signed-byte-p-when-signed-byte-p-smaller) + (:rewrite bitops::signed-byte-p-monotonicity) + (:linear rflags-is-n32p) + (:type-prescription bitp) + (:rewrite unsigned-byte-p-of-loghead) + (:type-prescription acl2::expt-type-prescription-positive) + (:type-prescription acl2::expt-type-prescription-nonzero) + (:type-prescription acl2::expt-type-prescription-integerp) + (:rewrite acl2::unsigned-byte-p-loghead) + word-state + subset-p))))) (defthmd effects-other-char-encountered-state-out-ms-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -4436,9 +4770,9 @@ (equal (combine-bytes (word-state x86 x86)) *out*)) (equal (xr :ms 0 (x86-run (gc-clk-otherwise-out) x86)) nil)) :hints (("Goal" :in-theory (e/d* () - (word-state - subset-p - loop-preconditions-forward-chain-addresses-info))))) + (word-state + loop-preconditions-forward-chain-addresses-info + subset-p))))) (defthmd effects-other-char-encountered-state-out-fault-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -4449,7 +4783,25 @@ (not (equal (get-char (offset x86) (input x86)) *tab*)) (equal (combine-bytes (word-state x86 x86)) *out*)) (equal (xr :fault 0 (x86-run (gc-clk-otherwise-out) x86)) nil)) - :hints (("Goal" :in-theory (e/d* () (word-state subset-p))))) + :hints (("Goal" :in-theory (e/d* () + (word-state + subset-p + (:definition acl2::take-redefinition) + (:rewrite las-to-pas-values-and-!flgi) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:definition las-to-pas) + (:rewrite acl2::take-when-atom) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition binary-append) + (:definition assoc-equal)))))) (defthmd effects-other-char-encountered-state-out-program-projection (implies (and (loop-preconditions addr x86) @@ -4466,7 +4818,23 @@ effects-eof-not-encountered-prelim-program-projection effects-eof-not-encountered-prelim-x86p-projection loop-preconditions-weird-rbp-rsp) - (word-state)) + (word-state + (:definition acl2::take-redefinition) + (:rewrite las-to-pas-values-and-!flgi) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:definition las-to-pas) + (:rewrite acl2::take-when-atom) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition binary-append) + (:definition assoc-equal))) :use ((:instance loop-preconditions-fwd-chaining-essentials))))) (defthmd effects-other-char-encountered-state-out-env-assumptions-projection @@ -4484,7 +4852,23 @@ effects-eof-not-encountered-prelim-programmer-level-mode-projection effects-eof-not-encountered-prelim-x86p-projection) (word-state - subset-p))) + subset-p + (:definition acl2::take-redefinition) + (:rewrite las-to-pas-values-and-!flgi) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:definition las-to-pas) + (:rewrite acl2::take-when-atom) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition binary-append) + (:definition assoc-equal)))) ("Goal''" :in-theory (e/d* (env-assumptions eof-terminatedp) (word-state subset-p)) :use ((:instance loop-preconditions-fwd-chaining-essentials))))) @@ -4499,7 +4883,25 @@ (equal (combine-bytes (word-state x86 x86)) *out*)) (equal (xr :programmer-level-mode 0 (x86-run (gc-clk-otherwise-out) x86)) (xr :programmer-level-mode 0 x86))) - :hints (("Goal" :in-theory (e/d* () (word-state subset-p))))) + :hints (("Goal" :in-theory (e/d* () + (word-state + subset-p + (:definition acl2::take-redefinition) + (:rewrite las-to-pas-values-and-!flgi) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:definition las-to-pas) + (:rewrite acl2::take-when-atom) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition binary-append) + (:definition assoc-equal)))))) (defthmd effects-other-char-encountered-state-out-alignment-checking-enabled-p-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -4511,7 +4913,25 @@ (equal (combine-bytes (word-state x86 x86)) *out*)) (equal (alignment-checking-enabled-p (x86-run (gc-clk-otherwise-out) x86)) (alignment-checking-enabled-p x86))) - :hints (("Goal" :in-theory (e/d* () (word-state subset-p))))) + :hints (("Goal" :in-theory (e/d* () + (word-state + subset-p + (:definition acl2::take-redefinition) + (:rewrite las-to-pas-values-and-!flgi) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:definition las-to-pas) + (:rewrite acl2::take-when-atom) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition binary-append) + (:definition assoc-equal)))))) (defthmd effects-other-char-encountered-state-out-os-info-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -4523,7 +4943,25 @@ (equal (combine-bytes (word-state x86 x86)) *out*)) (equal (xr :os-info 0 (x86-run (gc-clk-otherwise-out) x86)) (xr :os-info 0 x86))) - :hints (("Goal" :in-theory (e/d* () (word-state subset-p))))) + :hints (("Goal" :in-theory (e/d* () + (word-state + subset-p + (:definition acl2::take-redefinition) + (:rewrite las-to-pas-values-and-!flgi) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:definition las-to-pas) + (:rewrite acl2::take-when-atom) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition binary-append) + (:definition assoc-equal)))))) (defthm loop-preconditions-other-char-encountered-state-out (implies (and (loop-preconditions addr x86) @@ -4560,7 +4998,25 @@ (equal (combine-bytes (word-state x86 x86)) *out*)) (equal (input (x86-run (gc-clk-otherwise-out) x86)) (input x86))) - :hints (("Goal" :in-theory (e/d* () (word-state subset-p))))) + :hints (("Goal" :in-theory (e/d* () + (word-state + subset-p + (:definition acl2::take-redefinition) + (:rewrite las-to-pas-values-and-!flgi) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:definition las-to-pas) + (:rewrite acl2::take-when-atom) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition binary-append) + (:definition assoc-equal)))))) (defthmd effects-other-char-encountered-state-out-offset-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -4572,7 +5028,25 @@ (equal (combine-bytes (word-state x86 x86)) *out*)) (equal (offset (x86-run (gc-clk-otherwise-out) x86)) (+ 1 (offset x86)))) - :hints (("Goal" :in-theory (e/d* () (word-state subset-p))))) + :hints (("Goal" :in-theory (e/d* () + (word-state + subset-p + (:definition acl2::take-redefinition) + (:rewrite las-to-pas-values-and-!flgi) + (:rewrite acl2::car-nthcdr) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:type-prescription nthcdr-true-listp) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::take-of-len-free) + (:type-prescription file-descriptor-fieldp) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:definition las-to-pas) + (:rewrite acl2::take-when-atom) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + (:definition binary-append) + (:definition assoc-equal)))))) ;;---------------------------------------------------------------------- ;; Other Char Encountered (State = OUT): Delta Variable Theorems: @@ -4589,6 +5063,33 @@ (equal (combine-bytes (word-state x86 (x86-run (gc-clk-otherwise-out) x86))) *in*)) :hints (("Goal" + :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0))) :use ((:instance effects-other-char-encountered-state-out-rbp-projection) (:instance effects-other-char-encountered-state-out))))) @@ -4618,7 +5119,33 @@ (equal (combine-bytes (nc x86 (x86-run (gc-clk-otherwise-out) x86))) (loghead 32 (+ 1 (combine-bytes (nc x86 x86)))))) :hints (("Goal" :in-theory (e/d* (programmer-level-mode-permissions-dont-matter) - (force (force))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + force (force))) :use ((:instance effects-other-char-encountered-state-out) (:instance loop-preconditions-fwd-chaining-essentials))))) @@ -4648,7 +5175,33 @@ (equal (combine-bytes (nw x86 (x86-run (gc-clk-otherwise-out) x86))) (loghead 32 (+ 1 (combine-bytes (nw x86 x86)))))) :hints (("Goal" :in-theory (e/d* (programmer-level-mode-permissions-dont-matter) - (force (force))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + force (force))) :use ((:instance effects-other-char-encountered-state-out) (:instance loop-preconditions-fwd-chaining-essentials))))) @@ -4678,7 +5231,33 @@ (equal (nl x86 (x86-run (gc-clk-otherwise-out) x86)) (nl x86 x86))) :hints (("Goal" :in-theory (e/d* (programmer-level-mode-permissions-dont-matter) - (force (force))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + force (force))) :use ((:instance effects-other-char-encountered-state-out) (:instance loop-preconditions-fwd-chaining-essentials))))) @@ -4904,7 +5483,17 @@ remove-loghead-from-combine-bytes) (x86-run-plus byte-ify - (byte-ify)))))) + (byte-ify) + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix))))) (local (defthmd combine-bytes-and-byte-ify-inequality-lemma-for-n=4 @@ -5255,7 +5844,33 @@ (xr :rgf *rbp* x86))) :hints (("Goal" :in-theory (e/d* () (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-rsp-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -5269,7 +5884,33 @@ (xr :rgf *rsp* x86))) :hints (("Goal" :in-theory (e/d* () (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-rsp-projection-new (implies (and (bind-free '((addr . addr)) (addr)) @@ -5294,7 +5935,33 @@ (x86p (x86-run (gc-clk-otherwise-in) x86))) :hints (("Goal" :in-theory (e/d* (loop-preconditions) (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-msri-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -5308,7 +5975,35 @@ (x86-run (gc-clk-otherwise-in) x86))) 1) (equal (ia32_efer-slice :ia32_efer-lma (xr :msr *ia32_efer-idx* (x86-run (gc-clk-otherwise-in) x86))) 1))) - :hints (("Goal" :in-theory (e/d* () (combine-bytes word-state)) + :hints (("Goal" :in-theory (e/d* () + (combine-bytes + word-state + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0))) :use ((:instance loop-preconditions-fwd-chaining-essentials))))) (defthmd effects-other-char-encountered-state-in-rip-projection @@ -5321,7 +6016,35 @@ (not (equal (combine-bytes (word-state x86 x86)) *out*))) (equal (xr :rip 0 (x86-run (gc-clk-otherwise-in) x86)) (+ 145 addr))) - :hints (("Goal" :in-theory (e/d* () (word-state subset-p))))) + :hints (("Goal" :in-theory (e/d* () + (word-state + subset-p + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-ms-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -5334,7 +6057,33 @@ (equal (xr :ms 0 (x86-run (gc-clk-otherwise-in) x86)) nil)) :hints (("Goal" :in-theory (e/d* () (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-fault-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -5347,7 +6096,33 @@ (equal (xr :fault 0 (x86-run (gc-clk-otherwise-in) x86)) nil)) :hints (("Goal" :in-theory (e/d* () (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-program-projection (implies (and (loop-preconditions addr x86) (equal len-wc (len *wc*)) @@ -5364,7 +6139,33 @@ effects-eof-not-encountered-prelim-program-projection effects-eof-not-encountered-prelim-x86p-projection loop-preconditions-weird-rbp-rsp) - (word-state)) + (word-state + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0))) :use ((:instance loop-preconditions-fwd-chaining-essentials))))) (defthmd effects-other-char-encountered-state-in-env-assumptions-projection @@ -5382,7 +6183,33 @@ effects-eof-not-encountered-prelim-programmer-level-mode-projection effects-eof-not-encountered-prelim-x86p-projection) (word-state - subset-p))) + subset-p + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))) ("Goal''" :in-theory (e/d* (env-assumptions eof-terminatedp) (word-state subset-p)) @@ -5400,8 +6227,34 @@ (equal (xr :programmer-level-mode 0 (x86-run (gc-clk-otherwise-in) x86)) (xr :programmer-level-mode 0 x86))) :hints (("Goal" :in-theory (e/d* () - (word-state - loop-preconditions-forward-chain-addresses-info))))) + (word-state + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-alignment-checking-enabled-p-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -5415,7 +6268,33 @@ (alignment-checking-enabled-p x86))) :hints (("Goal" :in-theory (e/d* () (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-os-info-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -5427,7 +6306,35 @@ (not (equal (combine-bytes (word-state x86 x86)) *out*))) (equal (xr :os-info 0 (x86-run (gc-clk-otherwise-in) x86)) (xr :os-info 0 x86))) - :hints (("Goal" :in-theory (e/d* () (word-state loop-preconditions-forward-chain-addresses-info))))) + :hints (("Goal" :in-theory (e/d* () + (word-state + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthm loop-preconditions-other-char-encountered-state-in-pre (implies (and (loop-preconditions addr x86) @@ -5466,7 +6373,33 @@ (input x86))) :hints (("Goal" :in-theory (e/d* () (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthmd effects-other-char-encountered-state-in-offset-projection-pre (implies (and (bind-free '((addr . addr)) (addr)) @@ -5480,7 +6413,33 @@ (+ 1 (offset x86)))) :hints (("Goal" :in-theory (e/d* () (word-state - loop-preconditions-forward-chain-addresses-info))))) + loop-preconditions-forward-chain-addresses-info + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0)))))) (defthm loop-preconditions-other-char-encountered-state-in (implies (and (loop-preconditions addr x86) @@ -5490,7 +6449,8 @@ (not (equal (get-char (offset x86) (input x86)) *tab*)) (not (equal (combine-bytes (word-state x86 x86)) *out*))) (loop-preconditions addr (x86-run (gc-clk-otherwise-in) x86))) - :hints (("Goal":use ((:instance loop-preconditions-other-char-encountered-state-in-pre))))) + :hints (("Goal" + :use ((:instance loop-preconditions-other-char-encountered-state-in-pre))))) (defthmd effects-other-char-encountered-state-in-input-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -5502,7 +6462,8 @@ (not (equal (combine-bytes (word-state x86 x86)) *out*))) (equal (input (x86-run (gc-clk-otherwise-in) x86)) (input x86))) - :hints (("Goal" :use ((:instance effects-other-char-encountered-state-in-input-projection-pre))))) + :hints (("Goal" + :use ((:instance effects-other-char-encountered-state-in-input-projection-pre))))) (defthmd effects-other-char-encountered-state-in-offset-projection (implies (and (bind-free '((addr . addr)) (addr)) @@ -5531,6 +6492,33 @@ (equal (word-state x86 (x86-run (gc-clk-otherwise-in) x86)) (word-state x86 x86))) :hints (("Goal" + :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0))) :use ((:instance effects-other-char-encountered-state-in) (:instance loop-preconditions-fwd-chaining-essentials))))) @@ -5544,7 +6532,35 @@ (not (equal (combine-bytes (word-state x86 x86)) *out*))) (equal (word-state (x86-run (gc-clk-otherwise-in) x86) xxx) (word-state x86 xxx))) - :hints (("Goal" :use ((:instance effects-other-char-encountered-state-in-rbp-projection))))) + :hints (("Goal" + :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0))) + :use ((:instance effects-other-char-encountered-state-in-rbp-projection))))) (defthmd effects-other-char-encountered-state-in-variables-nc (implies (and (bind-free '((addr . addr)) (addr)) @@ -5557,7 +6573,33 @@ (equal (combine-bytes (nc x86 (x86-run (gc-clk-otherwise-in) x86))) (loghead 32 (+ 1 (combine-bytes (nc x86 x86)))))) :hints (("Goal" :in-theory (e/d* (programmer-level-mode-permissions-dont-matter) - (force (force))) + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0) + force (force))) :use ((:instance effects-other-char-encountered-state-in) (:instance loop-preconditions-fwd-chaining-essentials))))) @@ -5571,7 +6613,35 @@ (not (equal (combine-bytes (word-state x86 x86)) *out*))) (equal (nc (x86-run (gc-clk-otherwise-in) x86) xxx) (nc x86 xxx))) - :hints (("Goal" :use ((:instance effects-other-char-encountered-state-in-rbp-projection))))) + :hints (("Goal" + :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0))) + :use ((:instance effects-other-char-encountered-state-in-rbp-projection))))) (defthmd effects-other-char-encountered-state-in-variables-nw (implies (and (bind-free '((addr . addr)) (addr)) @@ -5583,8 +6653,36 @@ (not (equal (combine-bytes (word-state x86 x86)) *out*))) (equal (nw x86 (x86-run (gc-clk-otherwise-in) x86)) (nw x86 x86))) - :hints (("Goal" :use ((:instance effects-other-char-encountered-state-in) - (:instance loop-preconditions-fwd-chaining-essentials))))) + :hints (("Goal" + :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0))) + :use ((:instance effects-other-char-encountered-state-in) + (:instance loop-preconditions-fwd-chaining-essentials))))) (defthmd effects-other-char-encountered-state-in-variables-nw-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -5608,8 +6706,36 @@ (not (equal (combine-bytes (word-state x86 x86)) *out*))) (equal (nl x86 (x86-run (gc-clk-otherwise-in) x86)) (nl x86 x86))) - :hints (("Goal" :use ((:instance effects-other-char-encountered-state-in) - (:instance loop-preconditions-fwd-chaining-essentials))))) + :hints (("Goal" + :in-theory (e/d* () + (append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix + (:definition acl2::take-redefinition) + (:definition nth) + (:type-prescription file-descriptor-fieldp-implies-natp-offset) + (:rewrite acl2::take-of-too-many) + (:rewrite acl2::car-nthcdr) + (:type-prescription consp-append) + (:type-prescription xw) + (:type-prescription nthcdr-true-listp) + (:definition binary-append) + (:rewrite acl2::take-of-len-free) + (:rewrite acl2::take-when-atom) + (:type-prescription file-descriptor-fieldp) + (:rewrite effects-other-char-encountered-state-out) + (:rewrite acl2::consp-when-member-equal-of-atom-listp) + (:rewrite default-+-2) + (:rewrite acl2::zp-when-gt-0))) + :use ((:instance effects-other-char-encountered-state-in) + (:instance loop-preconditions-fwd-chaining-essentials))))) (defthmd effects-other-char-encountered-state-in-variables-nl-in-terms-of-next-x86 (implies (and (bind-free '((addr . addr)) (addr)) @@ -5633,313 +6759,313 @@ ;;********************************************************************** (encapsulate - () + () - (local (include-book "std/lists/nthcdr" :dir :system)) + (local (include-book "std/lists/nthcdr" :dir :system)) - (defun loop-effects-hint (word-state offset str-bytes x86) - (declare (xargs :stobjs (x86) - :measure (len (nthcdr offset str-bytes)) - :verify-guards nil)) + (defun loop-effects-hint (word-state offset str-bytes x86) + (declare (xargs :stobjs (x86) + :measure (len (nthcdr offset str-bytes)) + :verify-guards nil)) - (if (and (eof-terminatedp str-bytes) - (< offset (len str-bytes)) - (natp offset)) - - (let ((char (get-char offset str-bytes))) + (if (and (eof-terminatedp str-bytes) + (< offset (len str-bytes)) + (natp offset)) - (if (equal char #.*eof*) + (let ((char (get-char offset str-bytes))) - (let ((x86 (x86-run (gc-clk-eof) x86))) - x86) + (if (equal char #.*eof*) - (b* (((mv word-state x86) - (case char - (#.*newline* - (b* ((x86 (x86-run (gc-clk-newline) x86))) - (mv 0 x86))) - (#.*space* - (b* ((x86 (x86-run (gc-clk-space) x86))) - (mv 0 x86))) - (#.*tab* - (b* ((x86 (x86-run (gc-clk-tab) x86))) - (mv 0 x86))) - (t - (if (equal word-state #.*out*) - (b* ((x86 (x86-run (gc-clk-otherwise-out) x86))) - (mv 1 x86)) - (b* ((x86 (x86-run (gc-clk-otherwise-in) x86))) - (mv word-state x86))))))) + (let ((x86 (x86-run (gc-clk-eof) x86))) + x86) - (loop-effects-hint word-state (1+ offset) str-bytes x86)))) - - x86)) - - ) ;; End of encapsulate + (b* (((mv word-state x86) + (case char + (#.*newline* + (b* ((x86 (x86-run (gc-clk-newline) x86))) + (mv 0 x86))) + (#.*space* + (b* ((x86 (x86-run (gc-clk-space) x86))) + (mv 0 x86))) + (#.*tab* + (b* ((x86 (x86-run (gc-clk-tab) x86))) + (mv 0 x86))) + (t + (if (equal word-state #.*out*) + (b* ((x86 (x86-run (gc-clk-otherwise-out) x86))) + (mv 1 x86)) + (b* ((x86 (x86-run (gc-clk-otherwise-in) x86))) + (mv word-state x86))))))) + + (loop-effects-hint word-state (1+ offset) str-bytes x86)))) + + x86)) + + ) ;; End of encapsulate (encapsulate - () - - (local (include-book "std/lists/nthcdr" :dir :system)) - - (local (include-book "std/lists/take" :dir :system)) - - (local (include-book "std/lists/last" :dir :system)) - - (local (in-theory (e/d* (acl2::take-of-1 acl2::take-of-zero take nthcdr) ()))) - - (local - (defthm |Subgoal *1/4.5| - (IMPLIES (AND (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 10) - (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) - STR-BYTES - (X86-RUN (GC-CLK-NEWLINE) X86)) - (X86-RUN (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES) - (X86-RUN (GC-CLK-NEWLINE) X86)))) - (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) - STR-BYTES - (X86-RUN (GC-CLK-NEWLINE) X86)) - (X86-RUN (BINARY-CLK+ (GC-CLK-NEWLINE) - (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES)) - X86))) - :hints (("Goal" :in-theory (e/d* (GC-CLK-NEWLINE - (GC-CLK-NEWLINE) - GC-CLK-NO-EOF - (GC-CLK-NO-EOF) - GC-CLK - (GC-CLK))))))) - - (local - (defthm |Subgoal *1/4.4| - (IMPLIES (AND (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 35)) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 10)) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 32)) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 9)) - (NOT (EQUAL WORD-STATE 0)) - (EQUAL (LOOP-EFFECTS-HINT WORD-STATE (+ 1 OFFSET) - STR-BYTES - (X86-RUN (GC-CLK-OTHERWISE-IN) X86)) - (X86-RUN (LOOP-CLK WORD-STATE (+ 1 OFFSET) - STR-BYTES) - (X86-RUN (GC-CLK-OTHERWISE-IN) X86)))) - (EQUAL (LOOP-EFFECTS-HINT WORD-STATE (+ 1 OFFSET) - STR-BYTES - (X86-RUN (GC-CLK-OTHERWISE-IN) X86)) - (X86-RUN (BINARY-CLK+ (GC-CLK-OTHERWISE-IN) - (LOOP-CLK WORD-STATE (+ 1 OFFSET) - STR-BYTES)) - X86))) - :hints (("Goal" :in-theory (e/d* (GC-CLK-OTHERWISE-IN - (GC-CLK-OTHERWISE-IN) - GC-CLK-NO-EOF - (GC-CLK-NO-EOF) - GC-CLK - (GC-CLK))))))) - - (local - (defthm |Subgoal *1/4.3'| - (IMPLIES (AND (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 35)) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 10)) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 32)) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 9)) - (EQUAL (LOOP-EFFECTS-HINT 1 (+ 1 OFFSET) - STR-BYTES - (X86-RUN (GC-CLK-OTHERWISE-OUT) X86)) - (X86-RUN (LOOP-CLK 1 (+ 1 OFFSET) STR-BYTES) - (X86-RUN (GC-CLK-OTHERWISE-OUT) X86)))) - (EQUAL (LOOP-EFFECTS-HINT 1 (+ 1 OFFSET) - STR-BYTES - (X86-RUN (GC-CLK-OTHERWISE-OUT) X86)) - (X86-RUN (BINARY-CLK+ (GC-CLK-OTHERWISE-OUT) - (LOOP-CLK 1 (+ 1 OFFSET) STR-BYTES)) - X86))) - :hints (("Goal" :in-theory (e/d* (GC-CLK-OTHERWISE-OUT - (GC-CLK-OTHERWISE-OUT) - GC-CLK-NO-EOF - (GC-CLK-NO-EOF) - GC-CLK - (GC-CLK))))))) - - (local - (defthm |Subgoal *1/4.2| - (IMPLIES (AND (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 9) - (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) - STR-BYTES (X86-RUN (GC-CLK-TAB) X86)) - (X86-RUN (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES) - (X86-RUN (GC-CLK-TAB) X86)))) - (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) - STR-BYTES (X86-RUN (GC-CLK-TAB) X86)) - (X86-RUN (BINARY-CLK+ (GC-CLK-TAB) - (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES)) - X86))) - :hints (("Goal" :in-theory (e/d* (GC-CLK-TAB - (GC-CLK-TAB) - GC-CLK-NO-EOF - (GC-CLK-NO-EOF) - GC-CLK - (GC-CLK))))))) - - (local - (defthm |Subgoal *1/4''| - (IMPLIES - (AND (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 32) - (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) - STR-BYTES (X86-RUN (GC-CLK-SPACE) X86)) - (X86-RUN (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES) - (X86-RUN (GC-CLK-SPACE) X86)))) - (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) - STR-BYTES (X86-RUN (GC-CLK-SPACE) X86)) - (X86-RUN (BINARY-CLK+ (GC-CLK-SPACE) - (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES)) - X86))) - :hints (("Goal" :in-theory (e/d* (GC-CLK-SPACE - (GC-CLK-SPACE) - GC-CLK-NO-EOF - (GC-CLK-NO-EOF) - GC-CLK - (GC-CLK))))))) - - (local - (defthm |Subgoal *1/2.5''| - (IMPLIES - (AND - (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) - (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 35)) - (<= (LEN STR-BYTES) (LEN STR-BYTES)) - (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) - 35)) - (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) - 10)) - (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + () + + (local (include-book "std/lists/nthcdr" :dir :system)) + + (local (include-book "std/lists/take" :dir :system)) + + (local (include-book "std/lists/last" :dir :system)) + + (local (in-theory (e/d* (acl2::take-of-1 acl2::take-of-zero take nthcdr) ()))) + + (local + (defthm |Subgoal *1/4.5| + (IMPLIES (AND (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 10) + (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) + STR-BYTES + (X86-RUN (GC-CLK-NEWLINE) X86)) + (X86-RUN (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES) + (X86-RUN (GC-CLK-NEWLINE) X86)))) + (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) + STR-BYTES + (X86-RUN (GC-CLK-NEWLINE) X86)) + (X86-RUN (BINARY-CLK+ (GC-CLK-NEWLINE) + (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES)) + X86))) + :hints (("Goal" :in-theory (e/d* (GC-CLK-NEWLINE + (GC-CLK-NEWLINE) + GC-CLK-NO-EOF + (GC-CLK-NO-EOF) + GC-CLK + (GC-CLK))))))) + + (local + (defthm |Subgoal *1/4.4| + (IMPLIES (AND (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 35)) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 10)) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 32)) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 9)) + (NOT (EQUAL WORD-STATE 0)) + (EQUAL (LOOP-EFFECTS-HINT WORD-STATE (+ 1 OFFSET) + STR-BYTES + (X86-RUN (GC-CLK-OTHERWISE-IN) X86)) + (X86-RUN (LOOP-CLK WORD-STATE (+ 1 OFFSET) + STR-BYTES) + (X86-RUN (GC-CLK-OTHERWISE-IN) X86)))) + (EQUAL (LOOP-EFFECTS-HINT WORD-STATE (+ 1 OFFSET) + STR-BYTES + (X86-RUN (GC-CLK-OTHERWISE-IN) X86)) + (X86-RUN (BINARY-CLK+ (GC-CLK-OTHERWISE-IN) + (LOOP-CLK WORD-STATE (+ 1 OFFSET) + STR-BYTES)) + X86))) + :hints (("Goal" :in-theory (e/d* (GC-CLK-OTHERWISE-IN + (GC-CLK-OTHERWISE-IN) + GC-CLK-NO-EOF + (GC-CLK-NO-EOF) + GC-CLK + (GC-CLK))))))) + + (local + (defthm |Subgoal *1/4.3'| + (IMPLIES (AND (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 35)) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 10)) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 32)) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 9)) + (EQUAL (LOOP-EFFECTS-HINT 1 (+ 1 OFFSET) + STR-BYTES + (X86-RUN (GC-CLK-OTHERWISE-OUT) X86)) + (X86-RUN (LOOP-CLK 1 (+ 1 OFFSET) STR-BYTES) + (X86-RUN (GC-CLK-OTHERWISE-OUT) X86)))) + (EQUAL (LOOP-EFFECTS-HINT 1 (+ 1 OFFSET) + STR-BYTES + (X86-RUN (GC-CLK-OTHERWISE-OUT) X86)) + (X86-RUN (BINARY-CLK+ (GC-CLK-OTHERWISE-OUT) + (LOOP-CLK 1 (+ 1 OFFSET) STR-BYTES)) + X86))) + :hints (("Goal" :in-theory (e/d* (GC-CLK-OTHERWISE-OUT + (GC-CLK-OTHERWISE-OUT) + GC-CLK-NO-EOF + (GC-CLK-NO-EOF) + GC-CLK + (GC-CLK))))))) + + (local + (defthm |Subgoal *1/4.2| + (IMPLIES (AND (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 9) + (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) + STR-BYTES (X86-RUN (GC-CLK-TAB) X86)) + (X86-RUN (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES) + (X86-RUN (GC-CLK-TAB) X86)))) + (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) + STR-BYTES (X86-RUN (GC-CLK-TAB) X86)) + (X86-RUN (BINARY-CLK+ (GC-CLK-TAB) + (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES)) + X86))) + :hints (("Goal" :in-theory (e/d* (GC-CLK-TAB + (GC-CLK-TAB) + GC-CLK-NO-EOF + (GC-CLK-NO-EOF) + GC-CLK + (GC-CLK))))))) + + (local + (defthm |Subgoal *1/4''| + (IMPLIES + (AND (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 32) + (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) + STR-BYTES (X86-RUN (GC-CLK-SPACE) X86)) + (X86-RUN (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES) + (X86-RUN (GC-CLK-SPACE) X86)))) + (EQUAL (LOOP-EFFECTS-HINT 0 (+ 1 OFFSET) + STR-BYTES (X86-RUN (GC-CLK-SPACE) X86)) + (X86-RUN (BINARY-CLK+ (GC-CLK-SPACE) + (LOOP-CLK 0 (+ 1 OFFSET) STR-BYTES)) + X86))) + :hints (("Goal" :in-theory (e/d* (GC-CLK-SPACE + (GC-CLK-SPACE) + GC-CLK-NO-EOF + (GC-CLK-NO-EOF) + GC-CLK + (GC-CLK))))))) + + (local + (defthm |Subgoal *1/2.5''| + (IMPLIES + (AND + (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) + (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 35)) + (<= (LEN STR-BYTES) (LEN STR-BYTES)) + (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + 35)) + (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + 10)) + (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + 32)) + (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + 9))) + (EQUAL (X86-RUN (GC-CLK-OTHERWISE-OUT) X86) + (X86-RUN (BINARY-CLK+ (GC-CLK-OTHERWISE-OUT) 0) + X86))) + :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) + ()))))) + + + (local + (defthm |Subgoal *1/2.4''| + (IMPLIES + (AND + (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) + (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 35)) + (<= (LEN STR-BYTES) (LEN STR-BYTES)) + (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + 35)) + (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + 10)) + (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + 32)) + (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + 9)) + (NOT (EQUAL WORD-STATE 0))) + (EQUAL (X86-RUN (GC-CLK-OTHERWISE-IN) X86) + (X86-RUN (BINARY-CLK+ (GC-CLK-OTHERWISE-IN) 0) + X86))) + :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) + ()))))) + + (local + (defthm |Subgoal *1/2.3''| + (IMPLIES + (AND (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) + (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 35)) + (<= (LEN STR-BYTES) (LEN STR-BYTES)) + (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) 32)) - (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) - 9))) - (EQUAL (X86-RUN (GC-CLK-OTHERWISE-OUT) X86) - (X86-RUN (BINARY-CLK+ (GC-CLK-OTHERWISE-OUT) 0) - X86))) - :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) - ()))))) - - - (local - (defthm |Subgoal *1/2.4''| - (IMPLIES - (AND - (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) - (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 35)) - (<= (LEN STR-BYTES) (LEN STR-BYTES)) - (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) - 35)) - (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + (EQUAL (X86-RUN (GC-CLK-SPACE) X86) + (X86-RUN (BINARY-CLK+ (GC-CLK-SPACE) 0) + X86))) + :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) + ()))))) + + (local + (defthm |Subgoal *1/2.2''| + (IMPLIES + (AND (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) + (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 35)) + (<= (LEN STR-BYTES) (LEN STR-BYTES)) + (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) 10)) - (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) - 32)) - (NOT (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) + (EQUAL (X86-RUN (GC-CLK-NEWLINE) X86) + (X86-RUN (BINARY-CLK+ (GC-CLK-NEWLINE) 0) + X86))) + :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) + ()))))) + + (local + (defthm |Subgoal *1/2.1''| + (IMPLIES + (AND (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) + (EOF-TERMINATEDP STR-BYTES) + (< OFFSET (LEN STR-BYTES)) + (NATP OFFSET) + (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) + 35)) + (<= (LEN STR-BYTES) (LEN STR-BYTES)) + (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) 9)) - (NOT (EQUAL WORD-STATE 0))) - (EQUAL (X86-RUN (GC-CLK-OTHERWISE-IN) X86) - (X86-RUN (BINARY-CLK+ (GC-CLK-OTHERWISE-IN) 0) - X86))) - :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) - ()))))) - - (local - (defthm |Subgoal *1/2.3''| - (IMPLIES - (AND (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) - (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 35)) - (<= (LEN STR-BYTES) (LEN STR-BYTES)) - (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) - 32)) - (EQUAL (X86-RUN (GC-CLK-SPACE) X86) - (X86-RUN (BINARY-CLK+ (GC-CLK-SPACE) 0) - X86))) - :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) - ()))))) - - (local - (defthm |Subgoal *1/2.2''| - (IMPLIES - (AND (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) - (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 35)) - (<= (LEN STR-BYTES) (LEN STR-BYTES)) - (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) - 10)) - (EQUAL (X86-RUN (GC-CLK-NEWLINE) X86) - (X86-RUN (BINARY-CLK+ (GC-CLK-NEWLINE) 0) - X86))) - :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) - ()))))) - - (local - (defthm |Subgoal *1/2.1''| - (IMPLIES - (AND (EQUAL (LEN STR-BYTES) (+ 1 OFFSET)) - (EOF-TERMINATEDP STR-BYTES) - (< OFFSET (LEN STR-BYTES)) - (NATP OFFSET) - (NOT (EQUAL (CAR (GRAB-BYTES (LIST (NTH OFFSET STR-BYTES)))) - 35)) - (<= (LEN STR-BYTES) (LEN STR-BYTES)) - (EQUAL (CAR (GRAB-BYTES (ACL2::LIST-FIX (NTHCDR OFFSET STR-BYTES)))) - 9)) - (EQUAL (X86-RUN (GC-CLK-TAB) X86) - (X86-RUN (BINARY-CLK+ (GC-CLK-TAB) 0) - X86))) - :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) - ()))))) - - (defthm loop-effects-hint-and-loop-clk - (implies (and (eof-terminatedp str-bytes) - (< offset (len str-bytes)) - (natp offset)) - (equal (loop-effects-hint word-state offset str-bytes x86) - (x86-run (loop-clk word-state offset str-bytes) x86))) - :hints (("Goal" :in-theory (e/d* (loop-clk) ())))) - - ) ;; End of encapsulate + (EQUAL (X86-RUN (GC-CLK-TAB) X86) + (X86-RUN (BINARY-CLK+ (GC-CLK-TAB) 0) + X86))) + :hints (("Goal" :in-theory (e/d* (BINARY-CLK+) + ()))))) + + (defthm loop-effects-hint-and-loop-clk + (implies (and (eof-terminatedp str-bytes) + (< offset (len str-bytes)) + (natp offset)) + (equal (loop-effects-hint word-state offset str-bytes x86) + (x86-run (loop-clk word-state offset str-bytes) x86))) + :hints (("Goal" :in-theory (e/d* (loop-clk) ())))) + + ) ;; End of encapsulate (defthm effects-loop ;; Begins at (call GC) @@ -5975,69 +7101,69 @@ ;; Intention: (encapsulate - () + () - (local (include-book "std/lists/nthcdr" :dir :system)) + (local (include-book "std/lists/nthcdr" :dir :system)) - (defun nc-algo (offset str-bytes nc) - (declare (xargs :measure - (len (nthcdr offset str-bytes)))) + (defun nc-algo (offset str-bytes nc) + (declare (xargs :measure + (len (nthcdr offset str-bytes)))) - (if (and (eof-terminatedp str-bytes) - (< offset (len str-bytes)) - (natp offset)) + (if (and (eof-terminatedp str-bytes) + (< offset (len str-bytes)) + (natp offset)) - (b* ((c (get-char offset str-bytes)) - ((when (equal c *eof*)) nc) - (new-nc (loghead 32 (1+ nc)))) - (nc-algo (1+ offset) str-bytes new-nc)) + (b* ((c (get-char offset str-bytes)) + ((when (equal c *eof*)) nc) + (new-nc (loghead 32 (1+ nc)))) + (nc-algo (1+ offset) str-bytes new-nc)) - nc)) + nc)) - (defun nl-algo (offset str-bytes nl) - (declare (xargs :measure - (len (nthcdr offset str-bytes)))) + (defun nl-algo (offset str-bytes nl) + (declare (xargs :measure + (len (nthcdr offset str-bytes)))) - (if (and (eof-terminatedp str-bytes) - (< offset (len str-bytes)) - (natp offset)) + (if (and (eof-terminatedp str-bytes) + (< offset (len str-bytes)) + (natp offset)) - (b* ((c (get-char offset str-bytes)) - ((when (equal c *eof*)) nl) - (new-nl (if (equal c *newline*) - (loghead 32 (1+ nl)) - nl))) - (nl-algo (1+ offset) str-bytes new-nl)) + (b* ((c (get-char offset str-bytes)) + ((when (equal c *eof*)) nl) + (new-nl (if (equal c *newline*) + (loghead 32 (1+ nl)) + nl))) + (nl-algo (1+ offset) str-bytes new-nl)) - nl)) + nl)) - (defun nw-algo (offset str-bytes word-state nw) - (declare (xargs :measure - (len (nthcdr offset str-bytes)))) + (defun nw-algo (offset str-bytes word-state nw) + (declare (xargs :measure + (len (nthcdr offset str-bytes)))) - (if (and (eof-terminatedp str-bytes) - (< offset (len str-bytes)) - (natp offset)) + (if (and (eof-terminatedp str-bytes) + (< offset (len str-bytes)) + (natp offset)) - (b* ((c (get-char offset str-bytes)) - ((when (equal c *eof*)) nw) + (b* ((c (get-char offset str-bytes)) + ((when (equal c *eof*)) nw) - ((mv new-nw new-word-state) - (if (equal c *newline*) - (mv nw *out*) - (if (equal c *space*) - (mv nw *out*) - (if (equal c *tab*) - (mv nw *out*) - (if (equal word-state *out*) - (mv (loghead 32 (1+ nw)) *in*) - (mv nw word-state))))))) + ((mv new-nw new-word-state) + (if (equal c *newline*) + (mv nw *out*) + (if (equal c *space*) + (mv nw *out*) + (if (equal c *tab*) + (mv nw *out*) + (if (equal word-state *out*) + (mv (loghead 32 (1+ nw)) *in*) + (mv nw word-state))))))) - (nw-algo (1+ offset) str-bytes new-word-state new-nw)) + (nw-algo (1+ offset) str-bytes new-word-state new-nw)) - nw)) + nw)) - ) ;; End of encapsulate + ) ;; End of encapsulate (deftheory effects-loop-rules @@ -6850,7 +7976,6 @@ (defthm not-member-p-canonical-address-listp-when-disjoint-p-new - ;; [Shilpi]: generalize... (implies (and (disjoint-p xs (create-canonical-address-list m addr)) (member-p e (create-canonical-address-list m addr))) (equal (member-p e xs) @@ -6949,6 +8074,16 @@ :hints (("Goal" :do-not-induct t :in-theory (e/d* () (wb-remove-duplicate-writes + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix force (force)))))) (defthmd memory-analysis-effects-other-char-encountered-state-in @@ -6972,6 +8107,16 @@ :hints (("Goal" :do-not-induct t :in-theory (e/d* () (wb-remove-duplicate-writes + append-and-create-addr-bytes-alist + cons-and-create-addr-bytes-alist + append-and-addr-byte-alistp + negative-logand-to-positive-logand-with-integerp-x + las-to-pas-values-and-!flgi + las-to-pas + get-prefixes-opener-lemma-group-1-prefix + get-prefixes-opener-lemma-group-2-prefix + get-prefixes-opener-lemma-group-3-prefix + get-prefixes-opener-lemma-group-4-prefix force (force)))))) (defthmd memory-analysis-loop From 9c6e3f501662e2394ec1234079d0828f3b3e781e Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Fri, 22 Jul 2016 08:47:28 -0500 Subject: [PATCH 08/70] Fixed typo in :doc fast-alists-free-on-exit; modified lambda-subtermp and lambda-subtermp-lst to be guard-verifiable; tweaked :doc system-utilities. Thanks to Eric Smith for suggesting the modifications to lambda-subtermp and lambda-subtermp-lst. In system-utilities, documented all-calls and expanded documentation for subst-expr. Thanks to Alessandro Coglio for an email leading us to make these modifications. --- books/centaur/misc/hons-extra.lisp | 2 +- books/system/doc/acl2-doc.lisp | 13 ++++++++++++- doc.lisp | 12 +++++++++++- simplify.lisp | 4 +++- 4 files changed, 27 insertions(+), 4 deletions(-) diff --git a/books/centaur/misc/hons-extra.lisp b/books/centaur/misc/hons-extra.lisp index 93314702187..aab20f4aaa1 100644 --- a/books/centaur/misc/hons-extra.lisp +++ b/books/centaur/misc/hons-extra.lisp @@ -227,7 +227,7 @@ (defxdoc fast-alists-free-on-exit :parents (fast-alists) - :short "Concisely call ~ilc[fast-alist-free-on-exit] for several alists." + :short "Concisely call @(tsee fast-alist-free-on-exit) for several alists." :long "

For example:

@({ diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index 1e62db0d87d..a94cad2e17d 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -97803,6 +97803,13 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

") (list (car pair) (cdr pair))))) }) +
  • @('(all-calls names term alist ans)'): Accumulate into @('ans') + (which typically is @('nil') at the top level) all pseudo-terms @('u/alist') + such that for some @('f') in the list, @('names'), @('u') is a subterm of the + pseudo-term, @('term'), that is a call of the symbol, @('f'). Note that + @('(all-calls-lst names lst alist ans)') is similar, except for a list, + @('list'), of terms in place of a single term, @('term').
    • +
  • @('(all-vars x)'): For a @(tsee pseudo-termp) @('x'), return the list of variables in @('x') in reverse print order of first occurrence. For example, @('all-vars') of @(''(f (g a b) c)') is @(''(c b a)').
    • @@ -98032,7 +98039,11 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

    ") @('form').
  • @('(subst-expr new old term)'): Substitute @('new') for @('old') in - @('term'); all are assumed to be @(see term)s.
    • + @('term'); all are assumed to be @(see term)s. This function provides a + slightly optimized version of equivalent function @('(subst-expr new old + term)'). Also, the former causes an explicit error if @('old') is a quoted + constant, and neither will search strictly inside a quoted subterm of + @('old').
  • @('(subst-var new old term)'): Substitute @('new') for @('old') in @('term'); all are assumed to be @(see term)s, but moreover, @('old') is diff --git a/doc.lisp b/doc.lisp index cd51b0cfa62..a65f3033a38 100644 --- a/doc.lisp +++ b/doc.lisp @@ -98904,6 +98904,12 @@ List of a few ACL2 system utilities: (let ((pair (nth i alist))) (list (car pair) (cdr pair))))) + * (all-calls names term alist ans): Accumulate into ans (which + typically is nil at the top level) all pseudo-terms u/alist + such that for some f in the list, names, u is a subterm of the + pseudo-term, term, that is a call of the symbol, f. Note that + (all-calls-lst names lst alist ans) is similar, except for a + list, list, of terms in place of a single term, term. * (all-vars x): For a [pseudo-termp] x, return the list of variables in x in reverse print order of first occurrence. For example, all-vars of '(f (g a b) c) is '(c b a). @@ -99074,7 +99080,11 @@ List of a few ACL2 system utilities: elements\".) * (sublis-var alist form): Substitute alist into the [term], form. * (subst-expr new old term): Substitute new for old in term; all are - assumed to be [term]s. + assumed to be [term]s. This function provides a slightly + optimized version of equivalent function (subst-expr new old + term). Also, the former causes an explicit error if old is a + quoted constant, and neither will search strictly inside a + quoted subterm of old. * (subst-var new old term): Substitute new for old in term; all are assumed to be [term]s, but moreover, old is assumed to be a variable. diff --git a/simplify.lisp b/simplify.lisp index 324a1cee5f9..8aa503cba8b 100644 --- a/simplify.lisp +++ b/simplify.lisp @@ -4637,6 +4637,7 @@ ; We determine whether some lambda-expression is used as a function in term. + (declare (xargs :guard (pseudo-termp term))) (if (or (variablep term) (fquotep term)) nil @@ -4644,7 +4645,8 @@ (lambda-subtermp-lst (fargs term))))) (defun lambda-subtermp-lst (termlist) - (if termlist + (declare (xargs :guard (pseudo-term-listp termlist))) + (if (consp termlist) (or (lambda-subtermp (car termlist)) (lambda-subtermp-lst (cdr termlist))) nil)) From 5a9c288a4fde18401d0171ae1189baff2dcde5f8 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Fri, 22 Jul 2016 12:18:03 -0700 Subject: [PATCH 09/70] Improve implementation of install-not-norm-event. Use INSTALL-NOT-NORMALIZED-NAME from [books]/misc/install-not-normalized.lisp instead of replicating its code. --- books/kestrel/system/install-not-norm-event.lisp | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/books/kestrel/system/install-not-norm-event.lisp b/books/kestrel/system/install-not-norm-event.lisp index 57c6677d31a..00cee73ae6e 100644 --- a/books/kestrel/system/install-not-norm-event.lisp +++ b/books/kestrel/system/install-not-norm-event.lisp @@ -37,9 +37,7 @@ also return the name @('fn$not-normalized') of the theorem that installs the non-normalized definition.

    " - (b* ((fn$not-normalized (intern-in-package-of-symbol - (symbol-name (packn (list fn '$not-normalized))) - fn)) + (b* ((fn$not-normalized (install-not-normalized-name fn)) (event-form (if local `(local (install-not-normalized ,fn)) `(install-not-normalized ,fn)))) From 3bfb7ff1749410ea730ac03fbe46c0458f01039e Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Fri, 22 Jul 2016 12:25:04 -0700 Subject: [PATCH 10/70] Improve fresh name utilities. Use ADD-SUFFIX instead of PACKN, so the fresh names are not always put into the ACL2 package. --- books/kestrel/system/fresh-names-tests.lisp | 8 ++++---- books/kestrel/system/fresh-names.lisp | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/books/kestrel/system/fresh-names-tests.lisp b/books/kestrel/system/fresh-names-tests.lisp index c5eead6d62d..873fee8288d 100644 --- a/books/kestrel/system/fresh-names-tests.lisp +++ b/books/kestrel/system/fresh-names-tests.lisp @@ -30,12 +30,12 @@ 'abcdefg$)) (assert-event - (equal (fresh-name-in-world-with-$s 'cons '(cons$ cons$$) (w state)) - 'cons$$$)) + (equal (fresh-name-in-world-with-$s 'len '(len$ len$$) (w state)) + 'len$$$)) (assert-event - (equal (fresh-name-in-world-with-$s 'cons '(cons$ cons$$$) (w state)) - 'cons$$)) + (equal (fresh-name-in-world-with-$s 'len '(len$ len$$$) (w state)) + 'len$$)) (must-succeed* (defun f (x) x) diff --git a/books/kestrel/system/fresh-names.lisp b/books/kestrel/system/fresh-names.lisp index b4bc0cb61da..d0113de338c 100644 --- a/books/kestrel/system/fresh-names.lisp +++ b/books/kestrel/system/fresh-names.lisp @@ -40,5 +40,5 @@

    " (if (or (logical-namep name wrld) (member name names-to-avoid)) - (fresh-name-in-world-with-$s (packn (list name '$)) names-to-avoid wrld) + (fresh-name-in-world-with-$s (add-suffix name "$") names-to-avoid wrld) name)) From e11909db93cb28520e27973ae6dcbe930daaa7b5 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Fri, 22 Jul 2016 16:21:11 -0700 Subject: [PATCH 11/70] Improve applicability condition utilities. Now PROVE-APPLICABILITY-CONDITION and PROVE-APPLICABILITY-CONDITIONS return a more clear result, consisting of a boolean to indicate success or failure, a message, and the state. The message is an error message in case of failure, and currently empty in case of success; but in the future it could carry information also in case of success. --- .../applicability-conditions-tests.lisp | 191 +++++++++--------- .../system/applicability-conditions.lisp | 46 +++-- 2 files changed, 126 insertions(+), 111 deletions(-) diff --git a/books/kestrel/system/applicability-conditions-tests.lisp b/books/kestrel/system/applicability-conditions-tests.lisp index 59e1466d591..36e1010ebc2 100644 --- a/books/kestrel/system/applicability-conditions-tests.lisp +++ b/books/kestrel/system/applicability-conditions-tests.lisp @@ -40,132 +40,135 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-condition (make-applicability-condition - :name 'false - :formula '(equal x y) - :hints nil) - nil ; verbose - state) - (value (msgp t/msg)))) + (b* (((mv success & state) + (prove-applicability-condition (make-applicability-condition + :name 'false + :formula '(equal x y) + :hints nil) + nil ; verbose + state))) + (value (not success)))) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-condition (make-applicability-condition - :name 'false - :formula '(equal x y) - :hints nil) - t ; verbose - state) - (value (msgp t/msg)))) + (b* (((mv success & state) + (prove-applicability-condition (make-applicability-condition + :name 'false + :formula '(equal x y) + :hints nil) + t ; verbose + state))) + (value (not success)))) (must-succeed* (defund f (x) x) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-condition (make-applicability-condition - :name 'need-hints - :formula '(equal (f x) x) - :hints nil) - nil ; verbose - state) - (value (msgp t/msg))))) + (b* (((mv success & state) + (prove-applicability-condition (make-applicability-condition + :name 'need-hints + :formula '(equal (f x) x) + :hints nil) + nil ; verbose + state))) + (value (not success))))) (must-succeed* (defund f (x) x) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-condition (make-applicability-condition - :name 'need-hints - :formula '(equal (f x) x) - :hints nil) - t ; verbose - state) - (value (msgp t/msg))))) + (b* (((mv success & state) + (prove-applicability-condition (make-applicability-condition + :name 'need-hints + :formula '(equal (f x) x) + :hints nil) + t ; verbose + state))) + (value (not success))))) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-condition (make-applicability-condition - :name 'true - :formula '(equal x x) - :hints nil) - nil ; verbose - state) - (value (eq t/msg t)))) + (b* (((mv success & state) + (prove-applicability-condition (make-applicability-condition + :name 'true + :formula '(equal x x) + :hints nil) + nil ; verbose + state))) + (value success))) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-condition (make-applicability-condition - :name 'true - :formula '(equal x x) - :hints nil) - t ; verbose - state) - (value (eq t/msg t)))) + (b* (((mv success & state) + (prove-applicability-condition (make-applicability-condition + :name 'true + :formula '(equal x x) + :hints nil) + t ; verbose + state))) + (value success))) (must-succeed* (defund f (x) x) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-condition (make-applicability-condition - :name 'true - :formula '(equal (f x) x) - :hints '(("Goal" :in-theory (enable f)))) - nil ; verbose - state) - (value (eq t/msg t))))) + (b* (((mv success & state) + (prove-applicability-condition + (make-applicability-condition + :name 'true + :formula '(equal (f x) x) + :hints '(("Goal" :in-theory (enable f)))) + nil ; verbose + state))) + (value success)))) (must-succeed* (defund f (x) x) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-condition (make-applicability-condition - :name 'true - :formula '(equal (f x) x) - :hints '(("Goal" :in-theory (enable f)))) - t ; verbose - state) - (value (eq t/msg t))))) + (b* (((mv success & state) + (prove-applicability-condition + (make-applicability-condition + :name 'true + :formula '(equal (f x) x) + :hints '(("Goal" :in-theory (enable f)))) + t ; verbose + state))) + (value success)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-conditions (list (make-applicability-condition - :name 'true - :formula '(equal x x) - :hints nil) - (make-applicability-condition - :name 'false - :formula '(equal x y) - :hints nil)) - nil ; verbose - state) - (value (msgp t/msg)))) + (b* (((mv success & state) + (prove-applicability-conditions + (list (make-applicability-condition + :name 'true + :formula '(equal x x) + :hints nil) + (make-applicability-condition + :name 'false + :formula '(equal x y) + :hints nil)) + nil ; verbose + state))) + (value (not success)))) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-conditions nil - nil ; verbose - state) - (value (eq t/msg t)))) + (b* (((mv success & state) + (prove-applicability-conditions nil + nil ; verbose + state))) + (value success))) (must-succeed* (defund f (x) x) (must-eval-to-t - (mv-let (t/msg state) - (prove-applicability-conditions (list (make-applicability-condition - :name 'true - :formula '(equal x x) - :hints nil) - (make-applicability-condition - :name 'need-hints - :formula '(equal (f x) x) - :hints '(("Goal" - :in-theory (enable f))))) - nil ; verbose - state) - (value (eq t/msg t))))) + (b* (((mv success & state) + (prove-applicability-conditions + (list (make-applicability-condition + :name 'true + :formula '(equal x x) + :hints nil) + (make-applicability-condition + :name 'need-hints + :formula '(equal (f x) x) + :hints '(("Goal" :in-theory (enable f))))) + nil ; verbose + state))) + (value success)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/system/applicability-conditions.lisp b/books/kestrel/system/applicability-conditions.lisp index bf4fcdb80bc..6f3d9729448 100644 --- a/books/kestrel/system/applicability-conditions.lisp +++ b/books/kestrel/system/applicability-conditions.lisp @@ -55,17 +55,23 @@ (define prove-applicability-condition ((app-cond applicability-condition-p) (verbose booleanp) state) - :returns (mv (t/msg (or (eq t/msg t) - (msgp t/msg))) + :returns (mv (success booleanp) + (msg msgp) state) :prepwork ((program)) :short "Try to prove the applicability condition." :long "

    - If successful, return @('t'). - If unsuccessful or if an error occurs during the proof attempt, - return a structured error message (printable with @('~@')). + Besides returning an indication of success, + return a structured message (printable with @('~@')). + When the proof fails, the message is an error message. + When the proof succeeds, currently the message is empty, + but future versions of this code could return an informative message instead. +

    +

    + If an error occurs during the proof attempt, + the proof is regarded as having failed.

    If the @('verbose') argument is @('t'), @@ -85,7 +91,8 @@ ((mv erp yes/no state) (prove$ formula :hints hints))) (cond (erp (b* (((run-when verbose) (cw "Prover error.)~%~%"))) - (mv `("Prover error ~x0 ~ + (mv nil + `("Prover error ~x0 ~ when attempting to prove ~ the applicability condition ~x1:~%~x2~|" (#\0 . ,erp) @@ -94,10 +101,11 @@ state))) (yes/no (b* (((run-when verbose) (cw "Done.)~%~%"))) - (mv t state))) + (mv t "" state))) (t (b* (((run-when verbose) (cw "Failed.)~%~%"))) - (mv `("The applicability condition ~x0 fails:~%~x1~|" + (mv nil + `("The applicability condition ~x0 fails:~%~x1~|" (#\0 . ,name) (#\1 . ,formula)) state)))))) @@ -106,29 +114,33 @@ ((app-conds applicability-condition-listp) (verbose booleanp) state) - :returns (mv (t/msg (or (eq t/msg t) - (msgp t/msg))) + :returns (mv (success booleanp) + (msg msgp) state) :prepwork ((program)) :short "Try to prove a list of applicability conditions, one after the other." :long "

    - If successful, return @('t'). - If unsuccessful or if an error occurs during a proof attempt, - return a structured error message (printable with @('~@')). + Besides returning an indication of success, + return a structured message (printable with @('~@')). + When the proof of an applicability condition fails, + the message is the error message generated by that proof attempt. + When all the proofs of the applicability conditions succeed, + currently the message is empty, + but future versions of this code could return an informative message instead.

    If the @('verbose') argument is @('t'), also print progress messages for the applicability conditions.

    " - (cond ((endp app-conds) (mv t state)) + (cond ((endp app-conds) (mv t "" state)) (t (b* ((app-cond (car app-conds)) - ((mv t/msg state) + ((mv success msg state) (prove-applicability-condition app-cond verbose state))) - (if (eq t/msg t) + (if success (prove-applicability-conditions (cdr app-conds) verbose state) - (mv t/msg state)))))) + (mv nil msg state)))))) (define applicability-condition-event ((app-cond applicability-condition-p) From 9fe1bde126070d144182fa9e673f556b49d340bf Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Fri, 22 Jul 2016 16:26:20 -0700 Subject: [PATCH 12/70] Remove system utility. ALL-FNS is just ALL-FFN-SYMBS with the accumulator initialized to NIL. Given that (something like) ALL-FNS is not already in the ACL2 source code, it does not seem worth to add it (just use ALL-FFN-SYMBS). --- books/kestrel/system/terms-tests.lisp | 15 --------------- books/kestrel/system/terms.lisp | 5 ----- 2 files changed, 20 deletions(-) diff --git a/books/kestrel/system/terms-tests.lisp b/books/kestrel/system/terms-tests.lisp index afbf02de877..0ddff5c6f12 100644 --- a/books/kestrel/system/terms-tests.lisp +++ b/books/kestrel/system/terms-tests.lisp @@ -19,21 +19,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (equal (all-fns 'x) nil)) - -(assert-event (equal (all-fns ''3) nil)) - -(assert-event (equal (all-fns '(f x)) '(f))) - -(assert-event (equal (all-fns '(f '"ab")) '(f))) - -(assert-event (equal (all-fns '(f (g a) (h '4/5))) '(h g f))) - -(assert-event (equal (all-fns '((lambda (x y) (f x y)) (g '1) (h x x))) - '(h g f))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (assert-event (not (pseudo-lambda-expr-p "abc"))) (assert-event (not (pseudo-lambda-expr-p (cons 3 6)))) diff --git a/books/kestrel/system/terms.lisp b/books/kestrel/system/terms.lisp index c3a4a41e829..e78d3794ab8 100644 --- a/books/kestrel/system/terms.lisp +++ b/books/kestrel/system/terms.lisp @@ -26,11 +26,6 @@ :parents (kestrel-system-utilities system-utilities) :short "Utilities related to @(see term)s.") -(define all-fns ((term pseudo-termp)) - ;; :returns (fns symbol-listp) - :short "Function symbols in a term." - (all-ffn-symbs term nil)) - (define pseudo-lambda-expr-p (x) :returns (yes/no booleanp) :short From 013e72529847e7a68341f3e7f7c9b0725c843022 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 22 Jul 2016 18:52:31 -0700 Subject: [PATCH 13/70] Fix name of parameter in xdoc, add defpointer for all-calls. --- books/system/doc/acl2-doc.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index a94cad2e17d..a772195119f 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -97808,7 +97808,7 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

    ") such that for some @('f') in the list, @('names'), @('u') is a subterm of the pseudo-term, @('term'), that is a call of the symbol, @('f'). Note that @('(all-calls-lst names lst alist ans)') is similar, except for a list, - @('list'), of terms in place of a single term, @('term').
    • + @('lst'), of terms in place of a single term, @('term').
  • @('(all-vars x)'): For a @(tsee pseudo-termp) @('x'), return the list of variables in @('x') in reverse print order of first occurrence. For example, @@ -114932,6 +114932,7 @@ expand function call at the current subterm, without simplifying" (defpointer add-to-set-eq add-to-set) (defpointer add-to-set-eql add-to-set) ; pre-v4-3 compatibility (defpointer add-to-set-equal add-to-set) +(defpointer all-calls system-utilities) (defpointer all-vars system-utilities) (defpointer apropos finding-documentation) (defpointer assoc-eq assoc) From 0c6a873fa03079e636b0fee66968fb505418d89c Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 22 Jul 2016 18:57:23 -0700 Subject: [PATCH 14/70] Add missing paren in xdoc. --- books/std/util/defconsts.lisp | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/books/std/util/defconsts.lisp b/books/std/util/defconsts.lisp index eb1fea8de63..5f8f53fe295 100644 --- a/books/std/util/defconsts.lisp +++ b/books/std/util/defconsts.lisp @@ -102,7 +102,7 @@ checking the primality of a large number) might best be done as @('defconsts') to avoid repeating the computation.
  • Computations that are fast but produce \"large\" results (e.g., -@('(make-list 10000)'), might best be done as @('defconst'), to avoid storing +@('(make-list 10000)')), might best be done as @('defconst'), to avoid storing this large list in the certificate.
    • ") @@ -429,5 +429,3 @@ this large list in the certificate. :rule-classes nil) (defthm f2 (equal *oops2* 'ACL2::|(DEFCONSTS (*OOPS2* ...) ...)|) :rule-classes nil))) - - From 5cb08c87e7d7958b2b28980c5083a137d0906fa9 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 22 Jul 2016 19:06:57 -0700 Subject: [PATCH 15/70] Change verify-guards-program to return an error if anything went wrong, uncomment tests and move into a separate -tests file. --- .../system/verify-guards-program-tests.lisp | 56 +++++++++++++++++ .../kestrel/system/verify-guards-program.lisp | 60 +------------------ 2 files changed, 57 insertions(+), 59 deletions(-) create mode 100644 books/kestrel/system/verify-guards-program-tests.lisp diff --git a/books/kestrel/system/verify-guards-program-tests.lisp b/books/kestrel/system/verify-guards-program-tests.lisp new file mode 100644 index 00000000000..a025c12c484 --- /dev/null +++ b/books/kestrel/system/verify-guards-program-tests.lisp @@ -0,0 +1,56 @@ +(in-package "ACL2") + +; Copyright (C) 2016, Regents of the University of Texas +; Written by Matt Kaufmann and Eric Smith +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +; Tests for verify-guards-program + +(include-book "verify-guards-program") +(include-book "../general/testing") + +(defun f1p (x) (declare (xargs :mode :program)) x) +(defun f2p (x) + (declare (xargs :mode :program)) + (if (consp x) (f2p (cdr x)) x)) +(defun f3 (x) x) +(defun f4p (x) + (declare (xargs :mode :program)) + (list (f1p x) (f2p x) (f3 x))) +(verify-guards-program f4p :print t) + +(defun f5p (x y) + (declare (xargs :mode :program)) + (if (consp x) + (f5p (cdr x) y) + (if (consp y) + (f5p x (cdr y)) + (list x y)))) +(defun f6p (x y) + (declare (xargs :mode :program)) + (list (f4p x) (f5p x y))) + +; No measure guessed: +(verify-guards-program f6p :print t) + +; Guard verification fails for f7p: +(defun f7p (x) + (declare (xargs :mode :program)) + (car (f1p x))) +(must-fail (verify-guards-program f7p :print t)) + +; Fails (tests that verify-termination doesn't do guard +; verification under skip-proofs): +(defun f8p (x) + (declare (xargs :mode :program :guard (not (acl2-numberp x)))) + (car (f1p x))) +(must-fail (verify-guards-program f8p)) + +; Succeeds +(defun f9p (x) + (declare (xargs :mode :program :guard (consp x))) + (car (f1p x))) +(verify-guards-program f9p) + +;; Fails because f0 does not exist +(must-fail (verify-guards-program f0)) diff --git a/books/kestrel/system/verify-guards-program.lisp b/books/kestrel/system/verify-guards-program.lisp index 4fbaf9cc458..56ad62901b1 100644 --- a/books/kestrel/system/verify-guards-program.lisp +++ b/books/kestrel/system/verify-guards-program.lisp @@ -67,9 +67,6 @@ ; - Have an option that just returns the forms, rather than passing them to LD. -; - Consider returning an error rather than (value :FAILED) when -; verify-guards-program fails. - ; - Perhaps remove excess skip-proofs. ; - Note that because a defttag is executed under the make-event, a command @@ -339,59 +336,4 @@ :ld-error-action :error ,@(and print-p `(:ld-pre-eval-print ,print))) (declare (ignore val)) - (value (list 'value-triple - (if erp :FAILED :SUCCESS)))))) - -; Examples: -#|| - -(logic) - -(progn - (defun f1p (x) (declare (xargs :mode :program)) x) - (defun f2p (x) - (declare (xargs :mode :program)) - (if (consp x) (f2p (cdr x)) x)) - (defun f3 (x) x) - (defun f4p (x) - (declare (xargs :mode :program)) - (list (f1p x) (f2p x) (f3 x)))) -(verify-guards-program f4p :print t)) - -; No measure guessed: -(progn - (defun f5p (x y) - (declare (xargs :mode :program)) - (if (consp x) - (f5p (cdr x) y) - (if (consp y) - (f5p x (cdr y)) - (list x y)))) - (defun f6p (x y) - (declare (xargs :mode :program)) - (list (f4p x) (f5p x y)))) -(verify-guards-program f6p :print t) - -; Guard verification fails for f7p: -(defun f7p (x) - (declare (xargs :mode :program)) - (car (f1p x))) -(verify-guards-program f7p :print t) - -; Fails (tests that verify-termination doesn't do guard -; verification under skip-proofs): -(defun f8p (x) - (declare (xargs :mode :program :guard (not (acl2-numberp x)))) - (car (f1p x))) -(verify-guards-program f8p) - -; Succeeds -(defun f9p (x) - (declare (xargs :mode :program :guard (consp x))) - (car (f1p x))) -(verify-guards-program f9p) - -; Fails -(verify-guards-program f0) - -||# + (mv erp (list 'value-triple (if erp :FAILED :SUCCESS)) state)))) From 8075e98119f59e0e0f5bbe3bebce4a0b01438db2 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 22 Jul 2016 19:20:34 -0700 Subject: [PATCH 16/70] Fix doc typo. --- books/system/doc/acl2-doc.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index a94cad2e17d..b5851e477cc 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -97820,7 +97820,7 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

    ")
  • @('(body fn normalp w)'): For a function symbol or @('lambda') expression @('fn') of @(see world) @('w'), return its body (@(see normalize)d iff @('normalp') is true). NOTE: If @('normalp') is true, then @('fn') should be - a @(':')@('tsee logic')-mode function symbol of @('w').
    • + a @(':')@(tsee logic)-mode function symbol of @('w').
  • @('(conjoin lst)'): The conjunction of the given list of terms.
    • From 2c73e2f8bb6ffd5fc497780e54eb5ab591b28c7e Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 22 Jul 2016 20:16:08 -0700 Subject: [PATCH 17/70] Add .acl2 file for verify-guards-program-tests (needed for the ttag). --- books/kestrel/system/verify-guards-program-tests.acl2 | 1 + 1 file changed, 1 insertion(+) create mode 100644 books/kestrel/system/verify-guards-program-tests.acl2 diff --git a/books/kestrel/system/verify-guards-program-tests.acl2 b/books/kestrel/system/verify-guards-program-tests.acl2 new file mode 100644 index 00000000000..481e16b0419 --- /dev/null +++ b/books/kestrel/system/verify-guards-program-tests.acl2 @@ -0,0 +1 @@ +; cert-flags: ? t :ttags :all \ No newline at end of file From bed2bb125750ce1ad2e1bfa976203f6238a60349 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 22 Jul 2016 20:54:28 -0700 Subject: [PATCH 18/70] Add all-calls to *acl2-exports-exclusions*. --- books/misc/check-acl2-exports.lisp | 1 + 1 file changed, 1 insertion(+) diff --git a/books/misc/check-acl2-exports.lisp b/books/misc/check-acl2-exports.lisp index 08ad41e10c7..49459cc7b34 100644 --- a/books/misc/check-acl2-exports.lisp +++ b/books/misc/check-acl2-exports.lisp @@ -104,6 +104,7 @@ WATERFALL ; Some of the following might be added to *acl2-exports*, but perhaps not; they ; come from defpointers to system-utilities. + ALL-CALLS BODY CONJOIN CONS-COUNT-BOUNDED From 60602e5026f1ef103f20c2578df1962117abb723 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sat, 23 Jul 2016 15:29:47 -0700 Subject: [PATCH 19/70] Simplify implementation of SOFT. Avoid storing the type of a function variable into the table of function variables. Currently, the type of a function variable is equivalent to its arity, which can be easily retrieved via the ARITY system utility; the current implementation does not explicitly need to retrieve it anyway. --- books/kestrel/soft/implementation.lisp | 20 +++----------------- 1 file changed, 3 insertions(+), 17 deletions(-) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index 5304c2de556..02817a66f3a 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -51,18 +51,10 @@ (and (eq (car stars) 'acl2::*) (*-listp (cdr stars))))) -(define funvar-typep (type) - (and (true-listp type) - (= (len type) 3) - (*-listp (first type)) - (first type) - (eq (second type) 'acl2::=>) - (eq (third type) 'acl2::*))) - -; The name and type of each function variable are stored in a table. +; The name of each function variable is stored in a table. (table function-variables nil nil :guard (and (symbolp acl2::key) ; name - (funvar-typep acl2::val))) + (null acl2::val))) ; no extra info (define funvarp (funvar (w plist-worldp)) :verify-guards nil @@ -70,12 +62,6 @@ (and (symbolp funvar) (not (null (assoc-eq funvar table)))))) -(define funvar-type (funvar (w plist-worldp)) - :guard (funvarp funvar w) - :verify-guards nil - (let ((table (table-alist 'function-variables w))) - (cdr (assoc-eq funvar table)))) - ; Function variables are mimicked by uninterpreted functions (i.e. stubs). ; The macro DEFUNVAR defines a function variable with its type. ; DEFUNVAR introduces the stub and updates the table of function variables. @@ -92,7 +78,7 @@ (raise "~x0 must be *." result))) `(progn (defstub ,funvar ,arguments => *) - (table function-variables ',funvar '(,arguments ,'acl2::=> *))))) + (table function-variables ',funvar nil)))) (defmacro defunvar (funvar arguments arrow result) `(make-event (defunvar-event ',funvar ',arguments ',arrow ',result))) From 9b3a40c1035c1272adea4c9b5543401e3e4de09f Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Sat, 23 Jul 2016 19:07:42 -0500 Subject: [PATCH 20/70] Made improvements associated with iprinting, especially new set-iprint keyword, :share; included as a technical improvement is changing the order in *acl2-files*. Quoting :doc note-7-3: The iprinting utility has a new keyword option, :share, which causes iprint indices to be re-used. See [set-iprint]. Thanks to David Rager for suggesting such an enhancement. To evaluate a form (set-iprint t :hard-bound N), ACL2 will first replace t by :reset-enable. This behavior has been expanded to apply to (set-iprint nil :hard-bound N) and (set-iprint :same :hard-bound N) as well: the first argument will be converted to :reset or :reset-enable. See [set-iprint]. This change fixes a bug in the interaction between hard-bounds and rollovers. For an example that formerly exhibited this bug, see a comment about ``hard-bounds and rollovers'' in (defxdoc note-7-3 ...) in community book books/system/doc/acl2-doc.lisp. Quoting comments in (defxdoc note-7-3 ...): ; We made some technical changes in the implementation of iprinting. For one, ; we no longer compress iprint-ar when exiting a wormhole, since that array is ; already compressed. More important, we fixed a bug in the interaction ; between hard-bounds and rollovers, as noted in the :doc below. The folowing ; caused a hard Lisp error but now works properly. ; ; (set-evisc-tuple (evisc-tuple 3 3 nil nil) :sites :all :iprint t) ; (set-iprint t :hard-bound 3) ; (set-iprint :same :hard-bound 1000) ; (quote ((a b c d) (a b c d) ; (a b c d) e)) ; (quote ((a b c d) (a b c d) ; (a b c d) e)) ; ; Hard Lisp error: ; (quote ((a b c d) (a b c d) ; (a b c d) e)) ; We changed the order of files in *acl2-files*, so that "hons-raw" comes ; immediately after "hons". We think we have seen inlining of hons-related ; functions with under-the-hood raw Lisp code in a tentative implementation of ; eviscerate-stobjs-top, while implementing the set-iprint :share keyword. --- acl2-fns.lisp | 289 +++++++++++++++------------------ acl2.lisp | 14 +- axioms.lisp | 29 +++- basis-a.lisp | 263 ++++++++++++++++++++---------- basis-b.lisp | 77 +++++---- books/system/doc/acl2-doc.lisp | 205 ++++++++++++++++++++--- history-management.lisp | 1 + hons-raw.lisp | 116 +++++++------ hons.lisp | 76 ++++++--- interface-raw.lisp | 98 +++++++++++ ld.lisp | 69 +++++--- other-events.lisp | 219 +++++++++++++++---------- 12 files changed, 952 insertions(+), 504 deletions(-) diff --git a/acl2-fns.lisp b/acl2-fns.lisp index 518df94fe66..3e6be7cc3c2 100644 --- a/acl2-fns.lisp +++ b/acl2-fns.lisp @@ -1024,6 +1024,130 @@ notation causes an error and (b) the use of ,. is not permitted." (#\. (error ",. not allowed in ACL2 backquote forms.")) (otherwise (list *comma* (read stream t nil t))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; PACKAGES +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; The following function used to be defined in axioms.lisp (with +; #-acl2-loop-only), but we need it here. + +(defun symbol-package-name (x) + +; Warning: This function assumes that x is not a bad-lisp-objectp. In +; particular, see the Invariant on Symbols in the Common Lisp Package, +; discussed in a comment in bad-lisp-objectp, which allows us to assume that if +; x resides in the "COMMON-LISP" package and does not have its +; *initial-lisp-symbol-mark* property set, then its symbol-package is the +; *main-lisp-package*. + + (cond ((get x *initial-lisp-symbol-mark*)) + ((let ((p (symbol-package x))) + (cond ((eq p *main-lisp-package*) + +; We could just return *main-lisp-package-name-raw* in this case (but do not +; skip this case, since in non-ANSI GCL, (package-name *main-lisp-package*) is +; "LISP", not "COMMON-LISP" (which is what we need here). But we go ahead and +; set *initial-lisp-symbol-mark* in order to bypass this code next time. + + (setf (get x *initial-lisp-symbol-mark*) + *main-lisp-package-name-raw*)) + (t (and p (package-name p)))))) + +; We use ERROR now because we cannot print symbols without packages +; with ACL2 functions. + + (t (error + "The symbol ~a, which has no package, was encountered~%~ + by ACL2. This is an inconsistent state of affairs, one that~%~ + may have arisen by undoing a defpkg but holding onto a symbol~%~ + in the package being flushed, contrary to warnings printed.~%~%" + x)))) + +(defvar *defpkg-virgins* nil) + +(defun maybe-make-package (name) + +; We formerly had a long comment here explaining that this definition CMU +; Common Lisp 19e. At that time, maybe-make-package was a macro with a #+cmu +; body of `(defpackage ,name (:use)). But CMU Common Lisp 21a does not have +; this problem, so we have changed maybe-make-package from a macro to a +; function, which allows its callers to be functions as well. That, in turn, +; may avoid compilation required for macro calls in some Lisps, including CCL. + + (when (not (find-package name)) + (make-package name :use nil))) + +(defun maybe-make-three-packages (name) + (maybe-make-package name) + (maybe-make-package (concatenate 'string + acl2::*global-package-prefix* + name)) + (maybe-make-package (concatenate 'string + acl2::*1*-package-prefix* + name))) + +(defmacro maybe-introduce-empty-pkg-1 (name) + +; It appears that GCL requires a user::defpackage (non-ANSI case) or +; defpackage (ANSI case; this may be the same as user::defpackage) form near +; the top of a file in order to read the corresponding compiled file. For +; example, an error occurred upon attempting to load the community books file +; books/data-structures/defalist.o after certifying the corresponding book +; using GCL, because the form (MAYBE-INTRODUCE-EMPTY-PKG-1 "U") near the top of +; the file was insufficient to allow reading a symbol in the "U" package +; occurring later in the corresponding source file. + +; On the other hand, the CL HyperSpec does not pin down the effect of +; defpackage when a package already exists. Indeed, the defpackage approach +; that we use for GCL does not work for LispWorks 6.0. + +; So, we have quite a different definition of this macro for GCL as opposed to +; the other Lisps. + + #-gcl + `(eval-when + #+cltl2 (:load-toplevel :execute :compile-toplevel) + #-cltl2 (load eval compile) ; though probably #-gcl implies #+cltl2 + (maybe-make-three-packages ,name)) + #+gcl + (let ((defp #+cltl2 'defpackage #-cltl2 'user::defpackage)) + `(progn + (,defp ,name + (:use)) + (,defp ,(concatenate 'string + acl2::*global-package-prefix* + name) + (:use)) + (,defp ,(concatenate 'string + acl2::*1*-package-prefix* + name) + (:use))))) + +(defvar *ever-known-package-alist* ; to be redefined in axioms.lisp + nil) + +(defun package-has-no-imports (name) + (let ((pkg (find-package name))) + (do-symbols (sym pkg) + (when (not (eq (symbol-package sym) pkg)) + (return-from package-has-no-imports nil)))) + t) + +(defun maybe-introduce-empty-pkg-2 (name) + (when (and (not (member name *defpkg-virgins* + :test 'equal)) + (not (assoc name *ever-known-package-alist* + :test 'equal)) + (package-has-no-imports name)) + (push name *defpkg-virgins*))) + +; The GCL proclaim mechanism puts symbols in package "ACL2-PC" into file +; acl2-proclaims.lisp. So Lisp needs to know about that package when it loads +; that file. We introduce that package in a harmless way here. Although we +; only need to do so for GCL, we do so for every Lisp, for uniformity. +(maybe-make-package "ACL2-PC") +(maybe-introduce-empty-pkg-2 "ACL2-PC") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; SUPPORT FOR ACL2 CHARACTER READER ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1117,7 +1241,7 @@ notation causes an error and (b) the use of ,. is not permitted." (acl2-read-character-string s ch))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; SUPPORT FOR #, +; SUPPORT FOR #. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *inside-sharp-dot-read* nil) @@ -1214,43 +1338,8 @@ notation causes an error and (b) the use of ,. is not permitted." ; SUPPORT FOR #@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmacro sharp-atsign-read-er (str &rest format-args) - `(progn (loop (when (null (read-char-no-hang stream nil nil t)) - (return))) - (error (concatenate 'string ,str ". See :DOC set-iprint.") - ,@format-args))) - -(defun sharp-atsign-read (stream char n) - (declare (ignore char n)) - (let (ch - bad-ch - (zero-code (char-code #\0)) - (index 0)) - (loop - (when (eql (setq ch (read-char stream t nil t)) - #\#) - (return)) - (let ((digit (- (char-code ch) zero-code))) - (cond ((or (< digit 0) - (> digit 9)) - (when (not bad-ch) - (setq bad-ch ch)) - (return)) - (t - (setq index (+ digit (* 10 index))))))) - (cond (bad-ch - (sharp-atsign-read-er - "Non-digit character ~s following #@~s" - bad-ch index)) - ((eval '(f-get-global 'certify-book-info *the-live-state*)) - (sharp-atsign-read-er - "Illegal reader macro during certify-book, #@~s#" - index)) - ((qfuncall iprint-ar-illegal-index index *the-live-state*) - (sharp-atsign-read-er - "Out-of-bounds index in #@~s#" - index)) - (t (qfuncall iprint-ar-aref1 index *the-live-state*))))) +; See interface-raw.lisp, as sharp-atsign-read uses several functions defined +; in the sources and we want to avoid compiler warnings. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; SUPPORT FOR #{""" @@ -1415,130 +1504,6 @@ notation causes an error and (b) the use of ,. is not permitted." (setf (svref *sharp-reader-array* i) nil)) (setq *sharp-reader-max-index* 0))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; PACKAGES -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; The following function used to be defined in axioms.lisp (with -; #-acl2-loop-only), but we need it here. - -(defun symbol-package-name (x) - -; Warning: This function assumes that x is not a bad-lisp-objectp. In -; particular, see the Invariant on Symbols in the Common Lisp Package, -; discussed in a comment in bad-lisp-objectp, which allows us to assume that if -; x resides in the "COMMON-LISP" package and does not have its -; *initial-lisp-symbol-mark* property set, then its symbol-package is the -; *main-lisp-package*. - - (cond ((get x *initial-lisp-symbol-mark*)) - ((let ((p (symbol-package x))) - (cond ((eq p *main-lisp-package*) - -; We could just return *main-lisp-package-name-raw* in this case (but do not -; skip this case, since in non-ANSI GCL, (package-name *main-lisp-package*) is -; "LISP", not "COMMON-LISP" (which is what we need here). But we go ahead and -; set *initial-lisp-symbol-mark* in order to bypass this code next time. - - (setf (get x *initial-lisp-symbol-mark*) - *main-lisp-package-name-raw*)) - (t (and p (package-name p)))))) - -; We use ERROR now because we cannot print symbols without packages -; with ACL2 functions. - - (t (error - "The symbol ~a, which has no package, was encountered~%~ - by ACL2. This is an inconsistent state of affairs, one that~%~ - may have arisen by undoing a defpkg but holding onto a symbol~%~ - in the package being flushed, contrary to warnings printed.~%~%" - x)))) - -(defvar *defpkg-virgins* nil) - -(defun maybe-make-package (name) - -; We formerly had a long comment here explaining that this definition CMU -; Common Lisp 19e. At that time, maybe-make-package was a macro with a #+cmu -; body of `(defpackage ,name (:use)). But CMU Common Lisp 21a does not have -; this problem, so we have changed maybe-make-package from a macro to a -; function, which allows its callers to be functions as well. That, in turn, -; may avoid compilation required for macro calls in some Lisps, including CCL. - - (when (not (find-package name)) - (make-package name :use nil))) - -(defun maybe-make-three-packages (name) - (maybe-make-package name) - (maybe-make-package (concatenate 'string - acl2::*global-package-prefix* - name)) - (maybe-make-package (concatenate 'string - acl2::*1*-package-prefix* - name))) - -(defmacro maybe-introduce-empty-pkg-1 (name) - -; It appears that GCL requires a user::defpackage (non-ANSI case) or -; defpackage (ANSI case; this may be the same as user::defpackage) form near -; the top of a file in order to read the corresponding compiled file. For -; example, an error occurred upon attempting to load the community books file -; books/data-structures/defalist.o after certifying the corresponding book -; using GCL, because the form (MAYBE-INTRODUCE-EMPTY-PKG-1 "U") near the top of -; the file was insufficient to allow reading a symbol in the "U" package -; occurring later in the corresponding source file. - -; On the other hand, the CL HyperSpec does not pin down the effect of -; defpackage when a package already exists. Indeed, the defpackage approach -; that we use for GCL does not work for LispWorks 6.0. - -; So, we have quite a different definition of this macro for GCL as opposed to -; the other Lisps. - - #-gcl - `(eval-when - #+cltl2 (:load-toplevel :execute :compile-toplevel) - #-cltl2 (load eval compile) ; though probably #-gcl implies #+cltl2 - (maybe-make-three-packages ,name)) - #+gcl - (let ((defp #+cltl2 'defpackage #-cltl2 'user::defpackage)) - `(progn - (,defp ,name - (:use)) - (,defp ,(concatenate 'string - acl2::*global-package-prefix* - name) - (:use)) - (,defp ,(concatenate 'string - acl2::*1*-package-prefix* - name) - (:use))))) - -(defvar *ever-known-package-alist* ; to be redefined in axioms.lisp - nil) - -(defun package-has-no-imports (name) - (let ((pkg (find-package name))) - (do-symbols (sym pkg) - (when (not (eq (symbol-package sym) pkg)) - (return-from package-has-no-imports nil)))) - t) - -(defun maybe-introduce-empty-pkg-2 (name) - (when (and (not (member name *defpkg-virgins* - :test 'equal)) - (not (assoc name *ever-known-package-alist* - :test 'equal)) - (package-has-no-imports name)) - (push name *defpkg-virgins*))) - -; The GCL proclaim mechanism puts symbols in package "ACL2-PC" into file -; acl2-proclaims.lisp. So Lisp needs to know about that package when it loads -; that file. We introduce that package in a harmless way here. Although we -; only need to do so for GCL, we do so for every Lisp, for uniformity. -(maybe-make-package "ACL2-PC") -(maybe-introduce-empty-pkg-2 "ACL2-PC") - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ENVIRONMENT SUPPORT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/acl2.lisp b/acl2.lisp index 6a3faa3b01a..5c9abddd572 100644 --- a/acl2.lisp +++ b/acl2.lisp @@ -960,15 +960,15 @@ #+acl2-par "multi-threading-raw" #+hons "serialize-raw" "axioms" + "hons" ; but only get special under-the-hood treatment with #+hons + #+hons "hons-raw" ; avoid possible inlining of hons fns in later sources "basis-a" ; to be included in any "toothbrush" "memoize" ; but only get special under-the-hood treatment with #+hons - "hons" ; but only get special under-the-hood treatment with #+hons "serialize" ; but only get special under-the-hood treatment with #+hons "basis-b" ; not to be included in any "toothbrush" "parallel" ; but only get special under-the-hood treatment with #+acl2-par #+acl2-par "futures-raw" #+acl2-par "parallel-raw" - #+hons "hons-raw" #+hons "memoize-raw" "translate" "type-set-a" @@ -1631,11 +1631,7 @@ which is saved just in case it's needed later.") #\. #'sharp-dot-read)) -(defun define-sharp-atsign () - (set-new-dispatch-macro-character - #\# - #\@ - #'sharp-atsign-read)) +; Define-sharp-atsign is defined in interface-raw.lisp. (defun define-sharp-bang () (set-new-dispatch-macro-character @@ -1702,7 +1698,7 @@ which is saved just in case it's needed later.") (when do-all-changes (define-sharp-dot) - (define-sharp-atsign) +; (define-sharp-atsign) ; see interface-raw.lisp (define-sharp-bang) (define-sharp-u)) @@ -1731,7 +1727,7 @@ which is saved just in case it's needed later.") (copy-readtable *acl2-readtable*)) (let ((*readtable* *acl2-readtable*)) (define-sharp-dot) - (define-sharp-atsign) +; (define-sharp-atsign) ; see interface-raw.lisp (define-sharp-bang) (define-sharp-u) (set-dispatch-macro-character diff --git a/axioms.lisp b/axioms.lisp index ada1a7e6b58..61c407c5289 100644 --- a/axioms.lisp +++ b/axioms.lisp @@ -1164,8 +1164,12 @@ #-acl2-loop-only (progn + +; The following are valid exactly when *wormhole-iprint-ar* is not nil. + (defvar *wormhole-iprint-ar* nil) (defvar *wormhole-iprint-hard-bound* nil) +(defvar *wormhole-iprint-fal* nil) (defvar *wormhole-iprint-soft-bound* nil) ) @@ -1256,6 +1260,7 @@ ((member arg1 '(iprint-ar iprint-hard-bound + iprint-fal iprint-soft-bound) :test 'eq) @@ -1265,17 +1270,21 @@ `(progn (when (null *wormhole-iprint-ar*) - (setq *wormhole-iprint-ar* - (f-get-global - 'iprint-ar - *the-live-state*)) (setq *wormhole-iprint-hard-bound* (f-get-global 'iprint-hard-bound *the-live-state*)) + (setq *wormhole-iprint-fal* + (f-get-global + 'iprint-fal + *the-live-state*)) (setq *wormhole-iprint-soft-bound* (f-get-global 'iprint-soft-bound + *the-live-state*)) + (setq *wormhole-iprint-ar* + (f-get-global + 'iprint-ar *the-live-state*))) ,@(when (eq arg1 'iprint-ar) `((let ((qarg2 (quote ,arg2))) @@ -1311,8 +1320,7 @@ *the-live-state*) (cddr *wormhole-cleanup-form*))))) (otherwise - (interface-er "Unrecognized op in push-wormhole-undo-formi,~ - ~x0." op))))) + (interface-er "Unrecognized op in push-wormhole-undo-formi,~x0." op))))) ; The following symbol is the property under which we store Common ; Lisp streams on the property lists of channels. @@ -12536,7 +12544,7 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step certify-book-finish-complete chk-absstobj-invariants get-stobj-creator - restore-iprint-ar-from-wormhole + iprint-oracle-updates ld-fix-command update-enabled-structure-array update-enabled-structure @@ -12875,6 +12883,8 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step (defun init-iprint-ar (hard-bound enabledp) +; Warning: Consider also calling init-iprint-fal when calling this function. + ; We return an iprint-ar with the given hard-bound. ; As stated in the Essay on Iprinting, we maintain the invariants that the @@ -13123,6 +13133,7 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step (inhibited-summary-types . nil) (inside-skip-proofs . nil) (iprint-ar . ,(init-iprint-ar *iprint-hard-bound-default* nil)) + (iprint-fal . nil) (iprint-hard-bound . ,*iprint-hard-bound-default*) (iprint-soft-bound . ,*iprint-soft-bound-default*) (keep-tmp-files . nil) @@ -19879,6 +19890,7 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step set-evisc-tuple-lst set-evisc-tuple-fn1 set-iprint-ar + init-iprint-fal update-iprint-fal-rec update-iprint-fal init-iprint-fal+ checkpoint-world @@ -20028,6 +20040,7 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step ; print-readably ; generalized boolean print-right-margin ; nil or non-negative integer iprint-ar + iprint-fal iprint-hard-bound iprint-soft-bound ; ld-evisc-tuple ; already mentioned above @@ -20058,7 +20071,7 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step verify-termination-on-raw-program-okp )) -; There are a variety of state global variables, 'ld-skip-proofsp among them, +; There is a variety of state global variables, 'ld-skip-proofsp among them, ; that are "bound" by LD in the sense that their values are protected by ; pushing them upon entrance to LD and popping them upon exit. These globals ; are called the "LD specials". For each LD special there are accessor and diff --git a/basis-a.lisp b/basis-a.lisp index ec4afe98d0f..9d44eaa7cf1 100644 --- a/basis-a.lisp +++ b/basis-a.lisp @@ -26,12 +26,6 @@ (in-package "ACL2") -(defmacro defn (f a &rest r) - `(defun ,f ,a (declare (xargs :guard t)) ,@r)) - -(defmacro defnd (f a &rest r) - `(defund ,f ,a (declare (xargs :guard t)) ,@r)) - ; Essay on Wormholes ; Once upon a time (Version 3.6 and earlier) the wormhole function had a @@ -701,6 +695,10 @@ ; call such i the last-index, and it is initially 0. Note that state global ; 'iprint-ar is thus always bound to an installed ACL2 array. +; When state global 'iprint-fal has a non-nil value, it is a fast-alist that +; inverts iprint-ar in the following sense: for every pair (i . v) in iprint-ar +; with 1 <= i <= last-index, (v . i) is in the value of 'iprint-fal. + ; We have to face a fundamental question: Do we use acons or aset1 as we ; encounter a new form to assign to some #@i# during those recursive ; subroutines? The latter is dangerous in case we interrupt before installing @@ -743,12 +741,13 @@ ; It is tempting to cause an error when the user submits a form containing some ; #@j# and #@k# such that j <= last-index < k. In such a case, k is from ; before the rollover and j is from after the rollover, so these couldn't have -; been stored during a prettyprint of the same form. But we avoid considering -; this restriction because the user might want to read a list of forms that -; include some prettyprinted before the last rollover and others printed after -; the last rollover. At any time, the reader is happy with #@j# for any index -; j <= last-index and also any j below the maximum index before the last -; rollover (initially 0). +; been stored during a prettyprint of the same form. By default we avoid this +; restriction, because the user might want to read a list that includes some +; forms prettyprinted before the last rollover and other forms printed after +; the last rollover. But if iprint sharing is on, then a subform that had been +; printed before rollover might include iprint indices that have since changed, +; which might be highly confusing. So we make the above restriction on indices +; when iprint sharing is on, as documented in :doc set-iprint. ; We need to be sure that the global iprint-ar is installed as an ACL2 array, in ; order to avoid slow-array-warnings. See the comment in @@ -776,33 +775,29 @@ (aref1 'sharp-atsign-ar *sharp-atsign-ar* i)) (t (make-sharp-atsign i)))) -(defun update-iprint-alist (iprint-alist val) +(defun update-iprint-alist-fal (iprint-alist iprint-fal-new iprint-fal-old val) ; We are doing iprinting. Iprint-alist is either a positive integer, ; representing the last-index but no accumulated iprint-alist, or else is a ; non-empty alist of entries (i . val_i). See the Essay on Iprinting. - (cond ((consp iprint-alist) - (let ((i (1+ (caar iprint-alist)))) - (acons i val iprint-alist))) - (t ; iprint-alist is a natp - (acons (1+ iprint-alist) val nil)))) - -#+(or acl2-loop-only (not hons)) -(defn hons-equal (x y) - (declare (xargs :mode :logic)) - ;; Has an under-the-hood implementation - (equal x y)) - -(defn hons-assoc-equal (key alist) - (declare (xargs :mode :logic)) - (cond ((atom alist) - nil) - ((and (consp (car alist)) - (hons-equal key (caar alist))) - (car alist)) - (t - (hons-assoc-equal key (cdr alist))))) + (let ((pair (and iprint-fal-old + (or (hons-get val iprint-fal-new) + (hons-get val iprint-fal-old))))) + (cond (pair + (mv (cdr pair) iprint-alist iprint-fal-new)) + ((consp iprint-alist) + (let ((index (1+ (caar iprint-alist)))) + (mv index + (acons index val iprint-alist) + (and iprint-fal-old + (hons-acons val index iprint-fal-new))))) + (t + (let ((index (1+ iprint-alist))) + (mv index + (acons index val nil) + (and iprint-fal-old + (hons-acons val index iprint-fal-new)))))))) ; We now define the most elementary eviscerator, the one that implements ; *print-level* and *print-length*. In this same pass we also arrange to @@ -812,7 +807,8 @@ (mutual-recursion -(defun eviscerate1 (x v max-v max-n alist evisc-table hiding-cars iprint-alist) +(defun eviscerate1 (x v max-v max-n alist evisc-table hiding-cars + iprint-alist iprint-fal-new iprint-fal-old) ; Iprint-alist is either a symbol, indicating that we are not doing iprinting; a ; positive integer, representing the last-index but no accumulated iprint-alist; @@ -826,26 +822,34 @@ (mv (cond ((stringp (cdr temp)) (cons *evisceration-mark* (cdr temp))) (t (cdr temp))) - iprint-alist)) + iprint-alist + iprint-fal-new)) ((atom x) (mv (cond ((eq x *evisceration-mark*) *anti-evisceration-mark*) (t x)) - iprint-alist)) + iprint-alist + iprint-fal-new)) ((= v max-v) (cond ((symbolp iprint-alist) - (mv *evisceration-hash-mark* t)) + (mv *evisceration-hash-mark* t iprint-fal-new)) (t - (let ((iprint-alist (update-iprint-alist iprint-alist x))) + (mv-let (index iprint-alist iprint-fal-new) + (update-iprint-alist-fal iprint-alist + iprint-fal-new + iprint-fal-old + x) (mv (cons *evisceration-mark* - (get-sharp-atsign (caar iprint-alist))) - iprint-alist))))) + (get-sharp-atsign index)) + iprint-alist + iprint-fal-new))))) ((member-eq (car x) hiding-cars) - (mv *evisceration-hiding-mark* iprint-alist)) + (mv *evisceration-hiding-mark* iprint-alist iprint-fal-new)) (t (eviscerate1-lst x (1+ v) 0 max-v max-n alist evisc-table - hiding-cars iprint-alist))))) + hiding-cars iprint-alist + iprint-fal-new iprint-fal-old))))) (defun eviscerate1-lst (lst v n max-v max-n alist evisc-table hiding-cars - iprint-alist) + iprint-alist iprint-fal-new iprint-fal-old) (let ((temp (or (hons-assoc-equal lst alist) (hons-assoc-equal lst evisc-table)))) (cond @@ -853,27 +857,35 @@ (mv (cond ((stringp (cdr temp)) (cons *evisceration-mark* (cdr temp))) (t (cdr temp))) - iprint-alist)) + iprint-alist + iprint-fal-new)) ((atom lst) (mv (cond ((eq lst *evisceration-mark*) *anti-evisceration-mark*) (t lst)) - iprint-alist)) + iprint-alist + iprint-fal-new)) ((= n max-n) (cond ((symbolp iprint-alist) - (mv (list *evisceration-ellipsis-mark*) t)) - (t - (let ((iprint-alist (update-iprint-alist iprint-alist lst))) - (mv (cons *evisceration-mark* - (get-sharp-atsign (caar iprint-alist))) - iprint-alist))))) - (t (mv-let (first iprint-alist) - (eviscerate1 (car lst) v max-v max-n alist evisc-table - hiding-cars iprint-alist) - (mv-let (rest iprint-alist) - (eviscerate1-lst (cdr lst) v (1+ n) - max-v max-n alist evisc-table - hiding-cars iprint-alist) - (mv (cons first rest) iprint-alist))))))) + (mv (list *evisceration-ellipsis-mark*) t iprint-fal-new)) + (t (mv-let (index iprint-alist iprint-fal-new) + (update-iprint-alist-fal iprint-alist + iprint-fal-new + iprint-fal-old + lst) + (mv (cons *evisceration-mark* + (get-sharp-atsign index)) + iprint-alist + iprint-fal-new))))) + (t (mv-let (first iprint-alist iprint-fal-new) + (eviscerate1 (car lst) v max-v max-n alist evisc-table + hiding-cars iprint-alist + iprint-fal-new iprint-fal-old) + (mv-let (rest iprint-alist iprint-fal-new) + (eviscerate1-lst (cdr lst) v (1+ n) + max-v max-n alist evisc-table + hiding-cars iprint-alist + iprint-fal-new iprint-fal-old) + (mv (cons first rest) iprint-alist iprint-fal-new))))))) ) (mutual-recursion @@ -907,7 +919,7 @@ ) (defun eviscerate (x print-level print-length alist evisc-table hiding-cars - iprint-alist) + iprint-alist iprint-fal-new iprint-fal-old) ; See also eviscerate-top, which takes iprint-ar from the state and installs a ; new iprint-ar in the state, and update-iprint-alist, which describes the role @@ -956,15 +968,17 @@ (cond ((eviscerate1p x alist evisc-table hiding-cars) (eviscerate1 x 0 -1 -1 alist evisc-table hiding-cars - iprint-alist)) - (t (mv x iprint-alist)))) + iprint-alist iprint-fal-new iprint-fal-old)) + (t (mv x iprint-alist iprint-fal-new)))) (t (eviscerate1 x 0 (or print-level -1) (or print-length -1) alist evisc-table hiding-cars - iprint-alist)))) + iprint-alist + iprint-fal-new + iprint-fal-old)))) (defun eviscerate-simple (x print-level print-length alist evisc-table hiding-cars) @@ -972,11 +986,18 @@ ; This wrapper for eviscerate avoids the need to pass back multiple values when ; the iprint-alist is nil and we don't care if evisceration has occurred. - (mv-let (result null-iprint-alist) - (eviscerate x print-level print-length alist evisc-table hiding-cars - nil) - (assert$ (symbolp null-iprint-alist) - result))) + (mv-let (result null-iprint-alist null-iprint-fal) + (eviscerate x print-level print-length alist evisc-table hiding-cars + nil nil + +; We normally pass in the current value of state global 'iprint-fal for the +; last argument, iprint-fal-old, of eviscerate. However, since iprint-alist is +; nil, we know that it's fine to pass in nil for iprint-fal-old + + nil) + (assert$ (and (booleanp null-iprint-alist) + (null null-iprint-fal)) + result))) (defun aset1-lst (name alist ar) (declare (xargs :guard (eqlable-alistp alist))) ; really nat-alistp @@ -1055,6 +1076,39 @@ acc (cons (car ar) acc)))))) +(defun init-iprint-fal (sym state) + +; Warning: Consider also calling init-iprint-ar when calling this function. + +; The initial value of state global 'iprint-fal is nil if we are not to re-use +; indices, and otherwise is the atom, :iprint-fal. We choose a keyword so that +; fast-alist-summary can print that name nicely in any package. + + (declare (xargs :guard (symbolp sym))) + (let* ((old-iprint-fal (f-get-global 'iprint-fal state)) + (old-iprint-name (if (consp old-iprint-fal) + (cdr (last old-iprint-fal)) + old-iprint-fal)) + (new-iprint-fal (cond ((null sym) nil) + ((eq sym t) + :iprint-fal) + ((eq sym :same) + old-iprint-name) + (t sym)))) + (prog2$ (and (consp old-iprint-fal) ; optimization + (fast-alist-free old-iprint-fal)) + (pprogn (f-put-global 'iprint-fal new-iprint-fal state) + (mv (cond + ((eq old-iprint-name new-iprint-fal) + nil) + (new-iprint-fal + (msg "Iprinting is enabled with sharing, with a ~ + fast-alist whose name is ~x0." + new-iprint-fal)) + (t + (msg "Iprinting is enabled without sharing."))) + state))))) + (defun rollover-iprint-ar (iprint-alist last-index state) ; We assume that iprinting is enabled. Install a new iprint-ar, whose last @@ -1126,9 +1180,27 @@ ; changing the :order from :none requires some thought. iprint-alist)))))) - (f-put-global 'iprint-ar new-iprint-ar state))) + (mv-let (msg state) + (init-iprint-fal :same state) + (declare (ignore msg)) + (f-put-global 'iprint-ar new-iprint-ar state)))) + +(defun update-iprint-fal-rec (iprint-fal-new iprint-fal-old) + (cond ((atom iprint-fal-new) iprint-fal-old) + (t (update-iprint-fal-rec (cdr iprint-fal-new) + (hons-acons (caar iprint-fal-new) + (cdar iprint-fal-new) + iprint-fal-old))))) + +(defun update-iprint-fal (iprint-fal-new state) + (cond + ((atom iprint-fal-new) state) ; optimization + (t (f-put-global 'iprint-fal + (update-iprint-fal-rec iprint-fal-new + (f-get-global 'iprint-fal state)) + state)))) -(defun update-iprint-ar (iprint-alist state) +(defun update-iprint-ar-fal (iprint-alist iprint-fal-new iprint-fal-old state) ; We assume that iprinting is enabled. Iprint-alist is known to be a consp. ; We update state global 'iprint-ar by updating iprint-ar with the pairs in @@ -1136,9 +1208,21 @@ (let ((last-index (caar iprint-alist))) (cond ((> last-index (iprint-hard-bound state)) + +; We throw away iprint-fal-new, because we only want to re-use indices below +; last-index -- re-use of larger indices could quickly leave us pointing to +; stale values when re-printing (say, using without-evisc) recently-printed +; values. + (rollover-iprint-ar iprint-alist last-index state)) (t - (f-put-global 'iprint-ar + (assert$ + (or (null iprint-fal-old) ; might have passed in nil at top level + (equal (f-get-global 'iprint-fal state) + iprint-fal-old)) + (pprogn + (update-iprint-fal iprint-fal-new state) + (f-put-global 'iprint-ar ; We know last-index <= (iprint-hard-bound state), and it is an invariant that ; this hard bound is less than the dimension of (@ iprint-ar). See the @@ -1146,10 +1230,10 @@ ; less than that dimension, hence we can update with aset1 without encountering ; out-of-bounds indices. - (aset1-lst 'iprint-ar - (acons 0 last-index iprint-alist) - (f-get-global 'iprint-ar state)) - state))))) + (aset1-lst 'iprint-ar + (acons 0 last-index iprint-alist) + (f-get-global 'iprint-ar state)) + state))))))) (defun eviscerate-top (x print-level print-length alist evisc-table hiding-cars state) @@ -1158,15 +1242,24 @@ ; in addition to returning the evisceration of x. See eviscerate and the Essay ; on Iprinting for more details. - (mv-let (result iprint-alist) - (eviscerate x print-level print-length alist evisc-table hiding-cars - (and (iprint-enabledp state) - (iprint-last-index state))) - (let ((state (cond ((eq iprint-alist t) - (f-put-global 'evisc-hitp-without-iprint t state)) - ((atom iprint-alist) state) - (t (update-iprint-ar iprint-alist state))))) - (mv result state)))) + (let ((iprint-fal-old (f-get-global 'iprint-fal state))) + (mv-let (result iprint-alist iprint-fal-new) + (eviscerate x print-level print-length alist evisc-table hiding-cars + (and (iprint-enabledp state) + (iprint-last-index state)) + nil iprint-fal-old) + (fast-alist-free-on-exit + iprint-fal-new + (let ((state + (cond + ((eq iprint-alist t) + (f-put-global 'evisc-hitp-without-iprint t state)) + ((atom iprint-alist) state) + (t (update-iprint-ar-fal iprint-alist + iprint-fal-new + iprint-fal-old + state))))) + (mv result state)))))) ; Essay on the ACL2 Prettyprinter diff --git a/basis-b.lisp b/basis-b.lisp index f32fd94962e..1c7e48c3312 100644 --- a/basis-b.lisp +++ b/basis-b.lisp @@ -658,28 +658,33 @@ (defun eviscerate-stobjs1 (estobjs-out lst print-level print-length alist evisc-table hiding-cars - iprint-alist) + iprint-alist + iprint-fal-new iprint-fal-old) (cond - ((null estobjs-out) (mv nil iprint-alist)) + ((null estobjs-out) (mv nil iprint-alist iprint-fal-new)) ((car estobjs-out) - (mv-let (rest iprint-alist) - (eviscerate-stobjs1 (cdr estobjs-out) (cdr lst) - print-level print-length - alist evisc-table hiding-cars iprint-alist) - (mv (cons (car estobjs-out) rest) - iprint-alist))) - (t (mv-let (first iprint-alist) - (eviscerate (car lst) print-level print-length - alist evisc-table hiding-cars iprint-alist) - (mv-let (rest iprint-alist) - (eviscerate-stobjs1 (cdr estobjs-out) (cdr lst) - print-level print-length alist - evisc-table hiding-cars iprint-alist) - (mv (cons first rest) iprint-alist)))))) + (mv-let (rest iprint-alist iprint-fal-new) + (eviscerate-stobjs1 (cdr estobjs-out) (cdr lst) + print-level print-length + alist evisc-table hiding-cars + iprint-alist iprint-fal-new iprint-fal-old) + (mv (cons (car estobjs-out) rest) + iprint-alist + iprint-fal-new))) + (t (mv-let (first iprint-alist iprint-fal-new) + (eviscerate (car lst) print-level print-length + alist evisc-table hiding-cars iprint-alist + iprint-fal-new iprint-fal-old) + (mv-let (rest iprint-alist iprint-fal-new) + (eviscerate-stobjs1 (cdr estobjs-out) (cdr lst) + print-level print-length alist + evisc-table hiding-cars iprint-alist + iprint-fal-new iprint-fal-old) + (mv (cons first rest) iprint-alist iprint-fal-new)))))) (defun eviscerate-stobjs (estobjs-out lst print-level print-length alist evisc-table hiding-cars - iprint-alist) + iprint-alist iprint-fal-old) ; See also eviscerate-stobjs-top, which takes iprint-ar from the state and ; installs a new iprint-ar in the state. @@ -712,7 +717,7 @@ ; eviscerate it without regard for stobjs. (eviscerate lst print-level print-length alist evisc-table hiding-cars - iprint-alist)) + iprint-alist nil iprint-fal-old)) ((null (cdr estobjs-out)) ; Lst is a single output, which is either a stobj or not depending on whether @@ -720,11 +725,12 @@ (cond ((car estobjs-out) - (mv (car estobjs-out) iprint-alist)) + (mv (car estobjs-out) iprint-alist nil)) (t (eviscerate lst print-level print-length alist evisc-table - hiding-cars iprint-alist)))) + hiding-cars iprint-alist nil iprint-fal-old)))) (t (eviscerate-stobjs1 estobjs-out lst print-level print-length - alist evisc-table hiding-cars iprint-alist)))) + alist evisc-table hiding-cars iprint-alist + nil iprint-fal-old)))) (defun eviscerate-stobjs-top (estobjs-out lst print-level print-length alist evisc-table hiding-cars @@ -732,16 +738,25 @@ ; See eviscerate-stobjs. - (mv-let (result iprint-alist) - (eviscerate-stobjs estobjs-out lst print-level print-length alist - evisc-table hiding-cars - (and (iprint-enabledp state) - (iprint-last-index state))) - (let ((state (cond ((eq iprint-alist t) - (f-put-global 'evisc-hitp-without-iprint t state)) - ((atom iprint-alist) state) - (t (update-iprint-ar iprint-alist state))))) - (mv result state)))) + (let ((iprint-fal-old (f-get-global 'iprint-fal state))) + (mv-let (result iprint-alist iprint-fal-new) + (eviscerate-stobjs estobjs-out lst print-level print-length alist + evisc-table hiding-cars + (and (iprint-enabledp state) + (iprint-last-index state)) + iprint-fal-old) + (fast-alist-free-on-exit + iprint-fal-new + (let ((state + (cond + ((eq iprint-alist t) + (f-put-global 'evisc-hitp-without-iprint t state)) + ((atom iprint-alist) state) + (t (update-iprint-ar-fal iprint-alist + iprint-fal-new + iprint-fal-old + state))))) + (mv result state)))))) ; Essay on Abbreviating Live Stobjs diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index a772195119f..636ab5be1f3 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -73589,6 +73589,28 @@ it." ; (thm t :hints (("Goal" :use (:instance (:XXX car-cons (car car)))))) +; We made some technical changes in the implementation of iprinting. For one, +; we no longer compress iprint-ar when exiting a wormhole, since that array is +; already compressed. More important, we fixed a bug in the interaction +; between hard-bounds and rollovers, as noted in the :doc below. The folowing +; caused a hard Lisp error but now works properly. +; +; (set-evisc-tuple (evisc-tuple 3 3 nil nil) :sites :all :iprint t) +; (set-iprint t :hard-bound 3) +; (set-iprint :same :hard-bound 1000) +; (quote ((a b c d) (a b c d) +; (a b c d) e)) +; (quote ((a b c d) (a b c d) +; (a b c d) e)) +; ; Hard Lisp error: +; (quote ((a b c d) (a b c d) +; (a b c d) e)) + +; We changed the order of files in *acl2-files*, so that "hons-raw" comes +; immediately after "hons". We think we have seen inlining of hons-related +; functions with under-the-hood raw Lisp code in a tentative implementation of +; eviscerate-stobjs-top, while implementing the set-iprint :share keyword. + :parents (release-notes) :short "ACL2 Version 7.3 (xx, xxxx) Notes" :long "

    NOTE! New users can ignore these release notes, because the @(see @@ -73830,6 +73852,16 @@ it." (verify-termination foo) ; formerly failed }) +

    To evaluate a form @('(set-iprint t :hard-bound N)'), ACL2 will first + replace @('t') by @(':reset-enable'). This behavior has been expanded to + apply to @('(set-iprint nil :hard-bound N)') and @('(set-iprint :same + :hard-bound N)') as well: the first argument will be converted to @(':reset') + or @(':reset-enable'). See @(see set-iprint). This change fixes a bug in the + interaction between hard-bounds and rollovers. For an example that formerly + exhibited this bug, see a comment about ``hard-bounds and rollovers'' in + @('(defxdoc note-7-3 ...)') in community book + @('books/system/doc/acl2-doc.lisp').

    +

    New Features

    New optional arguments allow the @(tsee pso) utility to restrict output to @@ -73866,6 +73898,10 @@ it." which behaves like @('~s') except that margins are ignored. Thanks to Jared Davis for requesting this feature.

    +

    The iprinting utility has a new keyword option, @(':share'), which causes + iprint indices to be re-used. See @(see set-iprint). Thanks to David Rager + for suggesting such an enhancement.

    +

    Heuristic and Efficiency Improvements

    The raw-Lisp definition of @(tsee defpkg) has been modified in a way that @@ -91253,6 +91289,48 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

    ") ACL2 !> }) +

    You might wish to know which elided expressions are equal. You may specify + keyword argument @(':share t') for that purpose to turn on ``iprint sharing'', + which causes behavior as shown below: the value printed shows the iprint index + 2 being used twice for the list @('(C D E F)').

    + + @({ + ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) + ((A B . #@2#) (A B . #@2#) . #@3#) + ACL2 !> + }) + +

    Remark (feel free to skip this paragraph). To understand more fully how + iprint sharing works, consider the following log. The Warning below is + pointing out that previous iprint indices are no longer valid; we are starting + over. The first Observation points out that iprint sharing is on, and gives + the name @(':IPRINT-FAL') to look for in @('(fast-alist-summary)') in case you + want information on the @(see fast-alist) that associates values with + corresponding iprint indices. To see the relevance of a fast-alist, note that + the two elided occurrences of the list @('(C D E F)') were originally not the + identical list in memory; to make them identical, @(tsee hons-copy) is applied + to each to get the same list in memory, which is the one associated with + iprint index 2 in a fast-alist named @(':IPRINT-FAL').

    + + @({ + ACL2 !>(set-iprint t :share t) + + ACL2 Warning [Iprint] in SET-IPRINT: Converting SET-IPRINT action + from T to :RESET-ENABLE, as required by use of keyword :SHARE or :HARD- + BOUND. See :DOC set-iprint. + + + ACL2 Observation in SET-IPRINT: Iprinting is enabled with sharing, + with a fast-alist whose name is :IPRINT-FAL. + + ACL2 Observation in SET-IPRINT: Iprinting has been reset and enabled. + ACL2 !>(set-evisc-tuple (evisc-tuple 2 2 nil nil) :sites :all) + (:TERM :LD . #@1#) + ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) + ((A B . #@2#) (A B . #@2#) . #@3#) + ACL2 !> + }) +

    The documentation above probably suffices for most users. For those who want more details, below we detail all the ways to use the @('set-iprint') utility.

    @@ -91263,21 +91341,26 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

    ") (set-iprint nil) ; disable iprinting General Form: - (set-iprint action ; t, nil, :reset, :reset-enable, or :same - :soft-bound s ; initially 1000 - :hard-bound h ; initially 10000) + (set-iprint action ; t, nil, :reset, :reset-enable, or :same + :share sym ; initially nil + :soft-bound s ; initially 1000 + :hard-bound h ; initially 10000) })

    where all arguments are optional, but ACL2 queries for @('action') if it is - omitted. We defer the explanations of @(':soft-bound') and @(':hard-bound'). - The values for @('action') are as follows:

    + omitted. All arguments are evaluated. When a keyword argument is omitted, + there is no change in the behavior that it controls. For now we defer further + explanations of the keyword arguments. The values for @('action') are as + follows.

    -

    @('t') — Enable iprinting. If keyword @(':hard-bound') is supplied, - then @('t') is converted to @(':reset-enable').

    +

    @('t') — Enable iprinting. If either keyword @(':share') or + @(':hard-bound') is supplied, then @('t') is converted to + @(':reset-enable').

    -

    @('nil') — Disable iprinting.

    +

    @('nil') — Disable iprinting. If either keyword @(':share') or + @(':hard-bound') is supplied, then @('nil') is converted to @(':reset').

    @(':reset') — Reset iprinting to its initial disabled state, so that when enabled, the first index @('i') for which `@('#@i#') is printed will be @@ -91287,32 +91370,55 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

    ")

    @(':reset-enable') — Reset iprinting as with @(':reset'), and then enable iprinting.

    -

    @(':same') — Make no change to the iprinting state (other than - setting the @(':soft-bound') and/or @(':hard-bound') if specified, as - explained below).

    +

    @(':same') — If either keyword @(':share') or @(':hard-bound') is + supplied, then @(':same') is converted to @(':reset') or @(':reset-enable') + according to whether iprinting is currently disabled or enabled, respectively. + Otherwise, make no change to the iprinting state other than setting the + @('soft-bound') if specified, as explained below.

    + + + +

    The value of @(':share') must be a symbol, with default @('nil'). If the + value is @('nil'), then an elided value will be printed using the next + available iprint index. The value @(':same') is treated as though @(':share') + had not been supplied. Otherwise, iprint sharing is on, which provides the + following behavior. Suppose that a value @('V') is to be elided that would be + assigned the next available iprint index, @('N'). If an iprint index @('I < + N') is already associated with a value equal to @('V'), then ACL2 will print + @('#@I') for @('V') instead of @('#@N'). Thus, @('N') will remain the next + available iprint index. This behavior is implementing using a @(see + fast-alist) that associates values with indices; in our example, the @(tsee + hons-copy) of @('V') is associated with @('I'). If the value of @(':share') + is @('t') then the name of this fast-alist — that is, its initial value + — is @(':iprint-fal'); otherwise, the value of @(':share') (other than + @('nil') or @(':same') is its name. This name is useful when viewing the + output of @(tsee fast-alist-summary).

    Immediately after a top-level form is read, hence before it is evaluated, a check is made for whether the latest iprint index exceeds a certain bound, @('(iprint-soft-bound state)') — 1000, by default. If so, then the - @('(iprint-last-index state)') is set back to 0. This soft bound can be - changed to any positive integer @('k') by calling @('set-iprint') with - @(':soft-bound k'), typically @('(set-iprint :same :soft-bound k'))].

    + @('(iprint-last-index state)') is set back to 0 so that the next iprint index + that is generated will be 1. This soft bound can be changed to any positive + integer @('k') by calling @('set-iprint') with @(':soft-bound k'), for + example: @('(set-iprint :same :soft-bound k'))].

    The above ``soft bound'' is applied once for each top-level form, but you may want finer control by applying a bound after the pretty-printing of each individual form (since many forms may be pretty-printed between successive evaluations of top-level forms). That bound is @('(iprint-hard-bound state)'), and can be set with the @(':hard-bound') argument in analogy to how - @(':soft-bound') is set, as described above.

    + @(':soft-bound') is set, as described above, but with the effect of resetting + iprinting, with @('(iprint-last-index state)') set back to 0.

    A ``rollover'' is the detection that the soft or hard bound has been - exceeded, along with a state update so that the next iprint index will be 1. - When a rollover occurs, any index beyond the latest iprint index is no longer - available for reading. At the top level of the ACL2 read-eval-print loop, - this works as follows: ACL2 reads the next top-level form according to the - current iprint state, then handles a rollover if the latest iprint index - exceeded the current soft bound. The following log illustrates a rollover, - which follows the description above.

    + exceeded, along with a state update setting @('(iprint-last-index state)') to + 0 so that the next iprint index will be 1. Immediately before a rollover, any + index beyond the last iprint index used (which must be from before an earlier + rollover) is no longer available for reading. At the top level of the ACL2 + read-eval-print loop, this works as follows: ACL2 reads the next top-level + form according to the current iprint state, then handles a rollover if the + latest iprint index exceeded the current soft bound. The following log + illustrates a rollover, which follows the description above.

    @({ ACL2 !>(set-iprint t :soft-bound 3) @@ -91346,7 +91452,8 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

    ") Error: Out-of-bounds index in #@5#. See :DOC set-iprint. *********************************************** - If you didn't cause an explicit interrupt (Control-C), + The message above might explain the error. If not, and + if you didn't cause an explicit interrupt (Control-C), then the root cause may be call of a :program mode function that has the wrong guard specified, or even no guard specified (i.e., an implicit guard of t). @@ -91357,6 +91464,58 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

    ") ACL2 !> }) +

    Rollover has the following additional effect when iprint sharing is on: it + is illegal to read a form that has both an index from before the rollover and + an index from after the rollover. The following log illustrates this + requirement. Note that if the last input form below were read without error, + the result would likely be highly confusing, since iprint index 1 no longer + refers to the value it was originally given at the time the other iprint + indices in the input (2, 3, and 4) were given their values.

    + + @({ + ACL2 !>(set-iprint t :soft-bound 3 :share t) + + ACL2 Warning [Iprint] in SET-IPRINT: Converting SET-IPRINT action + from T to :RESET-ENABLE, as required by use of keyword :SHARE or :HARD- + BOUND. See :DOC set-iprint. + + + ACL2 Observation in SET-IPRINT: The soft-bound for iprinting has been + set to 3. + + ACL2 Observation in SET-IPRINT: Iprinting is enabled with sharing, + with a fast-alist whose name is :IPRINT-FAL. + + ACL2 Observation in SET-IPRINT: Iprinting has been reset and enabled. + ACL2 !>(set-evisc-tuple (evisc-tuple 2 3 nil nil) :sites :ld) + (:LD) + ACL2 !>'((a b c d) (x y z w)) + ((A B C . #@1#) (X Y Z . #@2#)) + ACL2 !>'((e f g h) (k l m n)) + ((E F G . #@3#) (K L M . #@4#)) + ACL2 !>'(#@1# #@2# #@3# #@4#) ; OK, since rollover occurs after the read + ((D) (W) (H) . #@1#) + ACL2 !>'(#@1# #@2# #@3# #@4#) + + *********************************************** + ************ ABORTING from raw Lisp *********** + Error: Attempt to read a form containing both an index + created before the most recent rollover (#@2#) and + an index created after that rollover (#@1#). See :DOC set-iprint. + *********************************************** + + The message above might explain the error. If not, and + if you didn't cause an explicit interrupt (Control-C), + then the root cause may be call of a :program mode + function that has the wrong guard specified, or even no + guard specified (i.e., an implicit guard of t). + See :DOC guards. + + To enable breaks into the debugger (also see :DOC acl2-customization): + (SET-DEBUGGER-ENABLE T) + ACL2 !> + }) +

    We conclude by mentioning two cases where iprinting and evisc-tuples are ignored. (1) This is typically the case when printing results in raw Lisp outside the ACL2 loop. To use iprinting and evisc-tuples in raw Lisp, use diff --git a/history-management.lisp b/history-management.lisp index 7f914a44d1c..b94989d019e 100644 --- a/history-management.lisp +++ b/history-management.lisp @@ -3700,6 +3700,7 @@ gag-mode-evisc-tuple ;;; see just above slow-array-action ;;; see just above iprint-ar ;;; see just above + iprint-fal ;;; see just above iprint-soft-bound ;;; see just above iprint-hard-bound ;;; see just above show-custom-keyword-hint-expansion diff --git a/hons-raw.lisp b/hons-raw.lisp index 20a201681ef..4babdde36d5 100644 --- a/hons-raw.lisp +++ b/hons-raw.lisp @@ -1138,7 +1138,7 @@ (18cdrs (cddr 16cdrs))) (consp 18cdrs))))))))) -(defabbrev hl-flex-assoc (key al) +(defmacro hl-flex-assoc (key al) ; (hl-flex-assoc key al) returns the entry associated with key, or returns nil ; if key is not bound. Note that the comparisons performed by flex-assoc are @@ -1172,9 +1172,11 @@ ; NIL ; ? - (if (listp al) - (assoc key al) - (gethash key (the hash-table al)))) + `(let ((key ,key) + (al ,al)) + (if (listp al) + (assoc key al) + (gethash key (the hash-table al))))) (defmacro hl-flex-acons (elem al &optional shared) @@ -1245,7 +1247,7 @@ (= 1 (the fixnum (aref sbits (the fixnum idx))))))))) #-static-hons -(defabbrev hl-hspace-find-flex-alist-for-cdr (b ctables) +(defmacro hl-hspace-find-flex-alist-for-cdr (b ctables) ; (HL-HSPACE-FIND-FLEX-ALIST-FOR-CDR B CTABLES) --> FLEX ALIST ; @@ -1255,14 +1257,16 @@ ; though the NIL-HT starts out as a hash table, we can still regard it as a ; flex alist. - (cond ((null b) - (hl-ctables-nil-ht ctables)) - ((or (consp b) - (symbolp b) - (stringp b)) - (gethash b (hl-ctables-cdr-ht ctables))) - (t - (gethash b (hl-ctables-cdr-ht-eql ctables))))) + `(let ((b ,b) + (ctables ,ctables)) + (cond ((null b) + (hl-ctables-nil-ht ctables)) + ((or (consp b) + (symbolp b) + (stringp b)) + (gethash b (hl-ctables-cdr-ht ctables))) + (t + (gethash b (hl-ctables-cdr-ht-eql ctables)))))) (declaim (inline hl-hspace-honsp)) (defun hl-hspace-honsp (x hs) @@ -1495,7 +1499,7 @@ 'hl-with-lock-grabbed)) #+static-hons -(defabbrev hl-symbol-addr (s) +(defmacro hl-symbol-addr (s) ; (HL-SYMBOL-ADDR S) --> NAT ; @@ -1519,28 +1523,29 @@ ; without-interrupts because installing the new 'hl-static-address cons is a ; single setf. - (let ((addr-cons (get (the symbol s) 'hl-static-address))) - (if addr-cons - ;; Already have an address. ADDR-CONS = (S . TRUE-ADDR), where - ;; TRUE-ADDR is Index(ADDR-CONS) + BASE. So, we just need to - ;; return the TRUE-ADDR. - (cdr addr-cons) - ;; We need to assign an address. Must lock! - (hl-with-lock-grabbed - (*hl-symbol-addr-lock*) - ;; Some other thread might have assigned S an address before we - ;; got the lock. So, double-check and make sure that there still - ;; isn't an address. - (setq addr-cons (get (the symbol s) 'hl-static-address)) + `(let ((s ,s)) + (let ((addr-cons (get (the symbol s) 'hl-static-address))) (if addr-cons + ;; Already have an address. ADDR-CONS = (S . TRUE-ADDR), where + ;; TRUE-ADDR is Index(ADDR-CONS) + BASE. So, we just need to + ;; return the TRUE-ADDR. (cdr addr-cons) - ;; Okay, safe to generate a new address. - (let* ((new-addr-cons (hl-static-cons s nil)) - (true-addr (+ hl-dynamic-base-addr - (hl-staticp new-addr-cons)))) - (rplacd (the cons new-addr-cons) true-addr) - (setf (get (the symbol s) 'hl-static-address) new-addr-cons) - true-addr)))))) + ;; We need to assign an address. Must lock! + (hl-with-lock-grabbed + (*hl-symbol-addr-lock*) + ;; Some other thread might have assigned S an address before we + ;; got the lock. So, double-check and make sure that there still + ;; isn't an address. + (setq addr-cons (get (the symbol s) 'hl-static-address)) + (if addr-cons + (cdr addr-cons) + ;; Okay, safe to generate a new address. + (let* ((new-addr-cons (hl-static-cons s nil)) + (true-addr (+ hl-dynamic-base-addr + (hl-staticp new-addr-cons)))) + (rplacd (the cons new-addr-cons) true-addr) + (setf (get (the symbol s) 'hl-static-address) new-addr-cons) + true-addr))))))) #+static-hons (defun hl-addr-of-unusual-atom (x str-ht other-ht) @@ -1632,25 +1637,27 @@ b)) #+static-hons -(defabbrev hl-addr-combine* (a b) +(defmacro hl-addr-combine* (a b) ;; Inlined version of hl-addr-combine, defined in community book ;; books/system/hl-addr-combine.lisp. See that book for all documentation ;; and a proof that this function is one-to-one. The only change we make ;; here is to use typep to see if the arguments are fixnums in the ;; comparisons, which speeds up our test loop by about 1/3. - (if (and (typep a 'fixnum) - (typep b 'fixnum) - (< (the fixnum a) 1073741824) ; (expt 2 30) - (< (the fixnum b) 1073741824)) - ;; Optimized version of the small case - (the (signed-byte 61) - (- (the (signed-byte 61) - (logior (the (signed-byte 61) - (ash (the (signed-byte 31) a) 30)) - (the (signed-byte 31) b))))) - ;; Large case. - (- (hl-nat-combine* a b) - 576460752840294399))) ; (+ (expt 2 59) (expt 2 29) -1) + `(let ((a ,a) + (b ,b)) + (if (and (typep a 'fixnum) + (typep b 'fixnum) + (< (the fixnum a) 1073741824) ; (expt 2 30) + (< (the fixnum b) 1073741824)) + ;; Optimized version of the small case + (the (signed-byte 61) + (- (the (signed-byte 61) + (logior (the (signed-byte 61) + (ash (the (signed-byte 31) a) 30)) + (the (signed-byte 31) b))))) + ;; Large case. + (- (hl-nat-combine* a b) + 576460752840294399)))) ; (+ (expt 2 59) (expt 2 29) -1) ; ---------------------------------------------------------------------- @@ -2161,7 +2168,7 @@ (setf (gethash x persist-ht) t))) x)) -(defabbrev hl-hspace-hons (x y hs) +(defmacro hl-hspace-hons (x y hs) ; (HL-HSPACE-HONS X Y HS) --> (X . Y) which is normed, and destructively ; updates HS. @@ -2173,9 +2180,12 @@ ; new cons is considered normed, and return it. (declare (type hl-hspace hs)) - (hl-hspace-hons-normed (hl-hspace-norm x hs) - (hl-hspace-norm y hs) - nil hs)) + `(let ((x ,x) + (y ,y) + (hs ,hs)) + (hl-hspace-hons-normed (hl-hspace-norm x hs) + (hl-hspace-norm y hs) + nil hs))) ; ---------------------------------------------------------------------- @@ -3906,7 +3916,7 @@ To avoid the following break and get only the above warning:~% ~a~%" (hl-maybe-initialize-default-hs)) (defun hons (x y) - ;; hl-hspace-hons is inlined via defabbrev + ;; hl-hspace-hons is inlined via defmacro (hl-maybe-initialize-default-hs) (hl-hspace-hons x y *default-hs*)) diff --git a/hons.lisp b/hons.lisp index eadf29f2d0c..16243c40bd8 100644 --- a/hons.lisp +++ b/hons.lisp @@ -32,6 +32,55 @@ (in-package "ACL2") +(defmacro defn (f a &rest r) + `(defun ,f ,a (declare (xargs :guard t)) ,@r)) + +(defmacro defnd (f a &rest r) + `(defund ,f ,a (declare (xargs :guard t)) ,@r)) + +#+(or acl2-loop-only (not hons)) +(defn hons-equal (x y) + (declare (xargs :mode :logic)) + ;; Has an under-the-hood implementation + (equal x y)) + +(defn hons-assoc-equal (key alist) + (declare (xargs :mode :logic)) + (cond ((atom alist) + nil) + ((and (consp (car alist)) + (hons-equal key (caar alist))) + (car alist)) + (t + (hons-assoc-equal key (cdr alist))))) + +#+(or acl2-loop-only (not hons)) +(defn hons-get (key alist) + (declare (xargs :mode :logic)) + ;; Has an under-the-hood implementation + (hons-assoc-equal key alist)) + +#+(or acl2-loop-only (not hons)) +(defn hons-acons (key val alist) + (declare (xargs :mode :logic)) + ;; Has an under-the-hood implementation + (cons (cons key val) alist)) + +#+(or acl2-loop-only (not hons)) +(defmacro fast-alist-free-on-exit-raw (alist form) + ;; Has an under-the-hood implementation + (declare (ignore alist)) + form) + +#+(or acl2-loop-only (not hons)) +(defn fast-alist-free (alist) + (declare (xargs :mode :logic)) + ;; Has an under-the-hood implementation + alist) + +(defmacro fast-alist-free-on-exit (alist form) + `(return-last 'fast-alist-free-on-exit-raw ,alist ,form)) + #+(or acl2-loop-only (not hons)) (defn hons-copy (x) ;; Has an under-the-hood implementation @@ -48,9 +97,6 @@ ;; Has an under-the-hood implementation (cons x y)) -; See basis-a.lisp for hons-equal, which supports hons-assoc-equal, which -; supports eviscerate1. - #+(or acl2-loop-only (not hons)) (defn hons-equal-lite (x y) ;; Has an under-the-hood implementation @@ -115,16 +161,6 @@ (and (consp warning) (cdr warning)))) -#+(or acl2-loop-only (not hons)) -(defn hons-get (key alist) - ;; Has an under-the-hood implementation - (hons-assoc-equal key alist)) - -#+(or acl2-loop-only (not hons)) -(defn hons-acons (key val alist) - ;; Has an under-the-hood implementation - (cons (cons key val) alist)) - #+(or acl2-loop-only (not hons)) (defn hons-acons! (key val alist) ;; Has an under-the-hood implementation @@ -179,11 +215,6 @@ ;; Has an under-the-hood implementation (len (fast-alist-fork alist nil))) -#+(or acl2-loop-only (not hons)) -(defn fast-alist-free (alist) - ;; Has an under-the-hood implementation - alist) - #+(or acl2-loop-only (not hons)) (defn fast-alist-summary () ;; Has an under-the-hood implementation @@ -207,15 +238,6 @@ (defmacro with-stolen-alist (alist form) `(return-last 'with-stolen-alist-raw ,alist ,form)) -#+(or acl2-loop-only (not hons)) -(defmacro fast-alist-free-on-exit-raw (alist form) - ;; Has an under-the-hood implementation - (declare (ignore alist)) - form) - -(defmacro fast-alist-free-on-exit (alist form) - `(return-last 'fast-alist-free-on-exit-raw ,alist ,form)) - (defn cons-subtrees (x al) (cond ((atom x) al) diff --git a/interface-raw.lisp b/interface-raw.lisp index fba26a5b8f0..f439c252bef 100644 --- a/interface-raw.lisp +++ b/interface-raw.lisp @@ -24,6 +24,104 @@ ; cannot code in ACL2 because they require constructs not in ACL2, such ; as calling the compiler. +; We start with a section that was originally in acl2-fns.lisp, but was moved +; here when sharp-atsign-read started using several functions defined in the +; sources, to avoid compiler warnings. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; SUPPORT FOR #@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro sharp-atsign-read-er (str &rest format-args) + `(progn (loop (when (null (read-char-no-hang stream nil nil t)) + (return))) + (error (concatenate 'string ,str ". See :DOC set-iprint.") + ,@format-args))) + +(defun sharp-atsign-read (stream char n &aux (state *the-live-state*)) + (declare (ignore char n)) + (let (ch + bad-ch + (zero-code (char-code #\0)) + (index 0) + (iprint-last-index (iprint-last-index state))) + (loop + (when (eql (setq ch (read-char stream t nil t)) + #\#) + (return)) + (let ((digit (- (char-code ch) zero-code))) + (cond ((or (< digit 0) + (> digit 9)) + (when (not bad-ch) + (setq bad-ch ch)) + (return)) + (t + (setq index (+ digit (* 10 index))))))) + (cond + (bad-ch + (sharp-atsign-read-er + "Non-digit character ~s following #@~s" + bad-ch index)) + ((symbol-value (f-get-global 'certify-book-info state)) + (sharp-atsign-read-er + "Illegal reader macro during certify-book, #@~s#" + index)) + ((iprint-ar-illegal-index index state) + (sharp-atsign-read-er + "Out-of-bounds index in #@~s#" + index)) + (t + (let ((old-read-state ; bind special + *iprint-read-state*)) + (cond + ((eq old-read-state nil) + (iprint-ar-aref1 index state)) + (t + (let ((new-read-state-order (if (<= index iprint-last-index) + '<= + '>))) + (cond + ((eq old-read-state t) + (setq *iprint-read-state* + (cons index new-read-state-order)) + (iprint-ar-aref1 index state)) + ((eq (cdr old-read-state) + new-read-state-order) ; both > or both <= + (iprint-ar-aref1 index state)) + (t + (multiple-value-bind + (index-before index-after) + (cond + ((eq (cdr old-read-state) '<=) + (values index (car old-read-state))) + (t ; (eq (cdr old-read-state) '>) + (values (car old-read-state) index))) + (sharp-atsign-read-er + "Attempt to read a form containing both an index~%~ + created before the most recent rollover (#@~s#) and~%~ + an index created after that rollover (#@~s#)" + index-before index-after)))))))))))) + +(defun define-sharp-atsign () + (set-new-dispatch-macro-character + #\# + #\@ + #'sharp-atsign-read)) + +(eval-when + +; Note: CMUCL build breaks without the check below for a compiled function. + + #-cltl2 + (load eval) + #+cltl2 + (:load-toplevel :execute) + (when (compiled-function-p! 'sharp-atsign-read) + (let ((*readtable* *acl2-readtable*)) + (define-sharp-atsign)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; EVALUATION ; Essay on Evaluation in ACL2 diff --git a/ld.lisp b/ld.lisp index d56bfc1c691..e3df5e27fae 100644 --- a/ld.lisp +++ b/ld.lisp @@ -743,38 +743,59 @@ (declare (ignore erp val)) (mv t nil nil state))))))))) -(defun restore-iprint-ar-from-wormhole (state) - (declare (xargs :stobjs state)) +#-acl2-loop-only +(defvar *iprint-read-state* + +; Possible values are: + +; nil - no requirement on current iprint index +; t - either all indices must exceed iprint-last-index, or none does +; (n . <=) - n, already read, is <= iprint-last-index; index must be too +; (n . >) - n, already read, is > iprint-last-index; index must be too + +; The value is initially nil. At a top-level read, it is set to nil if +; iprint-fal is nil, else to t. For the first index i that is read when the +; value is t, we set the value to <= if (<= i iprint-last-index) and to > +; otherwise. + + nil) + +(defun iprint-oracle-updates (state) #+acl2-loop-only (mv-let (erp val state) - (read-acl2-oracle state) - (declare (ignore erp)) + (read-acl2-oracle state) + (declare (ignore erp)) ; If we intend to reason about this function, then we might want to check that ; val is a reasonable value. But that seems not important, since very little ; reasoning would be possible anyhow for this function. - (pprogn (f-put-global 'iprint-ar - (and (consp val) (car val)) - state) - (f-put-global 'iprint-hard-bound - (nfix (and (consp val) - (consp (cdr val)) - (cadr val))) - state) - (f-put-global 'iprint-soft-bound - (nfix (and (consp val) - (consp (cdr val)) - (cddr val))) - state) - state)) + (let ((val (fix-true-list val))) + (pprogn (f-put-global 'iprint-ar + (nth 0 val) + state) + (f-put-global 'iprint-hard-bound + (nfix (nth 1 val)) + state) + (f-put-global 'iprint-soft-bound + (nfix (nth 2 val)) + state) + (f-put-global 'iprint-fal + (nth 3 val) + state) + state))) #-acl2-loop-only (let* ((ar *wormhole-iprint-ar*)) (when ar - (f-put-global 'iprint-ar (compress1 'iprint-ar ar) state) + (f-put-global 'iprint-ar ar state) + (f-put-global 'iprint-fal *wormhole-iprint-fal* state) (f-put-global 'iprint-hard-bound *wormhole-iprint-hard-bound* state) (f-put-global 'iprint-soft-bound *wormhole-iprint-soft-bound* state) (setq *wormhole-iprint-ar* nil)) + (setq *iprint-read-state* + (if (f-get-global 'iprint-fal state) + t + nil)) state)) (defun ld-fix-command (form) @@ -812,7 +833,7 @@ ; be (:kons x y). (pprogn - (restore-iprint-ar-from-wormhole state) ; even before the read + (iprint-oracle-updates state) ; even before the read (mv-let (eofp val state) (read-standard-oi state) (pprogn @@ -2532,10 +2553,10 @@ #-acl2-loop-only (defun-one-output compiled-function-p! (fn) -; In CMU Lisp, compiled-function-p is braindead. It seems that the -; symbol-function of every defun'd function is a ``compiled'' object. -; Some are # and others are #. -; I think the following test works. Fn is assumed to be a symbol. +; In CMU Lisp, it seems that the symbol-function of every defun'd function +; satisfies compiled-function-p. Some are # and +; others are #. The following test seems to work. Fn is assumed +; to be a symbol. #+cmu (not (eq (type-of (symbol-function fn)) 'eval:interpreted-function)) diff --git a/other-events.lisp b/other-events.lisp index 000aa76c670..bfb9e19e8b0 100644 --- a/other-events.lisp +++ b/other-events.lisp @@ -24359,18 +24359,10 @@ (cond (result (mv "Iprinting has been disabled." state)) (t (mv "Iprinting remains disabled." state))))) ((eq x t) - (cond - ((not (eql (1+ (iprint-hard-bound state)) - (car (dimensions 'iprint-ar - (f-get-global 'iprint-ar state))))) - (pprogn (warning$ 'set-iprint "Iprint" - "Resetting iprinting, because the :HARD-BOUND is ~ - changing.") - (set-iprint-fn1 :reset-enable state))) - (t (mv-let (result state) - (enable-iprint-ar state) - (cond (result (mv "Iprinting has been enabled." state)) - (t (mv "Iprinting remains enabled." state))))))) + (mv-let (result state) + (enable-iprint-ar state) + (cond (result (mv "Iprinting has been enabled." state)) + (t (mv "Iprinting remains enabled." state))))) ((member-eq x '(:reset :reset-enable)) (pprogn (f-put-global 'iprint-ar @@ -24384,82 +24376,143 @@ (t "Iprinting has been reset and disabled.")) state))) - (t (mv t state)))) - -(defun set-iprint-fn (x state) - (let ((ctx 'set-iprint)) - (mv-let (msg state) - (set-iprint-fn1 x state) - (cond ((eq msg t) - (er soft ctx - "Unknown option, ~x0. The legal iprint actions are ~&1." - x *iprint-actions*)) - (msg (pprogn (observation ctx "~@0" msg) - (value :invisible))) - (t (value :invisible)))))) - -(defun set-iprint-hard-bound (n ctx state) - (cond ((posp n) - (pprogn (f-put-global 'iprint-hard-bound n state) - (observation ctx "The hard-bound for iprinting has been set ~ - to ~x0." - n) - (value :invisible))) - (t - (er soft ctx - "The hard-bound for iprinting must be a positive integer, but ~ - ~x0 is not." - n)))) - -(defun set-iprint-soft-bound (n ctx state) - (cond ((posp n) - (pprogn (f-put-global 'iprint-soft-bound n state) - (observation ctx "The soft-bound for iprinting has been set ~ - to ~x0." - n) - (value :invisible))) - (t - (er soft ctx - "The soft-bound for iprinting must be a positive integer, but ~ - ~x0 is not." - n)))) + (t -(defmacro set-iprint (&optional (action ':RESET ; default ignored +; This is odd! Apparently we didn't cover all the cases in *iprint-actions* +; above, even though we thought we checked in set-iprint-fn that we are in one +; such case. + + (mv (er hard 'set-iprint-fn1 + "Implementation error! Please contact the ACL2 implementors.") + state)))) + +(defun init-iprint-fal+ (sym ctx state) + (mv-let (msg state) + (init-iprint-fal sym state) + (cond (msg (observation ctx "~@0" msg)) + (t state)))) + +(defun set-iprint-fn (action0 share share-p + soft-bound soft-bound-p + hard-bound hard-bound-p + ctx state) + (let ((action (cond ((or share-p hard-bound-p) + (case action0 + ((t) :reset-enable) + ((nil) :reset) + ((:same) (if (iprint-enabledp state) + :reset-enable + :reset)) + ((:reset :reset-enable) action0) + (otherwise (assert$ (not (member-eq action0 + *iprint-actions*)) + :fail)))) + (t action0)))) + (cond + ((eq action :fail) + (er soft ctx + "Unknown option, ~x0. The legal iprint actions are ~&1." + action0 *iprint-actions*)) + ((not (symbolp share)) + (er soft ctx + "The :share argument for iprinting must be a symbol, but ~x0 is not." + share)) + ((and soft-bound-p + (not (posp soft-bound))) + (er soft ctx + "The :SOFT-BOUND argument of SET-IPRINT must be a positive integer, ~ + but ~x0 is not." + soft-bound)) + ((and hard-bound-p + (not (posp hard-bound))) + (er soft ctx + "The :HARD-BOUND argument of SET-IPRINT must be a positive integer, ~ + but ~x0 is not." + hard-bound)) + (t (pprogn (cond ((not (eq action action0)) + (warning$ 'set-iprint "Iprint" + "Converting SET-IPRINT action from ~x0 to ~ + ~x1, as required by use of keyword :SHARE ~ + or :HARD-BOUND. See :DOC set-iprint." + action0 action)) + (t state)) + (pprogn (cond + (soft-bound-p + (pprogn (f-put-global 'iprint-soft-bound + soft-bound + state) + (observation ctx + "The soft-bound for ~ + iprinting has been set to ~ + ~x0." + soft-bound))) + (t state)) + (cond + (hard-bound-p + (pprogn (f-put-global 'iprint-hard-bound + hard-bound + state) + (observation ctx + "The hard-bound for ~ + iprinting has been set to ~ + ~x0." + hard-bound))) + (t state)) + (cond ((eq share :same) + (if (member-eq action + '(:reset :reset-enable)) + (init-iprint-fal+ :same ctx state) + state)) + ((eq share nil) + (init-iprint-fal+ share ctx state)) + (t (init-iprint-fal+ share ctx state))) + (mv-let (msg state) + (set-iprint-fn1 action state) + (pprogn (cond (msg (observation ctx "~@0" msg)) + (t state)) + (value :invisible))))))))) + +(defmacro set-iprint (&optional (action ':reset ; default ignored action-p) &key + (share ':same share-p) (soft-bound '1 ; default ignored soft-bound-p) (hard-bound '1 ; default ignored hard-bound-p)) (declare (xargs :guard ; the setters deal with illegal values t)) - `(er-progn ,@(and hard-bound-p - `((set-iprint-hard-bound ,hard-bound 'set-iprint state))) - ,@(and soft-bound-p - `((set-iprint-soft-bound ,soft-bound 'set-iprint state))) - ,(cond - (action-p `(set-iprint-fn ,action state)) - (t - '(er-let* - ((ans - (acl2-query - :set-iprint - '("Action" - :t t :nil nil - :reset :reset :reset-enable :reset-enable :same :same - :q :q - :? ("reply with :Q to quit, or else with one of the ~ - options to set-iprint, which are ~&0 (see :DOC ~ - set-iprint)" - :t t :nil nil - :reset :reset :reset-enable :reset-enable - :same :same - :q :q)) - (list (cons #\0 *iprint-actions*)) - state))) - (cond ((eq ans :q) - (silent-error state)) - (t (set-iprint-fn ans state)))))))) + `(mv-let + (action action-p share share-p + soft-bound soft-bound-p + hard-bound hard-bound-p) + (mv ,action ,action-p ,share ,share-p + ,soft-bound ,soft-bound-p + ,hard-bound ,hard-bound-p) + (er-let* ((action + (if action-p + (value action) + (acl2-query + :set-iprint + '("Action" + :t t :nil nil + :reset :reset :reset-enable :reset-enable :same :same + :q :q + :? ("reply with :Q to quit, or else with one of the ~ + options to set-iprint, which are ~&0 (see :DOC ~ + set-iprint)" + :t t :nil nil + :reset :reset :reset-enable :reset-enable + :same :same + :q :q)) + (list (cons #\0 *iprint-actions*)) + state)))) + (cond ((eq action :q) + (silent-error state)) + (t (set-iprint-fn action share share-p + soft-bound soft-bound-p + hard-bound hard-bound-p + 'set-iprint state)))))) ; We develop code for setting evisc-tuples. @@ -24611,7 +24664,10 @@ (t (er-progn (chk-evisc-tuple evisc-tuple ctx state) - (cond (iprint-p (set-iprint-fn iprint state)) + (cond (iprint-p (set-iprint-fn iprint :same nil + nil nil + nil nil + ctx state)) ((not (iprint-virginp state)) (value nil)) (t (set-iprint))) @@ -27215,8 +27271,7 @@ ; This function, which is untouchable, assumes that iprint-ar is well-formed. ; It is used when restoring a valid iprint-ar. - (prog2$ (compress1 'iprint-ar iprint-ar) - (f-put-global 'iprint-ar iprint-ar state))) + (f-put-global 'iprint-ar (compress1 'iprint-ar iprint-ar) state)) (defmacro channel-to-string (form channel-var &optional From 3dfdc1a4c64d01fcf287b91b6147b41fb516fde4 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sat, 23 Jul 2016 18:53:34 -0700 Subject: [PATCH 21/70] Simplify implementation of SOFT. Avoid storing the kind of DEFUN-SK rewrite rule in the table of second-order functions. This can be obtained using the DEFUN-SK query utilities. --- books/kestrel/soft/implementation.lisp | 66 +++++++++----------------- 1 file changed, 22 insertions(+), 44 deletions(-) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index 02817a66f3a..b44fac7b412 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -150,11 +150,6 @@ (or (eq quant 'acl2::forall) (eq quant 'acl2::exists))) -(define qrewrite-kindp (qrkind) - (or (eq qrkind 'default) - (eq qrkind 'direct) - (eq qrkind 'term))) - (define plain-sofun-infop (info (w plist-worldp)) :verify-guards nil (and (true-listp info) @@ -173,12 +168,11 @@ (define quant-sofun-infop (info (w plist-worldp)) :verify-guards nil (and (true-listp info) - (= (len info) 5) + (= (len info) 4) (sofun-kindp (first info)) (funvar-setp (second info) w) (bound-varsp (third info)) - (quantifierp (fourth info)) - (qrewrite-kindp (fifth info)))) + (quantifierp (fourth info)))) (define sofun-infop (info (w plist-worldp)) :verify-guards nil @@ -233,12 +227,6 @@ (let ((table (table-alist 'second-order-functions w))) (fourth (cdr (assoc-eq sofun table))))) -(define sofun-qrewrite-kind (sofun (w plist-worldp)) - :guard (quant-sofunp sofun w) - :verify-guards nil - (let ((table (table-alist 'second-order-functions w))) - (fifth (cdr (assoc-eq sofun table))))) - ; A DEFUN-SK introduces a rewrite rule for the function FUN being defined, ; namely the FUN-NECC (for FORALL) or FUN-SUFF (for EXISTS) theorem. ; These are the default names, @@ -591,14 +579,7 @@ (quant (first body)) (bvars (second body)) (bvars (if (symbolp bvars) (list bvars) bvars)) - (rewrite (cadr (assoc-keyword :rewrite options))) - (qrkind (if rewrite - (case rewrite - (:default 'default) - (:direct 'direct) - (otherwise 'term)) - 'default)) - (info (list 'quant fparams bvars quant qrkind))) + (info (list 'quant fparams bvars quant))) `(progn (defun-sk ,sofun ,params ,body ,@options) (table second-order-functions ',sofun ',info) @@ -1326,26 +1307,23 @@ ;; is determined from the supplied value (if any), ;; otherwise it is inherited from SOFUN: (rewrite-supplied (cadr (assoc-keyword :rewrite options))) - (rewrite (or rewrite-supplied - (let ((qrkind (sofun-qrewrite-kind sofun w))) - (case qrkind - (default :default) - (direct :direct) - (term - ;; apply instantiation to that term - ;; and use result as :REWRITE for FUN - ;; (the instantiation is extended with (SOFUN . FUN) - ;; because the term presumably references SOFUN): - (let* ((fsbs (acons sofun fun inst)) - (rule-name (defun-sk-rewrite-rule-name - sofun (sofun-quantifier sofun w))) - (term (formula rule-name nil w))) - (fun-subst-term fsbs term w))))))) - ;; kind of rewrite rule for FUN: - (qrkind (case rewrite - (:default 'default) - (:direct 'direct) - (otherwise 'term))) + (rewrite + (or rewrite-supplied + (let ((qrkind (acl2::defun-sk-info->rewrite-kind + (acl2::defun-sk-check sofun w)))) + (case qrkind + (:default :default) + (:direct :direct) + (:custom + ;; apply instantiation to that term + ;; and use result as :REWRITE for FUN + ;; (the instantiation is extended with (SOFUN . FUN) + ;; because the term presumably references SOFUN): + (let* ((fsbs (acons sofun fun inst)) + (rule-name (defun-sk-rewrite-rule-name + sofun (sofun-quantifier sofun w))) + (term (formula rule-name nil w))) + (fun-subst-term fsbs term w))))))) ;; apply instantiation to the guard of SOFUN: (sofun-guard (guard sofun nil w)) (fun-guard (fun-subst-term inst sofun-guard w)) @@ -1353,7 +1331,7 @@ (wit-dcl `(declare (xargs :guard ,fun-guard :verify-guards nil))) ;; info about FUN to add to the table of second-order functions ;; (if FUN is second-order): - (info (list 'quant fparams bound-vars quant qrkind)) + (info (list 'quant fparams bound-vars quant)) ;; singleton list of event to add FUN ;; to the table of second-order functions, ;; or NIL if FUN is first-order: @@ -1367,7 +1345,7 @@ :quant-ok t :rewrite ,rewrite :witness-dcls (,wit-dcl) -; Matt K. mod: avoid duplicate keywords. + ;; Matt K. mod: avoid duplicate keywords: ,@(acl2::strip-keyword-list '(:strengthen :quant-ok :rewrite :witness-dcls) options)) From c77ca974f39c6206b421b864db08309601ebcd21 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sat, 23 Jul 2016 19:43:43 -0700 Subject: [PATCH 22/70] Improve implementation of SOFT. Use a DEFUN-SK query utility instead of a local, less general version of it (which has been now removed). --- books/kestrel/soft/implementation.lisp | 75 +++++++++----------------- 1 file changed, 26 insertions(+), 49 deletions(-) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index b44fac7b412..81e8c124d77 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -227,20 +227,6 @@ (let ((table (table-alist 'second-order-functions w))) (fourth (cdr (assoc-eq sofun table))))) -; A DEFUN-SK introduces a rewrite rule for the function FUN being defined, -; namely the FUN-NECC (for FORALL) or FUN-SUFF (for EXISTS) theorem. -; These are the default names, -; but they may be changed using the :THM-NAME option of DEFUN-SK. -; However, currently SOFT does not support the :THM-NAME option (see below), -; and so the names are always the default ones. - -(define defun-sk-rewrite-rule-name ((fun symbolp) (quant quantifierp)) - :verify-guards nil - (let* ((fun-name (symbol-name fun)) - (suffix (case quant (forall "-NECC") (exists "-SUFF"))) - (rule-name (string-append fun-name suffix))) - (intern-in-package-of-symbol rule-name fun))) - ; A term may reference a function variable directly ; (when the function variable occurs in the term) ; or indirectly @@ -303,14 +289,14 @@ ; may reference function variables in their defining bodies. (define funvars-of-defchoose ((fun symbolp) (w plist-worldp)) - :mode :program ; calls DEFCHOOSE-BODY + :mode :program (funvars-of-term (acl2::defchoose-body fun w) w)) ; Second-order theorems and their instances ; may reference function variables in their formulas. (define funvars-of-defthm ((thm symbolp) (w plist-worldp)) - :mode :program ; calls FORMULA + :mode :program (funvars-of-term (formula thm nil w) w)) ; When a second-order function, or an instance thereof, is introduced, @@ -327,7 +313,7 @@ (w plist-worldp)) :guard (or (funvar-setp fparams w) ; if FUN is 2nd-order (null fparams)) ; if FUN is 1st-order - :mode :program ; calls FUNVARS-OF-DEFUN + :mode :program (let ((funvars (case kind (plain (funvars-of-defun fun w)) (choice (funvars-of-defchoose fun w)) @@ -360,10 +346,10 @@ ; the custom rewrite rule must have the same function variables ; as the matrix (or body) of the function. -(define check-qrewrite-rule-funvars - ((fun symbolp) (quant quantifierp) (w plist-worldp)) - :mode :program ; calls FORMULA - (let* ((rule-name (defun-sk-rewrite-rule-name fun quant)) +(define check-qrewrite-rule-funvars ((fun symbolp) (w plist-worldp)) + :mode :program + (let* ((rule-name (acl2::defun-sk-info->rewrite-name + (acl2::defun-sk-check fun w))) (rule-body (formula rule-name nil w)) (fun-body (acl2::body fun nil w))) (set-equiv (funvars-of-term rule-body w) @@ -588,7 +574,6 @@ ',fparams (w state))) (value-triple (check-qrewrite-rule-funvars ',sofun - ',quant (w state)))))) (defmacro defun-sk2 (sofun fparams params body &rest options) @@ -607,7 +592,7 @@ ; A theorem may reference function variables in its formula. (define funvars-of-theorem ((thm symbolp) (w plist-worldp)) - :mode :program ; calls FORMUAL + :mode :program (funvars-of-term (formula thm nil w) w)) ; A second-order theorem is mimicked by a (first-order) theorem @@ -616,7 +601,7 @@ ; A theorem is second-order iff it depends on one or more function variables. (define sothmp ((sothm symbolp) (w plist-worldp)) - :mode :program ; calls FUNVARS-OF-THEOREM + :mode :program (not (null (funvars-of-theorem sothm w)))) ; When a second-order function or theorem is instantiated, @@ -825,7 +810,7 @@ ; similarly to the code that applies a function substitution to a term. (defines ext-fun-subst-term/terms/function - :mode :program ; termination needs ACL2 world invariants + :mode :program (define ext-fun-subst-term ((term pseudo-termp) (fsbs fun-substp) (w plist-worldp)) @@ -847,7 +832,6 @@ (define ext-fun-subst-function ((fun symbolp) (fsbs fun-substp) (w plist-worldp)) - :mode :program ; calls FORMULA (cond ((assoc fun fsbs) fsbs) ; pair already present ((sofunp fun w) @@ -860,16 +844,8 @@ (raise "~x0 has no instance for ~x1." fun fsbs)) (fsbs (acons fun funinst fsbs))) ; extend FSBS (case (sofun-kind fun w) - (plain (ext-fun-subst-term (acl2::body fun nil w) fsbs w)) - (choice (ext-fun-subst-term (acl2::defchoose-body fun w) fsbs w)) - (quant - (let* ((fsbs (ext-fun-subst-term (acl2::body fun nil w) fsbs w)) - ;; the 2nd-order functions in the matrix of FUN - ;; are the same as in the rewrite rule of FUN: - (quant (sofun-quantifier fun w)) - (body - (formula (defun-sk-rewrite-rule-name fun quant) nil w))) - (ext-fun-subst-term body fsbs w)))))) + ((plain quant) (ext-fun-subst-term (acl2::body fun nil w) fsbs w)) + (choice (ext-fun-subst-term (acl2::defchoose-body fun w) fsbs w))))) (t fsbs)))) ; FUN is not a 2nd-order function ; From a function substitution obtained by extending an instantiation as above, @@ -892,7 +868,7 @@ ; does not catch these witnesses. (define sothm-inst-pairs ((fsbs fun-substp) (w plist-worldp)) - :mode :program ; calls DEFUN-SK-CHECK + :mode :program (if (endp fsbs) nil (let* ((pair (car fsbs)) @@ -957,7 +933,7 @@ ; so no fact is used in the proof. (define sothm-inst-facts ((fsbs fun-substp) (w plist-worldp)) - :verify-guards nil + :mode :program (if (endp fsbs) nil (let* ((pair (car fsbs)) @@ -967,7 +943,8 @@ (choice-sofunp 1st w)) (cons 2nd (sothm-inst-facts (cdr fsbs) w))) ((quant-sofunp 1st w) - (cons (defun-sk-rewrite-rule-name 2nd (sofun-quantifier 1st w)) + (cons (acl2::defun-sk-info->rewrite-name + (acl2::defun-sk-check 2nd w)) (sothm-inst-facts (cdr fsbs) w))) (t (sothm-inst-facts (cdr fsbs) w)))))) @@ -983,7 +960,7 @@ (define sothm-inst-proof ((sothm symbolp) (fsbs fun-substp) (w plist-worldp)) - :mode :program ; calls SOTHM-INST-PAIRS + :mode :program `(:instructions ((:use (:functional-instance ,sothm ,@(sothm-inst-pairs fsbs w))) (:repeat (:then (:use ,@(sothm-inst-facts fsbs w)) :prove))))) @@ -1020,14 +997,14 @@ ; where SOTHM is a 2nd-order theorem ; and ((F1 . G1) ... (Fm . Gm)) is an instantiation: (define check-sothm-inst (sothm-inst (w plist-worldp)) - :mode :program ; calls SOTHMP + :mode :program (and (true-listp sothm-inst) (>= (len sothm-inst) 2) (sothmp (car sothm-inst) w) (funvar-instp (cdr sothm-inst) w))) (define defthm-inst-event (thm sothm-inst rest (w plist-worldp)) - :mode :program ; calls EXT-FUN-SUBST-TERM and FORMULA + :mode :program (b* (;; THM is the name of the new theorem: ((unless (symbolp thm)) (raise "~x0 must be a name." thm)) ;; after THM there is (SOTHM (F1 . G1) ... (Fm . Gm)): @@ -1205,7 +1182,7 @@ :guard (and (or (funvar-setp fparams w) ; FUN is 2nd-order (null fparams)) ; FUN is 1st-order (plain-sofunp sofun w)) - :mode :program ; calls EXT-FUN-SUBST-TERM and GUARD and FORMULA + :mode :program (b* (;; retrieve body, measure, and guard of SOFUN: (sofun-body (acl2::body sofun nil w)) (sofun-measure (if (acl2::recursivep sofun nil w) @@ -1264,7 +1241,7 @@ :guard (and (or (funvar-setp fparams w) ; FUN is 2nd-order (null fparams)) ; FUN is 1st-order (choice-sofunp sofun w)) - :mode :program ; calls DEFCHOOSE-BODY and DEFCHOOSE-STRENGTHEN + :mode :program (b* (;; retrieve bound variables of SOFUN: (bound-vars (sofun-bound-vars sofun w)) ;; apply instantiation to body of SOFUN: @@ -1294,7 +1271,7 @@ :guard (and (or (funvar-setp fparams w) ; FUN is 2nd-order (null fparams)) ; FUN is 1st-order (quant-sofunp sofun w)) - :mode :program ; calls FORMULA + :mode :program (b* (;; retrieve DEFUN-SK-specific constituents of SOFUN: (sofun-info (acl2::defun-sk-check sofun w)) ;; retrieve bound variables and quantifier of SOFUN: @@ -1320,8 +1297,8 @@ ;; (the instantiation is extended with (SOFUN . FUN) ;; because the term presumably references SOFUN): (let* ((fsbs (acons sofun fun inst)) - (rule-name (defun-sk-rewrite-rule-name - sofun (sofun-quantifier sofun w))) + (rule-name (acl2::defun-sk-info->rewrite-name + (acl2::defun-sk-check sofun w))) (term (formula rule-name nil w))) (fun-subst-term fsbs term w))))))) ;; apply instantiation to the guard of SOFUN: @@ -1350,10 +1327,10 @@ '(:strengthen :quant-ok :rewrite :witness-dcls) options)) ,@table-event - (value-triple (check-qrewrite-rule-funvars ',fun ',quant (w state)))))) + (value-triple (check-qrewrite-rule-funvars ',fun (w state)))))) (define defun-inst-event (fun fparams-or-sofuninst rest (w plist-worldp)) - :mode :program ; calls DEFUN-INST-PLAIN-EVENTS + :mode :program (b* (;; FUN is the name of the new function: ((unless (symbolp fun)) (raise "~x0 must be a name." fun)) ;; after FUN there is (FVAR1 ... FVARn) if FUN is 2nd-order, From 3f062d7ce909e8ad74c0fe268749350094e8a072 Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Sat, 23 Jul 2016 22:39:32 -0500 Subject: [PATCH 23/70] Changed ttag used by verify-guards-program from t to :verify-guards-program. Replaced a few null tests by endp tests. Thanks to Eric Smith for suggesting these changes. Plus, I put assoc-equal-cdr into guard-verified :logic mode. --- .../kestrel/system/verify-guards-program.lisp | 2 +- defthm.lisp | 2 +- doc.lisp | 188 +++++++++++++++--- rewrite.lisp | 2 +- type-set-b.lisp | 4 +- 5 files changed, 169 insertions(+), 29 deletions(-) diff --git a/books/kestrel/system/verify-guards-program.lisp b/books/kestrel/system/verify-guards-program.lisp index 56ad62901b1..278ab796cec 100644 --- a/books/kestrel/system/verify-guards-program.lisp +++ b/books/kestrel/system/verify-guards-program.lisp @@ -328,7 +328,7 @@ '(set-state-ok t) '(set-irrelevant-formals-ok t) '(set-ignore-ok t) - '(defttag t) + '(defttag :verify-guards-program) '(set-temp-touchable-vars t state) '(set-temp-touchable-fns t state) '(assign verify-termination-on-raw-program-okp t) diff --git a/defthm.lisp b/defthm.lisp index fec6e2756fd..d60bd11e4ea 100644 --- a/defthm.lisp +++ b/defthm.lisp @@ -10333,7 +10333,7 @@ (list 'pr!-fn cd 'state)) (defun disabledp-fn-lst (runic-mapping-pairs ens) - (cond ((null runic-mapping-pairs) nil) + (cond ((endp runic-mapping-pairs) nil) ((enabled-numep (caar runic-mapping-pairs) ens) (disabledp-fn-lst (cdr runic-mapping-pairs) ens)) (t (cons (cdar runic-mapping-pairs) diff --git a/doc.lisp b/doc.lisp index a65f3033a38..ce6c122a5a7 100644 --- a/doc.lisp +++ b/doc.lisp @@ -6246,6 +6246,8 @@ Subtopics [Symbol-alistp] Recognizer for association lists with symbols as keys") + (ALL-CALLS (POINTERS) + "See [system-utilities].") (ALL-VARS (POINTERS) "See [system-utilities].") (ALLOCATE-FIXNUM-RANGE @@ -72586,6 +72588,16 @@ Changes to Existing Features (set-state-ok nil) (verify-termination foo) ; formerly failed + To evaluate a form (set-iprint t :hard-bound N), ACL2 will first + replace t by :reset-enable. This behavior has been expanded to + apply to (set-iprint nil :hard-bound N) and (set-iprint :same + :hard-bound N) as well: the first argument will be converted to + :reset or :reset-enable. See [set-iprint]. This change fixes a bug + in the interaction between hard-bounds and rollovers. For an + example that formerly exhibited this bug, see a comment about + ``hard-bounds and rollovers'' in (defxdoc note-7-3 ...) in + community book books/system/doc/acl2-doc.lisp. + New Features @@ -72624,6 +72636,10 @@ New Features behaves like ~s except that margins are ignored. Thanks to Jared Davis for requesting this feature. + The iprinting utility has a new keyword option, :share, which causes + iprint indices to be re-used. See [set-iprint]. Thanks to David + Rager for suggesting such an enhancement. + Heuristic and Efficiency Improvements @@ -78573,6 +78589,9 @@ Subtopics [Add-to-set-equal] See [add-to-set]. + [All-calls] + See [system-utilities]. + [All-vars] See [system-utilities]. @@ -92241,6 +92260,46 @@ Example ACL2 !> + You might wish to know which elided expressions are equal. You may + specify keyword argument :share t for that purpose to turn on + ``iprint sharing'', which causes behavior as shown below: the value + printed shows the iprint index 2 being used twice for the list (C D + E F). + + ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) + ((A B . #@2#) (A B . #@2#) . #@3#) + ACL2 !> + + Remark (feel free to skip this paragraph). To understand more fully + how iprint sharing works, consider the following log. The Warning + below is pointing out that previous iprint indices are no longer + valid; we are starting over. The first Observation points out that + iprint sharing is on, and gives the name :IPRINT-FAL to look for in + (fast-alist-summary) in case you want information on the + [fast-alist] that associates values with corresponding iprint + indices. To see the relevance of a fast-alist, note that the two + elided occurrences of the list (C D E F) were originally not the + identical list in memory; to make them identical, [hons-copy] is + applied to each to get the same list in memory, which is the one + associated with iprint index 2 in a fast-alist named :IPRINT-FAL. + + ACL2 !>(set-iprint t :share t) + + ACL2 Warning [Iprint] in SET-IPRINT: Converting SET-IPRINT action + from T to :RESET-ENABLE, as required by use of keyword :SHARE or :HARD- + BOUND. See :DOC set-iprint. + + + ACL2 Observation in SET-IPRINT: Iprinting is enabled with sharing, + with a fast-alist whose name is :IPRINT-FAL. + + ACL2 Observation in SET-IPRINT: Iprinting has been reset and enabled. + ACL2 !>(set-evisc-tuple (evisc-tuple 2 2 nil nil) :sites :all) + (:TERM :LD . #@1#) + ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) + ((A B . #@2#) (A B . #@2#) . #@3#) + ACL2 !> + The documentation above probably suffices for most users. For those who want more details, below we detail all the ways to use the set-iprint utility. @@ -92250,18 +92309,22 @@ Example (set-iprint nil) ; disable iprinting General Form: - (set-iprint action ; t, nil, :reset, :reset-enable, or :same - :soft-bound s ; initially 1000 - :hard-bound h ; initially 10000) + (set-iprint action ; t, nil, :reset, :reset-enable, or :same + :share sym ; initially nil + :soft-bound s ; initially 1000 + :hard-bound h ; initially 10000) where all arguments are optional, but ACL2 queries for action if it - is omitted. We defer the explanations of :soft-bound and - :hard-bound. The values for action are as follows: + is omitted. All arguments are evaluated. When a keyword argument is + omitted, there is no change in the behavior that it controls. For + now we defer further explanations of the keyword arguments. The + values for action are as follows. - t --- Enable iprinting. If keyword :hard-bound is supplied, then t is - converted to :reset-enable. + t --- Enable iprinting. If either keyword :share or :hard-bound is + supplied, then t is converted to :reset-enable. - nil --- Disable iprinting. + nil --- Disable iprinting. If either keyword :share or :hard-bound is + supplied, then nil is converted to :reset. :reset --- Reset iprinting to its initial disabled state, so that when enabled, the first index i for which `#@i# is printed will @@ -92271,16 +92334,36 @@ Example :reset-enable --- Reset iprinting as with :reset, and then enable iprinting. - :same --- Make no change to the iprinting state (other than setting - the :soft-bound and/or :hard-bound if specified, as explained - below). + :same --- If either keyword :share or :hard-bound is supplied, then + :same is converted to :reset or :reset-enable according to + whether iprinting is currently disabled or enabled, + respectively. Otherwise, make no change to the iprinting state + other than setting the soft-bound if specified, as explained + below. + + The value of :share must be a symbol, with default nil. If the value + is nil, then an elided value will be printed using the next + available iprint index. The value :same is treated as though :share + had not been supplied. Otherwise, iprint sharing is on, which + provides the following behavior. Suppose that a value V is to be + elided that would be assigned the next available iprint index, N. + If an iprint index I < N is already associated with a value equal + to V, then ACL2 will print #@I for V instead of #@N. Thus, N will + remain the next available iprint index. This behavior is + implementing using a [fast-alist] that associates values with + indices; in our example, the [hons-copy] of V is associated with I. + If the value of :share is t then the name of this fast-alist --- + that is, its initial value --- is :iprint-fal; otherwise, the value + of :share (other than nil or :same is its name. This name is useful + when viewing the output of [fast-alist-summary]. Immediately after a top-level form is read, hence before it is evaluated, a check is made for whether the latest iprint index exceeds a certain bound, (iprint-soft-bound state) --- 1000, by - default. If so, then the (iprint-last-index state) is set back to - 0. This soft bound can be changed to any positive integer k by - calling set-iprint with :soft-bound k, typically (set-iprint :same + default. If so, then the (iprint-last-index state) is set back to 0 + so that the next iprint index that is generated will be 1. This + soft bound can be changed to any positive integer k by calling + set-iprint with :soft-bound k, for example: (set-iprint :same :soft-bound k)]. The above ``soft bound'' is applied once for each top-level form, but @@ -92289,17 +92372,20 @@ Example pretty-printed between successive evaluations of top-level forms). That bound is (iprint-hard-bound state), and can be set with the :hard-bound argument in analogy to how :soft-bound is set, as - described above. + described above, but with the effect of resetting iprinting, with + (iprint-last-index state) set back to 0. A ``rollover'' is the detection that the soft or hard bound has been - exceeded, along with a state update so that the next iprint index - will be 1. When a rollover occurs, any index beyond the latest - iprint index is no longer available for reading. At the top level - of the ACL2 read-eval-print loop, this works as follows: ACL2 reads - the next top-level form according to the current iprint state, then - handles a rollover if the latest iprint index exceeded the current - soft bound. The following log illustrates a rollover, which follows - the description above. + exceeded, along with a state update setting (iprint-last-index + state) to 0 so that the next iprint index will be 1. Immediately + before a rollover, any index beyond the last iprint index used + (which must be from before an earlier rollover) is no longer + available for reading. At the top level of the ACL2 read-eval-print + loop, this works as follows: ACL2 reads the next top-level form + according to the current iprint state, then handles a rollover if + the latest iprint index exceeded the current soft bound. The + following log illustrates a rollover, which follows the description + above. ACL2 !>(set-iprint t :soft-bound 3) @@ -92332,7 +92418,59 @@ Example Error: Out-of-bounds index in #@5#. See :DOC set-iprint. *********************************************** - If you didn't cause an explicit interrupt (Control-C), + The message above might explain the error. If not, and + if you didn't cause an explicit interrupt (Control-C), + then the root cause may be call of a :program mode + function that has the wrong guard specified, or even no + guard specified (i.e., an implicit guard of t). + See :DOC guards. + + To enable breaks into the debugger (also see :DOC acl2-customization): + (SET-DEBUGGER-ENABLE T) + ACL2 !> + + Rollover has the following additional effect when iprint sharing is + on: it is illegal to read a form that has both an index from before + the rollover and an index from after the rollover. The following + log illustrates this requirement. Note that if the last input form + below were read without error, the result would likely be highly + confusing, since iprint index 1 no longer refers to the value it + was originally given at the time the other iprint indices in the + input (2, 3, and 4) were given their values. + + ACL2 !>(set-iprint t :soft-bound 3 :share t) + + ACL2 Warning [Iprint] in SET-IPRINT: Converting SET-IPRINT action + from T to :RESET-ENABLE, as required by use of keyword :SHARE or :HARD- + BOUND. See :DOC set-iprint. + + + ACL2 Observation in SET-IPRINT: The soft-bound for iprinting has been + set to 3. + + ACL2 Observation in SET-IPRINT: Iprinting is enabled with sharing, + with a fast-alist whose name is :IPRINT-FAL. + + ACL2 Observation in SET-IPRINT: Iprinting has been reset and enabled. + ACL2 !>(set-evisc-tuple (evisc-tuple 2 3 nil nil) :sites :ld) + (:LD) + ACL2 !>'((a b c d) (x y z w)) + ((A B C . #@1#) (X Y Z . #@2#)) + ACL2 !>'((e f g h) (k l m n)) + ((E F G . #@3#) (K L M . #@4#)) + ACL2 !>'(#@1# #@2# #@3# #@4#) ; OK, since rollover occurs after the read + ((D) (W) (H) . #@1#) + ACL2 !>'(#@1# #@2# #@3# #@4#) + + *********************************************** + ************ ABORTING from raw Lisp *********** + Error: Attempt to read a form containing both an index + created before the most recent rollover (#@2#) and + an index created after that rollover (#@1#). See :DOC set-iprint. + *********************************************** + + The message above might explain the error. If not, and + if you didn't cause an explicit interrupt (Control-C), then the root cause may be call of a :program mode function that has the wrong guard specified, or even no guard specified (i.e., an implicit guard of t). @@ -98909,7 +99047,7 @@ List of a few ACL2 system utilities: such that for some f in the list, names, u is a subterm of the pseudo-term, term, that is a call of the symbol, f. Note that (all-calls-lst names lst alist ans) is similar, except for a - list, list, of terms in place of a single term, term. + list, lst, of terms in place of a single term, term. * (all-vars x): For a [pseudo-termp] x, return the list of variables in x in reverse print order of first occurrence. For example, all-vars of '(f (g a b) c) is '(c b a). diff --git a/rewrite.lisp b/rewrite.lisp index efe4d428be7..05e551574dc 100644 --- a/rewrite.lisp +++ b/rewrite.lisp @@ -7093,7 +7093,7 @@ (t (lookup-brr-stack var-name (cdr stack)))))))) (defun clean-brr-stack1 (gstack stack) - (cond ((null stack) + (cond ((endp stack) nil) ((equal gstack (caar stack)) stack) (t (clean-brr-stack1 gstack (cdr stack))))) diff --git a/type-set-b.lisp b/type-set-b.lisp index 20e2cd66ed1..d27d5e1cc54 100644 --- a/type-set-b.lisp +++ b/type-set-b.lisp @@ -90,7 +90,9 @@ ; Like assoc-equal but compares against the cdr of each pair in alist. - (cond ((null alist) nil) + (declare (xargs :mode :logic ; might as well put this into :logic mode + :guard (alistp alist))) + (cond ((endp alist) nil) ((equal x (cdar alist)) (car alist)) (t (assoc-equal-cdr x (cdr alist))))) From c853a3fd5e060d633de2eecbfb39605afa22f285 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sat, 23 Jul 2016 21:37:11 -0700 Subject: [PATCH 24/70] Simplify implementation of SOFT. Avoid storing the quantifier of a DEFUN-SK2 in the table of second-order functions, since the quantifier can be retrieved via the DEFUN-SK query utilities. --- books/kestrel/soft/implementation.lisp | 25 +++++++------------------ 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index 81e8c124d77..a7bba857ba4 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -146,10 +146,6 @@ bvars (no-duplicatesp bvars))) -(define quantifierp (quant) - (or (eq quant 'acl2::forall) - (eq quant 'acl2::exists))) - (define plain-sofun-infop (info (w plist-worldp)) :verify-guards nil (and (true-listp info) @@ -168,11 +164,10 @@ (define quant-sofun-infop (info (w plist-worldp)) :verify-guards nil (and (true-listp info) - (= (len info) 4) + (= (len info) 3) (sofun-kindp (first info)) (funvar-setp (second info) w) - (bound-varsp (third info)) - (quantifierp (fourth info)))) + (bound-varsp (third info)))) (define sofun-infop (info (w plist-worldp)) :verify-guards nil @@ -221,12 +216,6 @@ (let ((table (table-alist 'second-order-functions w))) (third (cdr (assoc-eq sofun table))))) -(define sofun-quantifier (sofun (w plist-worldp)) - :guard (quant-sofunp sofun w) - :verify-guards nil - (let ((table (table-alist 'second-order-functions w))) - (fourth (cdr (assoc-eq sofun table))))) - ; A term may reference a function variable directly ; (when the function variable occurs in the term) ; or indirectly @@ -556,16 +545,15 @@ (raise "~x0 must be a list of symbols." params)) ((unless (and (consp body) (= (len body) 3) - (quantifierp (first body)) + (acl2::defun-sk-quantifier-p (first body)) (or (symbolp (second body)) (symbol-listp (second body))))) (raise "~x0 must be a quantified formula." body)) ((unless (keyword-value-listp options)) (raise "~x0 must be a list of keyed options." options)) - (quant (first body)) (bvars (second body)) (bvars (if (symbolp bvars) (list bvars) bvars)) - (info (list 'quant fparams bvars quant))) + (info (list 'quant fparams bvars))) `(progn (defun-sk ,sofun ,params ,body ,@options) (table second-order-functions ',sofun ',info) @@ -1276,7 +1264,8 @@ (sofun-info (acl2::defun-sk-check sofun w)) ;; retrieve bound variables and quantifier of SOFUN: (bound-vars (sofun-bound-vars sofun w)) - (quant (sofun-quantifier sofun w)) + (quant (acl2::defun-sk-info->quantifier + (acl2::defun-sk-check sofun w))) ;; apply instantiation to the matrix of SOFUN: (sofun-matrix (acl2::defun-sk-info->matrix sofun-info)) (fun-matrix (fun-subst-term inst sofun-matrix w)) @@ -1308,7 +1297,7 @@ (wit-dcl `(declare (xargs :guard ,fun-guard :verify-guards nil))) ;; info about FUN to add to the table of second-order functions ;; (if FUN is second-order): - (info (list 'quant fparams bound-vars quant)) + (info (list 'quant fparams bound-vars)) ;; singleton list of event to add FUN ;; to the table of second-order functions, ;; or NIL if FUN is first-order: From e54f0fc5fc2db3fe7b99b69caa5a71e1f30079de Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sat, 23 Jul 2016 21:59:33 -0700 Subject: [PATCH 25/70] Simplify implementation of SOFT. Avoid storing the bound variables of a DEFCHOOSE2 or DEFUN-SK2 into the table of second-order functions, since the bound variables can be retrieved via the DEFUN-SK query utilities and DEFCHOOSE query utilities. --- books/kestrel/soft/implementation.lisp | 63 ++++---------------------- 1 file changed, 9 insertions(+), 54 deletions(-) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index a7bba857ba4..6a33fb7e9b2 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -130,51 +130,14 @@ ; like a first-order function). ; A table associates to each second-order function name ; its kind and the set of its function parameters. -; In addition, the table associates -; to each choice or quantifier second-order function name -; its list of bound variables. -; In addition, the table associates -; to each quantifier second-order function name -; its quantifier (FORALL or EXISTS) -; and the kind of its rewrite rule -; (default, direct, or custom term; -; the custom term itself is not recorded in the table, -; just the fact that it is a custom term is recorded). - -(define bound-varsp (bvars) - (and (symbol-listp bvars) - bvars - (no-duplicatesp bvars))) - -(define plain-sofun-infop (info (w plist-worldp)) + +(define sofun-infop (info (w plist-worldp)) :verify-guards nil (and (true-listp info) (= (len info) 2) (sofun-kindp (first info)) (funvar-setp (second info) w))) -(define choice-sofun-infop (info (w plist-worldp)) - :verify-guards nil - (and (true-listp info) - (= (len info) 3) - (sofun-kindp (first info)) - (funvar-setp (second info) w) - (bound-varsp (third info)))) - -(define quant-sofun-infop (info (w plist-worldp)) - :verify-guards nil - (and (true-listp info) - (= (len info) 3) - (sofun-kindp (first info)) - (funvar-setp (second info) w) - (bound-varsp (third info)))) - -(define sofun-infop (info (w plist-worldp)) - :verify-guards nil - (or (plain-sofun-infop info w) - (choice-sofun-infop info w) - (quant-sofun-infop info w))) - (table second-order-functions nil nil :guard (and (symbolp acl2::key) ; name (sofun-infop acl2::val world))) @@ -209,13 +172,6 @@ (let ((table (table-alist 'second-order-functions w))) (second (cdr (assoc-eq sofun table))))) -(define sofun-bound-vars (sofun (w plist-worldp)) - :guard (or (choice-sofunp sofun w) - (quant-sofunp sofun w)) - :verify-guards nil - (let ((table (table-alist 'second-order-functions w))) - (third (cdr (assoc-eq sofun table))))) - ; A term may reference a function variable directly ; (when the function variable occurs in the term) ; or indirectly @@ -476,7 +432,7 @@ (raise "~x0 must be a non-empty list of function variables ~ without duplicates." fparams)) - (info (list 'choice fparams (if (symbolp bvars) (list bvars) bvars)))) + (info (list 'choice fparams))) `(progn (defchoose ,sofun ,bvars ,params ,body ,@options) (table second-order-functions ',sofun ',info) @@ -551,9 +507,7 @@ (raise "~x0 must be a quantified formula." body)) ((unless (keyword-value-listp options)) (raise "~x0 must be a list of keyed options." options)) - (bvars (second body)) - (bvars (if (symbolp bvars) (list bvars) bvars)) - (info (list 'quant fparams bvars))) + (info (list 'quant fparams))) `(progn (defun-sk ,sofun ,params ,body ,@options) (table second-order-functions ',sofun ',info) @@ -1231,13 +1185,13 @@ (choice-sofunp sofun w)) :mode :program (b* (;; retrieve bound variables of SOFUN: - (bound-vars (sofun-bound-vars sofun w)) + (bound-vars (acl2::defchoose-bound-vars sofun w)) ;; apply instantiation to body of SOFUN: (sofun-body (acl2::defchoose-body sofun w)) (fun-body (fun-subst-term inst sofun-body w)) ;; info about FUN to add to the table of second-order functions ;; (if FUN is second-order): - (info (list 'choice fparams bound-vars)) + (info (list 'choice fparams)) ;; singleton list of event to add FUN ;; to the table of second-order functions, ;; or NIL if FUN is first-order: @@ -1263,7 +1217,8 @@ (b* (;; retrieve DEFUN-SK-specific constituents of SOFUN: (sofun-info (acl2::defun-sk-check sofun w)) ;; retrieve bound variables and quantifier of SOFUN: - (bound-vars (sofun-bound-vars sofun w)) + (bound-vars (acl2::defun-sk-info->bound-vars + (acl2::defun-sk-check sofun w))) (quant (acl2::defun-sk-info->quantifier (acl2::defun-sk-check sofun w))) ;; apply instantiation to the matrix of SOFUN: @@ -1297,7 +1252,7 @@ (wit-dcl `(declare (xargs :guard ,fun-guard :verify-guards nil))) ;; info about FUN to add to the table of second-order functions ;; (if FUN is second-order): - (info (list 'quant fparams bound-vars)) + (info (list 'quant fparams)) ;; singleton list of event to add FUN ;; to the table of second-order functions, ;; or NIL if FUN is first-order: From 664486fa46d6cd29f9f3621db9ecad320c663ccf Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sun, 24 Jul 2016 15:13:09 -0700 Subject: [PATCH 26/70] Simplify implementation of world query utility. Now RECURSIVE-CALLS is defined as a suitable call to TERMINATION-MACHINE, instead of retrieving the induction machine and "flattening" it. --- books/kestrel/system/world-queries.lisp | 43 +++---------------------- 1 file changed, 4 insertions(+), 39 deletions(-) diff --git a/books/kestrel/system/world-queries.lisp b/books/kestrel/system/world-queries.lisp index eb2f1c46bb6..11f9292271f 100644 --- a/books/kestrel/system/world-queries.lisp +++ b/books/kestrel/system/world-queries.lisp @@ -369,8 +369,8 @@ (logicp fn wrld) (eql 1 (len (recursivep fn nil wrld))))) (wrld plist-worldp)) - ;; :returns (calls-with-tests pseudo-tests-and-call-listp) - :verify-guards nil + :returns (calls-with-tests pseudo-tests-and-call-listp) + :prepwork ((program)) :short "Recursive calls of a (singly) recursive function, along with the controlling tests." @@ -380,43 +380,8 @@ but each record has one recursive calls (instead of zero or more), and there is exactly one record for each recursive call.

    " - (recursive-calls-aux2 (induction-machine fn wrld)) - - :prepwork - - ((define recursive-calls-aux1 ((tests pseudo-term-listp) - (calls pseudo-term-listp)) - ;; :returns (calls-with-tests pseudo-tests-and-call-listp) - :parents (recursive-calls) - :short "First auxiliary function of @(tsee recursive-calls)." - :long - "

    - Pair each call in @('calls') with the tests @('tests'). -

    " - (if (endp calls) - nil - (cons (make tests-and-call - :tests tests - :call (car calls)) - (recursive-calls-aux1 tests (cdr calls))))) - - (define recursive-calls-aux2 - ((tests-and-calls-list pseudo-tests-and-calls-listp)) - ;; :returns (calls-with-tests pseudo-tests-and-call-listp) - :verify-guards nil - :parents (recursive-calls) - :short "Second auxiliary function of @(tsee recursive-calls)." - :long - "

    - Collect all the calls, with tests, from the induction machine. -

    " - (if (endp tests-and-calls-list) - nil - (let* ((tests-and-calls (car tests-and-calls-list)) - (tests (access tests-and-calls tests-and-calls :tests)) - (calls (access tests-and-calls tests-and-calls :calls))) - (append (recursive-calls-aux1 tests calls) - (recursive-calls-aux2 (cdr tests-and-calls-list)))))))) + (termination-machine + (list fn) (body fn nil wrld) nil nil (ruler-extenders fn wrld))) (std::deflist pseudo-event-landmark-listp (x) (pseudo-event-landmarkp x) From 000711cbf7ab7bf25a347ef7107be411cb14f4ef Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sun, 24 Jul 2016 18:25:45 -0700 Subject: [PATCH 27/70] Simplify documentation of system utility. Remove topic that had just one child, putting that child directly under the kestrel-system-utilities topic. --- books/kestrel/system/fresh-names.lisp | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/books/kestrel/system/fresh-names.lisp b/books/kestrel/system/fresh-names.lisp index d0113de338c..5a7c54ed2bf 100644 --- a/books/kestrel/system/fresh-names.lisp +++ b/books/kestrel/system/fresh-names.lisp @@ -8,8 +8,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; This file provides utilities for generating fresh names, -; i.e. names that do not already occur in the world, in terms, etc. +; This file provides utilities for generating fresh names. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -19,16 +18,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defsection fresh-names - :parents (kestrel-system-utilities system-utilities) - :short "Utilities for generating fresh names.") - (define fresh-name-in-world-with-$s ((name symbolp) (names-to-avoid symbol-listp) (wrld plist-worldp)) :returns (fresh-name symbolp) :prepwork ((program)) - :parents (fresh-names) + :parents (kestrel-system-utilities system-utilities) :short "Append as many @('$') signs to @('name') as needed to make the name new in the world, i.e. not already in use, From 1bf2c033034544a4e9c768dccb01d1500b4e0f9e Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sun, 24 Jul 2016 19:11:46 -0700 Subject: [PATCH 28/70] Group testing utilities under new topic. The MUST-BE-REDUNDANT, MUST-FAIL-LOCAL, and MUST-SUCCEED* testing utilities are not under a new testing-utilities topic, which is under the kestrel-general-utilities topic. --- books/kestrel/general/testing.lisp | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/books/kestrel/general/testing.lisp b/books/kestrel/general/testing.lisp index d40620d4154..f4f1ec17d77 100644 --- a/books/kestrel/general/testing.lisp +++ b/books/kestrel/general/testing.lisp @@ -10,8 +10,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; This file contains macros for building tests, -; related to MUST-SUCCEED and MUST-FAIL. +; This file provides utilities for building tests. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -21,13 +20,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defxdoc testing-utilities + :parents (kestrel-general-utilities) + :short "Utilities for building tests.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defsection must-succeed* - :parents (kestrel-general-utilities errors) + :parents (testing-utilities errors) - :short "A variant of @(tsee must-succeed) that takes multiple forms." + :short "A variant of @(tsee must-succeed) that accepts multiple forms." :long + "@({ (must-succeed* form1 ... @@ -35,6 +41,7 @@ :with-output-off ... :check-expansion ...) }) +

    The @('N') forms must be embedded event forms, @@ -50,11 +57,13 @@ before considering later forms as in @(tsee must-succeed*).

    +

    The forms may be followed by @(':with-output-off') and/or @(':check-expansion'), as in @(tsee must-succeed).

    + @(def must-succeed*)" (defmacro must-succeed* (&rest args) @@ -80,17 +89,19 @@ (defsection must-be-redundant - :parents (kestrel-general-utilities errors) + :parents (testing-utilities errors) :short "A top-level @(tsee assert$)-like command to ensure that given forms are redundant." :long + "

    The forms are put into an @(tsee encapsulate), along with a @(tsee set-enforce-redundancy) command that precedes them.

    + @(def must-be-redundant)" (defmacro must-be-redundant (&rest forms) @@ -103,15 +114,17 @@ (defsection must-fail-local - :parents (kestrel-general-utilities errors) + :parents (testing-utilities errors) :short "A @(see local) variant of @(tsee must-fail)." :long + "

    This is useful to overcome the problem discussed in the caveat in the documentation of @(tsee must-fail).

    + @(def must-fail-local)" (defmacro must-fail-local (&rest args) From 7e9eddb1880c6044d22a1f8ff9f473d968ba83ee Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sun, 24 Jul 2016 23:08:06 -0700 Subject: [PATCH 29/70] Add some miscellaneous types. These are a few enumerations (introduced via STD::DEFENUM), plus the type of NIL-terminated alists from symbols to symbols (introduced via STD::DEFALIST). The latter was previously in a file alists.lisp, which has been now removed (it only contained that type). --- books/kestrel/general/alists-tests.lisp | 33 --------------- books/kestrel/general/alists.lisp | 28 ------------- books/kestrel/general/top.lisp | 2 +- books/kestrel/general/types.lisp | 53 +++++++++++++++++++++++++ 4 files changed, 54 insertions(+), 62 deletions(-) delete mode 100644 books/kestrel/general/alists-tests.lisp delete mode 100644 books/kestrel/general/alists.lisp create mode 100644 books/kestrel/general/types.lisp diff --git a/books/kestrel/general/alists-tests.lisp b/books/kestrel/general/alists-tests.lisp deleted file mode 100644 index 6c1f5215f17..00000000000 --- a/books/kestrel/general/alists-tests.lisp +++ /dev/null @@ -1,33 +0,0 @@ -; Alist Utilities -- Tests -; -; Copyright (C) 2016 Kestrel Institute (http://www.kestrel.edu) -; -; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. -; -; Author: Alessandro Coglio (coglio@kestrel.edu) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; This file provides some tests for the alist utilities in alists.lisp. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(in-package "ACL2") - -(include-book "alists") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(assert-event (symbol-symbol-alistp nil)) - -(assert-event (symbol-symbol-alistp '((a . b)))) - -(assert-event (symbol-symbol-alistp '((t . nil) (:logic . :program)))) - -(assert-event (not (symbol-symbol-alistp 3))) - -(assert-event (not (symbol-symbol-alistp '(3)))) - -(assert-event (not (symbol-symbol-alistp '((x . y) (2/3 . nil))))) - -(assert-event (not (symbol-symbol-alistp '((xx . yy) (t . "nil"))))) diff --git a/books/kestrel/general/alists.lisp b/books/kestrel/general/alists.lisp deleted file mode 100644 index 287aa26ec6d..00000000000 --- a/books/kestrel/general/alists.lisp +++ /dev/null @@ -1,28 +0,0 @@ -; Alist Utilities -; -; Copyright (C) 2016 Kestrel Institute (http://www.kestrel.edu) -; -; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. -; -; Author: Alessandro Coglio (coglio@kestrel.edu) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; This file provides some alist utilities. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(in-package "ACL2") - -(include-book "std/util/defalist" :dir :system) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(std::defalist symbol-symbol-alistp (x) - :key (symbolp x) - :val (symbolp x) - :parents (kestrel-general-utilities alists) - :short "Recognize @('nil')-terminated alists from symbols to symbols." - :keyp-of-nil t - :valp-of-nil t - :true-listp t) diff --git a/books/kestrel/general/top.lisp b/books/kestrel/general/top.lisp index ce13e30df25..308eef74eac 100644 --- a/books/kestrel/general/top.lisp +++ b/books/kestrel/general/top.lisp @@ -14,10 +14,10 @@ (in-package "ACL2") -(include-book "alists") (include-book "auto-termination") (include-book "define-sk") (include-book "testing") +(include-book "types") (include-book "ubi") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/general/types.lisp b/books/kestrel/general/types.lisp new file mode 100644 index 00000000000..283ce2f6fa4 --- /dev/null +++ b/books/kestrel/general/types.lisp @@ -0,0 +1,53 @@ +; Miscellaneous Types +; +; Copyright (C) 2015-2016 Kestrel Institute (http://www.kestrel.edu) +; +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. +; +; Author: Alessandro Coglio (coglio@kestrel.edu) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; This file provides some miscellaneous types. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(include-book "std/util/defalist" :dir :system) +(include-book "std/util/defenum" :dir :system) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defxdoc miscellaneous-types + :parents (kestrel-general-utilities) + :short "Some miscellaneous types.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(std::defalist symbol-symbol-alistp (x) + :key (symbolp x) + :val (symbolp x) + :parents (miscellaneous-types alists) + :short "Recognize @('nil')-terminated alists from symbols to symbols." + :keyp-of-nil t + :valp-of-nil t + :true-listp t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(std::defenum logic/program-p (:logic :program) + :parents (miscellaneous-types) + :short "Recognize @(see defun-mode)s.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(std::defenum logic/program/auto-p (:logic :program :auto) + :parents (miscellaneous-types) + :short "Recognize @(see defun-mode)s and @(':auto').") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(std::defenum t/nil/auto-p (t nil :auto) + :parents (miscellaneous-types) + :short "Recognize booleans and @(':auto').") From 4dc119f6cf11068ccc924605fe81fc3f6cfe5eaa Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Mon, 25 Jul 2016 12:00:41 -0700 Subject: [PATCH 30/70] Improve implementation of SOFT. Use the :TERMINATION-THEOREM of a recursive second-order function to prove the termination of its instances, instead of relying on the termination theorem generated via the :T-PROOF option of DEFINE. --- books/kestrel/soft/implementation.lisp | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index 6a33fb7e9b2..1c625b11d3c 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -388,14 +388,6 @@ (defmacro acl2::show-defun2 (&rest args) `(show-defun2 ,@args)) -; The name of the termination theorem of a recursive second-order function -; is obtained by adding -T to the name of the function. - -(define sofun-termination-theorem-name ((sofun symbolp)) - (let* ((sofun-name (symbol-name sofun)) - (theorem-name (string-append sofun-name "-T"))) - (intern-in-package-of-symbol theorem-name sofun))) - ; The macro DEFCHOOSE2 introduces a choice second-order function. ; DEFCHOOSE2 has the form ; (DEFCHOOSE2 SOFUN (BVAR1 ... BVARm) (FVAR1 ... FVARn) (VAR1 ... VARp) @@ -1140,8 +1132,9 @@ (fun-measure (fun-subst-term inst sofun-measure w)) (fun-guard (fun-subst-term inst sofun-guard w)) ;; construct the termination proof from the instantiation, if recursive: - (sofun-tt-name (sofun-termination-theorem-name sofun)) - (sofun-tt-formula (formula sofun-tt-name nil w)) ; could be NIL + (sofun-tt-name `(:termination-theorem ,sofun)) + (sofun-tt-formula (and (acl2::recursivep sofun nil w) + (termination-theorem sofun w))) (fsbs (ext-fun-subst-term sofun-tt-formula inst w)) (fun-tt-proof (sothm-inst-proof sofun-tt-name fsbs w)) ;; :HINTS of FUN if recursive, otherwise NIL: From e700158484855370e2276a3ac4bc2b75669df203 Mon Sep 17 00:00:00 2001 From: "David L. Rager" Date: Mon, 25 Jul 2016 18:54:58 -0500 Subject: [PATCH 31/70] Fixing a typo --- books/system/doc/acl2-doc.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index 636ab5be1f3..17dfa2cab92 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -73592,7 +73592,7 @@ it." ; We made some technical changes in the implementation of iprinting. For one, ; we no longer compress iprint-ar when exiting a wormhole, since that array is ; already compressed. More important, we fixed a bug in the interaction -; between hard-bounds and rollovers, as noted in the :doc below. The folowing +; between hard-bounds and rollovers, as noted in the :doc below. The following ; caused a hard Lisp error but now works properly. ; ; (set-evisc-tuple (evisc-tuple 3 3 nil nil) :sites :all :iprint t) From 941ea58fdf845328f2124a6639f3cbc2bc5e42dc Mon Sep 17 00:00:00 2001 From: Shilpi Goel Date: Tue, 26 Jul 2016 00:36:48 -0500 Subject: [PATCH 32/70] x86isa: rm08 and wm08 are also defined in terms of rb and wb now Lemmas rm08-to-rb and wm08-to-wb don't need to exist anymore. --- .../x86isa/machine/x86-top-level-memory.lisp | 661 +++++++++--------- .../factorial/fact-inductive-assertions.lisp | 12 +- .../factorial/fact-wormhole-abstraction.lisp | 14 +- .../utilities/general-memory-utils.lisp | 9 +- .../programmer-level-memory-utils.lisp | 100 ++- .../system-level-mode/marking-mode-top.lisp | 1 - .../system-level-mode/marking-mode-utils.lisp | 74 +- .../non-marking-mode-top.lisp | 20 +- .../projects/x86isa/proofs/wordCount/wc.lisp | 8 +- .../zeroCopy/marking-mode/zeroCopy.lisp | 1 - 10 files changed, 474 insertions(+), 426 deletions(-) diff --git a/books/projects/x86isa/machine/x86-top-level-memory.lisp b/books/projects/x86isa/machine/x86-top-level-memory.lisp index 27e88513f63..9efdf062d54 100644 --- a/books/projects/x86isa/machine/x86-top-level-memory.lisp +++ b/books/projects/x86isa/machine/x86-top-level-memory.lisp @@ -169,7 +169,7 @@ memory. ;; ====================================================================== -;; Some misc. arithmetic lemmas: +;; Some misc. arithmetic lemmas and macros: (defthm signed-byte-p-limits-thm ;; i is positive, k is positive, k < i @@ -189,276 +189,12 @@ memory. (acl2::set-waterfall-parallelism t) -;; ====================================================================== - (defabbrev cpl (x86) (the (unsigned-byte 2) (seg-sel-layout-slice :rpl (the (unsigned-byte 16) (xr :seg-visible *cs* x86))))) ;; ====================================================================== -(define rm08 - ((lin-addr :type (signed-byte #.*max-linear-address-size*)) - (r-w-x :type (member :r :w :x)) - (x86)) - - :parents (x86-top-level-memory) - :guard (canonical-address-p lin-addr) - - (if (programmer-level-mode x86) - - (rvm08 lin-addr x86) - - (b* ((cpl (cpl x86)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr) x86) - (la-to-pa lin-addr r-w-x cpl x86)) - ((when flag) - (mv flag 0 x86)) - (byte (the (unsigned-byte 8) (memi p-addr x86)))) - (mv nil byte x86))) - - /// - - (defthm-usb n08p-mv-nth-1-rm08 - :hyp (and (signed-byte-p *max-linear-address-size* lin-addr) - (x86p x86)) - :bound 8 - :concl (mv-nth 1 (rm08 lin-addr r-w-x x86)) - :hints (("Goal" :in-theory (e/d () (unsigned-byte-p)))) - :gen-linear t - :hints-l (("Goal" :in-theory (e/d (unsigned-byte-p) ()))) - ;; If the hyps in the :type-prescription corollary aren't forced, - ;; we run into natp vs integerp/<= 0.. problems. - :hyp-t (forced-and (integerp lin-addr) - (x86p x86)) - :gen-type t) - - (defthm x86p-rm08 - (implies (force (x86p x86)) - (x86p (mv-nth 2 (rm08 lin-addr r-w-x x86)))) - :rule-classes (:rewrite :type-prescription)) - - (defthm rm08-value-when-error - (implies (mv-nth 0 (rm08 addr :x x86)) - (equal (mv-nth 1 (rm08 addr :x x86)) 0)) - :hints (("Goal" :in-theory (e/d (rvm08) (force (force)))))) - - (defthm rm08-does-not-affect-state-in-programmer-level-mode - (implies (programmer-level-mode x86) - (equal (mv-nth 2 (rm08 start-rip :x x86)) - x86)) - :hints (("Goal" :in-theory (e/d (rvm08) ())))) - - (defthm programmer-level-mode-rm08-no-error - (implies (and (programmer-level-mode x86) - (canonical-address-p addr)) - (and (equal (mv-nth 0 (rm08 addr r-w-x x86)) - nil) - (equal (mv-nth 1 (rm08 addr :x x86)) - (memi (loghead 48 addr) x86)) - (equal (mv-nth 2 (rm08 addr r-w-x x86)) - x86))) - :hints (("Goal" :in-theory (e/d (rvm08) ())))) - - (defthm xr-rm08-state-in-programmer-level-mode - (implies (and (programmer-level-mode x86) - (not (equal fld :mem))) - (equal (xr fld index (mv-nth 2 (rm08 addr r-w-x x86))) - (xr fld index x86))) - :hints (("Goal" :in-theory (e/d* () (force (force)))))) - - (defthm xr-rm08-state-in-system-level-mode - (implies (and (not (programmer-level-mode x86)) - (not (equal fld :mem)) - (not (equal fld :fault))) - (equal (xr fld index (mv-nth 2 (rm08 addr r-w-x x86))) - (xr fld index x86))) - :hints (("Goal" :in-theory (e/d* () (force (force)))))) - - (defthm rm08-xw-programmer-level-mode - (implies (and (programmer-level-mode x86) - (not (equal fld :mem)) - (not (equal fld :programmer-level-mode))) - (and (equal (mv-nth 0 (rm08 addr r-w-x (xw fld index value x86))) - (mv-nth 0 (rm08 addr r-w-x x86))) - (equal (mv-nth 1 (rm08 addr r-w-x (xw fld index value x86))) - (mv-nth 1 (rm08 addr r-w-x x86))) - ;; No need for the conclusion about the state because - ;; "rm08-does-not-affect-state-in-programmer-level-mode". - )) - :hints (("Goal" :in-theory (e/d* (rvm08) ())))) - - (defthm rm08-xw-system-mode - (implies (and (not (programmer-level-mode x86)) - (not (equal fld :fault)) - (not (equal fld :seg-visible)) - (not (equal fld :mem)) - (not (equal fld :ctr)) - (not (equal fld :msr)) - (not (equal fld :rflags)) - (not (equal fld :programmer-level-mode)) - (not (equal fld :page-structure-marking-mode))) - (and (equal (mv-nth 0 (rm08 addr r-w-x (xw fld index value x86))) - (mv-nth 0 (rm08 addr r-w-x x86))) - (equal (mv-nth 1 (rm08 addr r-w-x (xw fld index value x86))) - (mv-nth 1 (rm08 addr r-w-x x86))) - (equal (mv-nth 2 (rm08 addr r-w-x (xw fld index value x86))) - (xw fld index value (mv-nth 2 (rm08 addr r-w-x x86))))))) - - (defthm rm08-xw-system-mode-rflags-not-ac - (implies (and (not (programmer-level-mode x86)) - (equal (rflags-slice :ac value) - (rflags-slice :ac (rflags x86)))) - (and (equal (mv-nth 0 (rm08 addr r-w-x (xw :rflags 0 value x86))) - (mv-nth 0 (rm08 addr r-w-x x86))) - (equal (mv-nth 1 (rm08 addr r-w-x (xw :rflags 0 value x86))) - (mv-nth 1 (rm08 addr r-w-x x86))) - (equal (mv-nth 2 (rm08 addr r-w-x (xw :rflags 0 value x86))) - (xw :rflags 0 value (mv-nth 2 (rm08 addr r-w-x x86))))))) - - (defthm mv-nth-2-rm08-in-system-level-non-marking-mode - (implies (and (not (programmer-level-mode x86)) - (not (page-structure-marking-mode x86)) - (x86p x86) - (not (mv-nth 0 (rm08 lin-addr r-w-x x86)))) - (equal (mv-nth 2 (rm08 lin-addr r-w-x x86)) - x86)))) - -(define rim08 - ((lin-addr :type (signed-byte #.*max-linear-address-size*)) - (r-w-x :type (member :r :w :x)) - (x86)) - - :parents (x86-top-level-memory) - :guard (canonical-address-p lin-addr) - - (mv-let (flag val x86) - (rm08 lin-addr r-w-x x86) - (mv flag (n08-to-i08 val) x86)) - /// - - (defthm-sb i08p-mv-nth-1-rim08 - :hyp (and (signed-byte-p *max-linear-address-size* lin-addr) - (x86p x86)) - :bound 8 - :concl (mv-nth 1 (rim08 lin-addr r-w-x x86)) - :hints (("Goal" :in-theory (e/d () (signed-byte-p)))) - :gen-linear t - :hints-l (("Goal" :in-theory (e/d (signed-byte-p) ()))) - :hyp-t (forced-and (integerp lin-addr) - (x86p x86)) - :gen-type t) - - (defthm x86p-rim08 - (implies (force (x86p x86)) - (x86p (mv-nth 2 (rim08 lin-addr r-w-x x86)))) - :rule-classes (:rewrite :type-prescription))) - -(define wm08 - ((lin-addr :type (signed-byte #.*max-linear-address-size*)) - (val :type (unsigned-byte 8)) - (x86)) - - :parents (x86-top-level-memory) - :guard (canonical-address-p lin-addr) - - (if (programmer-level-mode x86) - - (wvm08 lin-addr val x86) - - (b* ((cpl (cpl x86)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr) x86) - (la-to-pa lin-addr :w cpl x86)) - ((when flag) - (mv flag x86)) - (byte (mbe :logic (n08 val) - :exec val)) - (x86 (!memi p-addr byte x86))) - (mv nil x86))) - - /// - - (defthm x86p-wm08 - (implies (force (x86p x86)) - (x86p (mv-nth 1 (wm08 lin-addr val x86)))) - :hints (("Goal" :in-theory (e/d () (force (force))))) - :rule-classes (:rewrite :type-prescription)) - - (defthm programmer-level-mode-wm08-no-error - (implies (and (programmer-level-mode x86) - (canonical-address-p addr)) - (equal (mv-nth 0 (wm08 addr val x86)) - nil)) - :hints (("Goal" :in-theory (e/d (wm08 wvm08) ())))) - - (defthm xr-wm08-programmer-level-mode - (implies (and (programmer-level-mode x86) - (not (equal fld :mem))) - (equal (xr fld index (mv-nth 1 (wm08 addr val x86))) - (xr fld index x86))) - :hints (("Goal" :in-theory (e/d* (wvm08) ())))) - - (defthm xr-wm08-system-level-mode - (implies (and (not (programmer-level-mode x86)) - (not (equal fld :mem)) - (not (equal fld :fault))) - (equal (xr fld index (mv-nth 1 (wm08 addr val x86))) - (xr fld index x86))) - :hints (("Goal" :in-theory (e/d* () (force (force)))))) - - (defthm wm08-xw-programmer-level-mode - (implies (and (programmer-level-mode x86) - (not (equal fld :mem)) - (not (equal fld :programmer-level-mode))) - (and (equal (mv-nth 0 (wm08 addr val (xw fld index value x86))) - (mv-nth 0 (wm08 addr val x86))) - (equal (mv-nth 1 (wm08 addr val (xw fld index value x86))) - (xw fld index value (mv-nth 1 (wm08 addr val x86)))))) - :hints (("Goal" :in-theory (e/d* (wm08 wvm08) ())))) - - (defthm wm08-xw-system-mode - (implies (and (not (programmer-level-mode x86)) - (not (equal fld :fault)) - (not (equal fld :seg-visible)) - (not (equal fld :mem)) - (not (equal fld :ctr)) - (not (equal fld :rflags)) - (not (equal fld :msr)) - (not (equal fld :programmer-level-mode)) - (not (equal fld :page-structure-marking-mode))) - (and (equal (mv-nth 0 (wm08 addr val (xw fld index value x86))) - (mv-nth 0 (wm08 addr val x86))) - (equal (mv-nth 1 (wm08 addr val (xw fld index value x86))) - (xw fld index value (mv-nth 1 (wm08 addr val x86)))))) - :hints (("Goal" :in-theory (e/d* () (force (force)))))) - - (defthm wm08-xw-system-mode-rflags-not-ac - (implies (and (not (programmer-level-mode x86)) - (equal (rflags-slice :ac value) - (rflags-slice :ac (rflags x86)))) - (and (equal (mv-nth 0 (wm08 addr val (xw :rflags 0 value x86))) - (mv-nth 0 (wm08 addr val x86))) - (equal (mv-nth 1 (wm08 addr val (xw :rflags 0 value x86))) - (xw :rflags 0 value (mv-nth 1 (wm08 addr val x86)))))) - :hints (("Goal" :in-theory (e/d* () (force (force))))))) - -(define wim08 - ((lin-addr :type (signed-byte #.*max-linear-address-size*)) - (val :type (signed-byte 8)) - (x86)) - - :parents (x86-top-level-memory) - :guard (canonical-address-p lin-addr) - - (wm08 lin-addr (the (unsigned-byte 8) (n08 val)) x86) - /// - (defthm x86p-wim08 - (implies (force (x86p x86)) - (x86p (mv-nth 1 (wim08 lin-addr val x86)))) - :rule-classes (:rewrite :type-prescription))) - -;; ====================================================================== - #|| ;; Unraveling nests of loghead: @@ -1016,8 +752,10 @@ memory. (if (endp addresses) (mv nil acc x86) (b* ((addr (car addresses)) + ;; rb-1 is used only in the programmer-level mode, so + ;; it makes sense to use rvm08 here. ((mv flg byte x86) - (rm08 addr r-w-x x86)) + (rvm08 addr x86)) ((when flg) (mv flg acc x86))) (rb-1 (cdr addresses) r-w-x x86 (append acc (list byte))))) @@ -1039,15 +777,14 @@ memory. (defthm rb-1-returns-x86-programmer-level-mode (implies (programmer-level-mode x86) (equal (mv-nth 2 (rb-1 addresses r-w-x x86 acc)) - x86)) - :hints (("Goal" :in-theory (e/d (rm08) ())))) + x86))) (defthm rb-1-returns-no-error-programmer-level-mode (implies (and (canonical-address-listp addresses) (programmer-level-mode x86)) (equal (mv-nth 0 (rb-1 addresses r-w-x x86 acc)) nil)) - :hints (("Goal" :in-theory (e/d (rm08 rvm08) ())))) + :hints (("Goal" :in-theory (e/d (rvm08) ())))) (local (defthm rb-1-accumulator-thm-helper @@ -1345,8 +1082,7 @@ memory. (defthm rb-returns-x86-programmer-level-mode (implies (and (programmer-level-mode x86) (x86p x86)) - (equal (mv-nth 2 (rb addresses r-w-x x86)) x86)) - :hints (("Goal" :in-theory (e/d (rm08) ())))) + (equal (mv-nth 2 (rb addresses r-w-x x86)) x86))) (defthm len-of-rb-in-system-level-mode (implies (and (not (mv-nth 0 (las-to-pas l-addrs r-w-x (cpl x86) x86))) @@ -1484,7 +1220,9 @@ memory. (b* ((addr (caar addr-lst)) (byte (cdar addr-lst)) ((mv flg x86) - (wm08 addr byte x86)) + ;; wb-1 is used only in the programmer-level mode, so + ;; it makes sense to use wvm08 here. + (wvm08 addr byte x86)) ((when flg) (mv flg x86))) (wb-1 (cdr addr-lst) x86))) @@ -1502,7 +1240,7 @@ memory. (programmer-level-mode x86)) (equal (mv-nth 0 (wb-1 addr-lst x86)) nil)) - :hints (("Goal" :in-theory (e/d (wm08 wvm08) ()))))) + :hints (("Goal" :in-theory (e/d (wvm08) ()))))) (define write-to-physical-memory ((p-addrs physical-address-listp) @@ -1578,18 +1316,6 @@ memory. (local (in-theory (e/d () (force (force))))) - ;; Relating rb and rm08: - - (defthmd rb-and-rm08-in-programmer-level-mode - (implies (and (programmer-level-mode x86) - (canonical-address-p addr) - (x86p x86)) - (equal (rm08 addr r-w-x x86) - (mv (mv-nth 0 (rb (list addr) r-w-x x86)) - (combine-bytes (mv-nth 1 (rb (list addr) r-w-x x86))) - x86))) - :hints (("Goal" :in-theory (e/d (rm08 rvm08) ())))) - ;; Relating rb and xr/xw in the programmer-level mode: (defthm xr-rb-state-in-programmer-level-mode @@ -1784,15 +1510,6 @@ memory. (xw :rflags 0 value (mv-nth 2 (rb addr r-w-x x86))))) :hints (("Goal" :in-theory (e/d* (rb) (force (force)))))) - ;; Relating wb and wm08: - - (defthmd wb-and-wm08 - (implies (and (canonical-address-p addr) - (n08p val)) - (equal (wm08 addr val x86) - (wb (acons addr val nil) x86))) - :hints (("Goal" :in-theory (e/d (wm08 wvm08) (force (force)))))) - ;; Relating wb and xr/xw in the programmer-level mode: (defthm xr-wb-1-in-programmer-level-mode @@ -2296,9 +2013,10 @@ memory. (* 8 (len xs)))))) :hints (("Goal" :in-theory (e/d* (push-ash-inside-logior) ()))))) + ;; ====================================================================== -;; Defining the 16, 32, and 64, and 128 bit memory read/write +;; Defining the 8, 16, 32, and 64, and 128 bit memory read/write ;; functions: ;; I haven't used physical memory functions like rm-low-* and wm-low-* @@ -2311,6 +2029,295 @@ memory. ;; are long and ugly sequences of memi and !memi below instead of nice ;; and pretty wrappers. +(define rm08 + ((lin-addr :type (signed-byte #.*max-linear-address-size*)) + (r-w-x :type (member :r :w :x)) + (x86)) + + :parents (x86-top-level-memory) + :guard (canonical-address-p lin-addr) + :guard-hints (("Goal" :in-theory (e/d* (rvm08) ()))) + + (if (mbt (canonical-address-p lin-addr)) + + (mbe + + :logic + (b* (((mv flg bytes x86) + (rb (create-canonical-address-list 1 lin-addr) r-w-x x86)) + (result (combine-bytes bytes))) + (mv flg result x86)) + + :exec + (if (programmer-level-mode x86) + + (rvm08 lin-addr x86) + + (b* ((cpl (cpl x86)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr) x86) + (la-to-pa lin-addr r-w-x cpl x86)) + ((when flag) + (mv flag 0 x86)) + (byte (the (unsigned-byte 8) (memi p-addr x86)))) + (mv nil byte x86)))) + + (mv 'rm08 0 x86)) + + /// + + (defthm-usb n08p-mv-nth-1-rm08 + :hyp (and (signed-byte-p *max-linear-address-size* lin-addr) + (x86p x86)) + :bound 8 + :concl (mv-nth 1 (rm08 lin-addr r-w-x x86)) + :hints (("Goal" :in-theory (e/d () (unsigned-byte-p)))) + :gen-linear t + :hints-l (("Goal" :in-theory (e/d (unsigned-byte-p) ()))) + ;; If the hyps in the :type-prescription corollary aren't forced, + ;; we run into natp vs integerp/<= 0.. problems. + :hyp-t (forced-and (integerp lin-addr) + (x86p x86)) + :gen-type t) + + (defthm x86p-rm08 + (implies (force (x86p x86)) + (x86p (mv-nth 2 (rm08 lin-addr r-w-x x86)))) + :rule-classes (:rewrite :type-prescription)) + + (defthm rm08-value-when-error + (implies (mv-nth 0 (rm08 addr :x x86)) + (equal (mv-nth 1 (rm08 addr :x x86)) 0)) + :hints (("Goal" :in-theory (e/d (rvm08) (force (force)))))) + + (defthm rm08-does-not-affect-state-in-programmer-level-mode + (implies (programmer-level-mode x86) + (equal (mv-nth 2 (rm08 start-rip :x x86)) + x86)) + :hints (("Goal" :in-theory (e/d (rvm08) (force (force)))))) + + (defthm programmer-level-mode-rm08-no-error + (implies (and (programmer-level-mode x86) + (canonical-address-p addr) + (x86p x86)) + (and (equal (mv-nth 0 (rm08 addr r-w-x x86)) + nil) + (equal (mv-nth 1 (rm08 addr :x x86)) + (memi (loghead 48 addr) x86)) + (equal (mv-nth 2 (rm08 addr r-w-x x86)) + x86))) + :hints (("Goal" :in-theory (e/d (rvm08) (force (force)))))) + + (defthm xr-rm08-state-in-programmer-level-mode + (implies (and (programmer-level-mode x86) + (not (equal fld :mem))) + (equal (xr fld index (mv-nth 2 (rm08 addr r-w-x x86))) + (xr fld index x86))) + :hints (("Goal" :in-theory (e/d* () (force (force)))))) + + (defthm xr-rm08-state-in-system-level-mode + (implies (and (not (programmer-level-mode x86)) + (not (equal fld :mem)) + (not (equal fld :fault))) + (equal (xr fld index (mv-nth 2 (rm08 addr r-w-x x86))) + (xr fld index x86))) + :hints (("Goal" :in-theory (e/d* () (force (force)))))) + + (defthm rm08-xw-programmer-level-mode + (implies (and (programmer-level-mode x86) + (not (equal fld :mem)) + (not (equal fld :programmer-level-mode))) + (and (equal (mv-nth 0 (rm08 addr r-w-x (xw fld index value x86))) + (mv-nth 0 (rm08 addr r-w-x x86))) + (equal (mv-nth 1 (rm08 addr r-w-x (xw fld index value x86))) + (mv-nth 1 (rm08 addr r-w-x x86))) + ;; No need for the conclusion about the state because + ;; "rm08-does-not-affect-state-in-programmer-level-mode". + )) + :hints (("Goal" :in-theory (e/d* (rvm08) ())))) + + (defthm rm08-xw-system-mode + (implies (and (not (programmer-level-mode x86)) + (not (equal fld :fault)) + (not (equal fld :seg-visible)) + (not (equal fld :mem)) + (not (equal fld :ctr)) + (not (equal fld :msr)) + (not (equal fld :rflags)) + (not (equal fld :programmer-level-mode)) + (not (equal fld :page-structure-marking-mode))) + (and (equal (mv-nth 0 (rm08 addr r-w-x (xw fld index value x86))) + (mv-nth 0 (rm08 addr r-w-x x86))) + (equal (mv-nth 1 (rm08 addr r-w-x (xw fld index value x86))) + (mv-nth 1 (rm08 addr r-w-x x86))) + (equal (mv-nth 2 (rm08 addr r-w-x (xw fld index value x86))) + (xw fld index value (mv-nth 2 (rm08 addr r-w-x x86))))))) + + (defthm rm08-xw-system-mode-rflags-not-ac + (implies (and (not (programmer-level-mode x86)) + (equal (rflags-slice :ac value) + (rflags-slice :ac (rflags x86)))) + (and (equal (mv-nth 0 (rm08 addr r-w-x (xw :rflags 0 value x86))) + (mv-nth 0 (rm08 addr r-w-x x86))) + (equal (mv-nth 1 (rm08 addr r-w-x (xw :rflags 0 value x86))) + (mv-nth 1 (rm08 addr r-w-x x86))) + (equal (mv-nth 2 (rm08 addr r-w-x (xw :rflags 0 value x86))) + (xw :rflags 0 value (mv-nth 2 (rm08 addr r-w-x x86))))))) + + (defthm mv-nth-2-rm08-in-system-level-non-marking-mode + (implies (and (not (programmer-level-mode x86)) + (not (page-structure-marking-mode x86)) + (x86p x86) + (not (mv-nth 0 (rm08 lin-addr r-w-x x86)))) + (equal (mv-nth 2 (rm08 lin-addr r-w-x x86)) + x86)))) + +(define rim08 + ((lin-addr :type (signed-byte #.*max-linear-address-size*)) + (r-w-x :type (member :r :w :x)) + (x86)) + + :parents (x86-top-level-memory) + :guard (canonical-address-p lin-addr) + + (mv-let (flag val x86) + (rm08 lin-addr r-w-x x86) + (mv flag (n08-to-i08 val) x86)) + /// + + (defthm-sb i08p-mv-nth-1-rim08 + :hyp (and (signed-byte-p *max-linear-address-size* lin-addr) + (x86p x86)) + :bound 8 + :concl (mv-nth 1 (rim08 lin-addr r-w-x x86)) + :hints (("Goal" :in-theory (e/d () (signed-byte-p)))) + :gen-linear t + :hints-l (("Goal" :in-theory (e/d (signed-byte-p) ()))) + :hyp-t (forced-and (integerp lin-addr) + (x86p x86)) + :gen-type t) + + (defthm x86p-rim08 + (implies (force (x86p x86)) + (x86p (mv-nth 2 (rim08 lin-addr r-w-x x86)))) + :rule-classes (:rewrite :type-prescription))) + +(define wm08 + ((lin-addr :type (signed-byte #.*max-linear-address-size*)) + (val :type (unsigned-byte 8)) + (x86)) + + :parents (x86-top-level-memory) + :guard (canonical-address-p lin-addr) + :guard-hints (("Goal" :in-theory (e/d* (wvm08 byte-ify) ()))) + + (if (mbt (canonical-address-p lin-addr)) + + (mbe + + :logic + (wb (create-addr-bytes-alist + (create-canonical-address-list 1 lin-addr) + (byte-ify 1 val)) + x86) + + :exec + (if (programmer-level-mode x86) + + (wvm08 lin-addr val x86) + + (b* ((cpl (cpl x86)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr) x86) + (la-to-pa lin-addr :w cpl x86)) + ((when flag) + (mv flag x86)) + (byte (mbe :logic (n08 val) + :exec val)) + (x86 (!memi p-addr byte x86))) + (mv nil x86)))) + + (mv 'wm08 x86)) + + /// + + (defthm x86p-wm08 + (implies (force (x86p x86)) + (x86p (mv-nth 1 (wm08 lin-addr val x86)))) + :hints (("Goal" :in-theory (e/d (byte-ify) (force (force))))) + :rule-classes (:rewrite :type-prescription)) + + (defthm programmer-level-mode-wm08-no-error + (implies (and (programmer-level-mode x86) + (canonical-address-p addr)) + (equal (mv-nth 0 (wm08 addr val x86)) + nil)) + :hints (("Goal" :in-theory (e/d (wm08 wvm08 byte-ify) ())))) + + (defthm xr-wm08-programmer-level-mode + (implies (and (programmer-level-mode x86) + (not (equal fld :mem))) + (equal (xr fld index (mv-nth 1 (wm08 addr val x86))) + (xr fld index x86))) + :hints (("Goal" :in-theory (e/d* (wvm08) ())))) + + (defthm xr-wm08-system-level-mode + (implies (and (not (programmer-level-mode x86)) + (not (equal fld :mem)) + (not (equal fld :fault))) + (equal (xr fld index (mv-nth 1 (wm08 addr val x86))) + (xr fld index x86))) + :hints (("Goal" :in-theory (e/d* () (force (force)))))) + + (defthm wm08-xw-programmer-level-mode + (implies (and (programmer-level-mode x86) + (not (equal fld :mem)) + (not (equal fld :programmer-level-mode))) + (and (equal (mv-nth 0 (wm08 addr val (xw fld index value x86))) + (mv-nth 0 (wm08 addr val x86))) + (equal (mv-nth 1 (wm08 addr val (xw fld index value x86))) + (xw fld index value (mv-nth 1 (wm08 addr val x86)))))) + :hints (("Goal" :in-theory (e/d* (wm08 wvm08) ())))) + + (defthm wm08-xw-system-mode + (implies (and (not (programmer-level-mode x86)) + (not (equal fld :fault)) + (not (equal fld :seg-visible)) + (not (equal fld :mem)) + (not (equal fld :ctr)) + (not (equal fld :rflags)) + (not (equal fld :msr)) + (not (equal fld :programmer-level-mode)) + (not (equal fld :page-structure-marking-mode))) + (and (equal (mv-nth 0 (wm08 addr val (xw fld index value x86))) + (mv-nth 0 (wm08 addr val x86))) + (equal (mv-nth 1 (wm08 addr val (xw fld index value x86))) + (xw fld index value (mv-nth 1 (wm08 addr val x86)))))) + :hints (("Goal" :in-theory (e/d* () (force (force)))))) + + (defthm wm08-xw-system-mode-rflags-not-ac + (implies (and (not (programmer-level-mode x86)) + (equal (rflags-slice :ac value) + (rflags-slice :ac (rflags x86)))) + (and (equal (mv-nth 0 (wm08 addr val (xw :rflags 0 value x86))) + (mv-nth 0 (wm08 addr val x86))) + (equal (mv-nth 1 (wm08 addr val (xw :rflags 0 value x86))) + (xw :rflags 0 value (mv-nth 1 (wm08 addr val x86)))))) + :hints (("Goal" :in-theory (e/d* () (force (force))))))) + +(define wim08 + ((lin-addr :type (signed-byte #.*max-linear-address-size*)) + (val :type (signed-byte 8)) + (x86)) + + :parents (x86-top-level-memory) + :guard (canonical-address-p lin-addr) + + (wm08 lin-addr (the (unsigned-byte 8) (n08 val)) x86) + /// + (defthm x86p-wim08 + (implies (force (x86p x86)) + (x86p (mv-nth 1 (wim08 lin-addr val x86)))) + :rule-classes (:rewrite :type-prescription))) + (define rm16 ((lin-addr :type (signed-byte #.*max-linear-address-size*)) (r-w-x :type (member :r :w :x)) @@ -3749,39 +3756,37 @@ memory. ;; Enable these rules when doing code proofs. -(local - (defthm dumb-integerp-of-mem-rewrite - (implies (x86p x86) - (integerp (xr :mem index x86))))) - -(defthmd rm08-to-rb - (implies (and (x86p x86) - (force (canonical-address-p lin-addr))) - (equal (rm08 lin-addr r-w-x x86) - (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 1 lin-addr) r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)))) - :hints (("Goal" - :use ((:instance rb-and-rm08-in-programmer-level-mode (addr lin-addr))) - :in-theory (e/d* (rm08 rb ifix) - (rb-1 - signed-byte-p - unsigned-byte-p - force (force)))))) - -(defthmd wm08-to-wb - (implies (and (force (canonical-address-p lin-addr)) - (force (unsigned-byte-p 8 byte))) - (equal (wm08 lin-addr byte x86) - (wb (create-addr-bytes-alist - (create-canonical-address-list 1 lin-addr) - (list byte)) - x86))) - :hints (("Goal" :in-theory (e/d* (wm08 wvm08 wb) - (signed-byte-p - unsigned-byte-p - force (force)))))) +;; Relating rb and rm08: + +;; (defthmd rm08-to-rb +;; (implies (and (x86p x86) +;; (force (canonical-address-p lin-addr))) +;; (equal (rm08 lin-addr r-w-x x86) +;; (b* (((mv flg bytes x86) +;; (rb (create-canonical-address-list 1 lin-addr) r-w-x x86)) +;; (result (combine-bytes bytes))) +;; (mv flg result x86)))) +;; :hints (("Goal" +;; :in-theory (e/d* (rm08 rb ifix) +;; (rb-1 +;; signed-byte-p +;; unsigned-byte-p +;; force (force)))))) + +;; ;; Relating wb and wm08: + +;; (defthmd wm08-to-wb +;; (implies (and (force (canonical-address-p lin-addr)) +;; (force (unsigned-byte-p 8 byte))) +;; (equal (wm08 lin-addr byte x86) +;; (wb (create-addr-bytes-alist +;; (create-canonical-address-list 1 lin-addr) +;; (list byte)) +;; x86))) +;; :hints (("Goal" :in-theory (e/d* (wm08 wvm08 wb byte-ify) +;; (signed-byte-p +;; unsigned-byte-p +;; force (force)))))) ;; ====================================================================== diff --git a/books/projects/x86isa/proofs/factorial/fact-inductive-assertions.lisp b/books/projects/x86isa/proofs/factorial/fact-inductive-assertions.lisp index 03e777eae82..7b8c7034cc1 100644 --- a/books/projects/x86isa/proofs/factorial/fact-inductive-assertions.lisp +++ b/books/projects/x86isa/proofs/factorial/fact-inductive-assertions.lisp @@ -10,15 +10,6 @@ (local (include-book "centaur/bitops/ihs-extensions" :dir :system)) -(local (in-theory (e/d* () - (mv-nth-1-wb-and-!flgi-commute - ia32e-la-to-pa-values-and-!flgi - las-to-pas - las-to-pas-values-and-!flgi - mv-nth-2-las-to-pas-and-!flgi-not-ac-commute - xr-fault-wb-in-system-level-marking-mode - xr-fault-wb-in-system-level-mode)))) - ;; ====================================================================== ;; (1) Specification: defining the expected inputs and the desired @@ -653,8 +644,7 @@ (assertions (:rewrite x86-fetch-decode-execute-opener) (:rewrite get-prefixes-opener-lemma-no-prefix-byte) - (:meta acl2::mv-nth-cons-meta) - (:rewrite rm08-to-rb)))))) + (:meta acl2::mv-nth-cons-meta)))))) ;; ====================================================================== diff --git a/books/projects/x86isa/proofs/factorial/fact-wormhole-abstraction.lisp b/books/projects/x86isa/proofs/factorial/fact-wormhole-abstraction.lisp index bdf808c203b..44ee9778dac 100644 --- a/books/projects/x86isa/proofs/factorial/fact-wormhole-abstraction.lisp +++ b/books/projects/x86isa/proofs/factorial/fact-wormhole-abstraction.lisp @@ -10,15 +10,6 @@ (local (include-book "centaur/bitops/ihs-extensions" :dir :system)) (local (include-book "arithmetic/top-with-meta" :dir :system)) -(local (in-theory (e/d* () - (mv-nth-1-wb-and-!flgi-commute - ia32e-la-to-pa-values-and-!flgi - las-to-pas - las-to-pas-values-and-!flgi - mv-nth-2-las-to-pas-and-!flgi-not-ac-commute - xr-fault-wb-in-system-level-marking-mode - xr-fault-wb-in-system-level-mode)))) - ;; ====================================================================== ;; (0) Factorial program: @@ -390,6 +381,7 @@ !flgi-undefined rim-size rim08 + rm08 two-byte-opcode-decode-and-execute x86-effective-addr n32-to-i32 @@ -453,6 +445,7 @@ ;; Spec functions: gpr-and-spec-4 jcc/cmovcc/setcc-spec + rm08 rm32 rim32 rr32 @@ -489,6 +482,7 @@ ;; Spec functions: gpr-and-spec-4 jcc/cmovcc/setcc-spec + rm08 rm32 rim32 rr32 @@ -532,6 +526,7 @@ ;; Spec functions: gpr-and-spec-4 jcc/cmovcc/setcc-spec + rm08 rm32 rim32 rr32 @@ -570,6 +565,7 @@ ;; Spec functions: gpr-and-spec-4 jcc/cmovcc/setcc-spec + rm08 rm32 rim32 rr32 diff --git a/books/projects/x86isa/proofs/utilities/general-memory-utils.lisp b/books/projects/x86isa/proofs/utilities/general-memory-utils.lisp index fe3f5f700e5..deb7cc5685f 100644 --- a/books/projects/x86isa/proofs/utilities/general-memory-utils.lisp +++ b/books/projects/x86isa/proofs/utilities/general-memory-utils.lisp @@ -17,8 +17,6 @@ (local (xdoc::set-default-parents general-memory-utils)) -(in-theory (e/d* (rm08-to-rb wm08-to-wb) ())) - ;; =================================================================== ;; Some lemmas for constructing a number from its constituent parts: @@ -991,9 +989,12 @@ (create-canonical-address-list (len bytes) lin-addr) bytes) x86))) - :hints (("Goal" :in-theory (e/d (write-bytes-to-memory wb wm08 wvm08) + :hints (("Goal" :in-theory (e/d (write-bytes-to-memory + wb + wm08 + wvm08 + byte-ify) (acl2::mv-nth-cons-meta - wm08-to-wb append-and-create-addr-bytes-alist cons-and-create-addr-bytes-alist append-and-addr-byte-alistp)))))) diff --git a/books/projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils.lisp b/books/projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils.lisp index b8cebb1ea2a..ed7ee5940c9 100644 --- a/books/projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils.lisp +++ b/books/projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils.lisp @@ -330,7 +330,7 @@ programmer-level mode.

    " ) (equal (mv-nth 1 (rvm08 addr (mv-nth 1 (wb addr-lst x86)))) (mv-nth 1 (rvm08 addr x86)))) :hints (("Goal" :in-theory (e/d (wm08 wvm08 wb rvm08) - (wm08-to-wb)))))) + ()))))) (local (defthm rm08-wb-not-member-p @@ -420,8 +420,7 @@ programmer-level mode.

    " ) (cdr (assoc-equal addr (reverse addr-lst))))) :hints (("Goal" :in-theory (e/d (wm08 member-p) - (wm08-to-wb - unsigned-byte-p + (unsigned-byte-p signed-byte-p)))))) (local @@ -661,7 +660,7 @@ programmer-level mode.

    " ) (equal (mv-nth 1 (wb-1 addr-list2 (mv-nth 1 (wb-1 addr-list1 x86)))) (mv-nth 1 (wb-1 (append addr-list1 addr-list2) x86)))) :hints (("Goal" :do-not '(generalize) - :in-theory (e/d (wb-and-wm08) (append acl2::mv-nth-cons-meta))))) + :in-theory (e/d () (append acl2::mv-nth-cons-meta))))) (defthm wb-and-wb-combine-wbs (implies (and (addr-byte-alistp addr-list1) @@ -686,7 +685,7 @@ programmer-level mode.

    " ) (equal (wb (acons addr val addr-list) x86) (wb addr-list x86))) :hints (("Goal" :do-not '(generalize) - :in-theory (e/d (wb wm08 mv-nth) (wm08-to-wb))))) + :in-theory (e/d (wb wm08 mv-nth) ())))) (defun-nx wb-duplicate-writes-induct (addr-list x86) (if (endp addr-list) @@ -727,8 +726,7 @@ programmer-level mode.

    " ) (wb (remove-duplicate-keys addr-list) x86))) :hints (("Goal" :do-not '(generalize) :in-theory (e/d (wm08 wb) - (wm08-to-wb - acl2::mv-nth-cons-meta)) + (acl2::mv-nth-cons-meta)) :induct (wb-duplicate-writes-induct addr-list x86)))) ;; ====================================================================== @@ -738,18 +736,6 @@ programmer-level mode.

    " ) ;; The following theorems help in relieving the hypotheses of ;; get-prefixes opener lemmas. -(defthmd rm08-in-terms-of-nth-pos-and-rb - ;; addresses is free. Hopefully, (member-p addr addresses) will - ;; help ACL2 find the right binding. - (implies (and (member-p addr addresses) - (canonical-address-listp addresses) - (equal bytes (mv-nth 1 (rb addresses r-w-x x86))) - (programmer-level-mode x86)) - (equal (mv-nth 1 (rm08 addr r-w-x x86)) - (nth (pos addr addresses) bytes))) - :hints (("Goal" :in-theory (e/d (pos rb) - (signed-byte-p))))) - ;; (defthm rm08-in-terms-of-rb ;; ;; Also see rb-and-rm08. ;; (implies (and (canonical-address-p addr) @@ -772,9 +758,38 @@ programmer-level mode.

    " ) (n (cadr addresses)) (prog-addr (caddr addresses)) (bytes (caddr call))) - `((n . ,n) - (prog-addr . ,prog-addr) - (bytes . ,bytes)))) + `((n . ,n) + (prog-addr . ,prog-addr) + (bytes . ,bytes)))) + +(local + (defthmd rb-in-terms-of-nth-and-pos-helper-1 + (implies (and (program-at (create-canonical-address-list n prog-addr) bytes x86) + (member-p addr (create-canonical-address-list n prog-addr)) + (programmer-level-mode x86)) + (equal (nth (+ addr (- prog-addr)) + (mv-nth 1 (rb-1 (create-canonical-address-list n prog-addr) + r-w-x x86 nil))) + (mv-nth 1 (rvm08 addr x86)))) + :hints (("Goal" :in-theory (e/d* (program-at) ()))))) + +(local + (defthmd rb-in-terms-of-nth-and-pos-helper-2 + (implies (and (program-at (create-canonical-address-list n prog-addr) bytes x86) + (member-p addr (create-canonical-address-list n prog-addr)) + (programmer-level-mode x86)) + (equal (car (mv-nth 1 (rb (list addr) :x x86))) + (nth (+ addr (- prog-addr)) bytes))) + :hints (("Goal" + :do-not-induct t + :use ((:instance rb-in-terms-of-nth-and-pos-helper-1 + (r-w-x :x)) + (:instance member-p-canonical-address-p-canonical-address-listp + (e addr))) + :in-theory (e/d (program-at) + (acl2::mv-nth-cons-meta + signed-byte-p + member-p-canonical-address-p-canonical-address-listp)))))) (defthm rb-in-terms-of-nth-and-pos (implies (and (bind-free (find-info-from-program-at-term-in-programmer-mode @@ -787,17 +802,11 @@ programmer-level mode.

    " ) (programmer-level-mode x86)) (equal (car (mv-nth 1 (rb (list addr) :x x86))) (nth (pos addr (create-canonical-address-list n prog-addr)) bytes))) - :hints (("Goal" :in-theory (e/d (program-at rb) - (acl2::mv-nth-cons-meta - rm08-to-rb - member-p-canonical-address-p-canonical-address-listp)) - :use ((:instance rm08-to-rb - (r-w-x :x)) - (:instance member-p-canonical-address-p-canonical-address-listp - (e addr)) - (:instance rm08-in-terms-of-nth-pos-and-rb - (r-w-x :x) - (addresses (create-canonical-address-list n prog-addr))))))) + :hints (("Goal" + :use ((:instance rb-in-terms-of-nth-and-pos-helper-2)) + :in-theory (e/d () + (acl2::mv-nth-cons-meta + signed-byte-p))))) (encapsulate () @@ -883,8 +892,7 @@ programmer-level mode.

    " ) :hints (("Goal" :in-theory (e/d* (combine-bytes rb rb-1 memi) - (rm08-to-rb - byte-listp + (byte-listp mv-nth create-canonical-address-list-1 (zp) @@ -899,4 +907,26 @@ programmer-level mode.

    " ) (globally-disable '(rb wb canonical-address-p program-at unsigned-byte-p signed-byte-p)) +(in-theory (e/d* + ;; We enable all these functions so that reasoning about + ;; memory can be done in terms of rb and wb. + (rim-size + rm-size + wim-size + wm-size + rm08 rim08 wm08 wim08 + rm16 rim16 wm16 wim16 + rm32 rim32 wm32 wim32 + rm64 rim64 wm64 wim64) + ;; We disable some expensive and irrelevant lemmas in + ;; the programmer-level mode. + (wb-remove-duplicate-writes + mv-nth-1-wb-and-!flgi-commute + ia32e-la-to-pa-values-and-!flgi + las-to-pas + las-to-pas-values-and-!flgi + mv-nth-2-las-to-pas-and-!flgi-not-ac-commute + xr-fault-wb-in-system-level-marking-mode + xr-fault-wb-in-system-level-mode))) + ;; ====================================================================== diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp index 747ddc5f312..c385786d2a6 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp @@ -1051,7 +1051,6 @@ n08p len) (rewrite-get-prefixes-to-get-prefixes-alt - rm08-to-rb las-to-pas-values-and-write-to-physical-memory-disjoint get-prefixes-xw-mem-values-in-system-level-mode-helper-1 xlate-equiv-memory-and-two-get-prefixes-values))))) diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-utils.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-utils.lisp index 2741f6e3ef3..68d4b50b41a 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-utils.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-utils.lisp @@ -311,10 +311,14 @@ (nth (pos addr l-addrs) (mv-nth 1 (rb l-addrs r-w-x (double-rewrite x86)))))) :hints (("Goal" :do-not-induct t + :use ((:instance member-p-canonical-address-p + (e addr) + (x l-addrs))) :in-theory (e/d (rm08 member-p disjoint-p rm08-in-terms-of-nth-pos-and-rb-helper) - (all-translation-governing-addresses + (member-p-canonical-address-p + all-translation-governing-addresses signed-byte-p (:meta acl2::mv-nth-cons-meta)))))) @@ -347,13 +351,11 @@ :hints (("Goal" :do-not-induct t :in-theory (e/d (program-at - rb-in-terms-of-nth-and-pos-helper) + rb-in-terms-of-nth-and-pos-helper + rm08) (acl2::mv-nth-cons-meta - rm08-to-rb member-p-canonical-address-p-canonical-address-listp)) - :use ((:instance rm08-to-rb - (r-w-x :x)) - (:instance member-p-canonical-address-p-canonical-address-listp + :use ((:instance member-p-canonical-address-p-canonical-address-listp (e lin-addr)) (:instance rm08-in-terms-of-nth-pos-and-rb-in-system-level-mode (addr lin-addr) @@ -1002,6 +1004,19 @@ unsigned-byte-p signed-byte-p)) +(in-theory (e/d* + ;; We enable all these functions so that reasoning about + ;; memory can be done in terms of rb and wb. + (rim-size + rm-size + wim-size + wm-size + rm08 rim08 wm08 wim08 + rm16 rim16 wm16 wim16 + rm32 rim32 wm32 wim32 + rm64 rim64 wm64 wim64) + ())) + ;; ====================================================================== (defsection xlate-equiv-memory-and-rm08 @@ -1064,8 +1079,10 @@ :hints (("Goal" :cases ((xr :programmer-level-mode 0 x86-1)) :in-theory (e/d* (rm08 + rb disjoint-p - member-p) + member-p + las-to-pas) (force (force))) :use ((:instance xlate-equiv-memory-and-xr-mem-from-rest-of-memory (j (mv-nth 1 (ia32e-la-to-pa lin-addr r-w-x (cpl x86-1) x86-1))) @@ -1077,12 +1094,12 @@ (implies (xlate-equiv-memory x86-1 x86-2) (xlate-equiv-memory (mv-nth 2 (rm08 lin-addr r-w-x x86-1)) (mv-nth 2 (rm08 lin-addr r-w-x x86-2)))) - :hints (("Goal" :in-theory (e/d* (rm08) (force (force))))) + :hints (("Goal" :in-theory (e/d* (rm08 rb) (force (force))))) :rule-classes :congruence) (defthm xlate-equiv-memory-and-mv-nth-2-rm08 (xlate-equiv-memory (mv-nth 2 (rm08 lin-addr r-w-x x86)) x86) - :hints (("Goal" :in-theory (e/d* (rm08) (force (force))))))) + :hints (("Goal" :in-theory (e/d* (rm08 rb) (force (force))))))) ;; ====================================================================== @@ -1100,9 +1117,8 @@ (xr fld index x86))) :hints (("Goal" :induct (get-prefixes start-rip prefixes cnt x86) - :in-theory (e/d* (get-prefixes rm08) - (rm08-to-rb - negative-logand-to-positive-logand-with-integerp-x + :in-theory (e/d* (get-prefixes rm08 rb las-to-pas) + (negative-logand-to-positive-logand-with-integerp-x unsigned-byte-p-of-logior acl2::loghead-identity not force (force)))))) @@ -1130,14 +1146,13 @@ :hints (("Goal" :induct (get-prefixes start-rip prefixes cnt x86) :in-theory (e/d* (get-prefixes - rm08 + rb las-to-pas) (mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p negative-logand-to-positive-logand-with-integerp-x unsigned-byte-p-of-logior subset-p-two-create-canonical-address-lists-general subset-p - rm08-to-rb not force (force)))))) (defthmd get-prefixes-xw-values-in-system-level-mode @@ -1157,14 +1172,16 @@ :hints (("Goal" :induct (get-prefixes start-rip prefixes cnt x86) :expand (get-prefixes start-rip prefixes cnt (xw fld index value x86)) - :in-theory (e/d* (get-prefixes) - (negative-logand-to-positive-logand-with-integerp-x + :in-theory (e/d* (get-prefixes + rb + las-to-pas) + (rm08 + negative-logand-to-positive-logand-with-integerp-x unsigned-byte-p-of-logior acl2::ash-0 acl2::zip-open acl2::ifix-when-not-integerp acl2::loghead-identity - rm08-to-rb (:t bitops::logior-natp-type) (:t natp-get-prefixes) (:t n08p-mv-nth-1-rm08) @@ -1185,14 +1202,16 @@ :hints (("Goal" :induct (get-prefixes start-rip prefixes cnt x86) :expand (get-prefixes start-rip prefixes cnt (xw fld index value x86)) - :in-theory (e/d* (get-prefixes) - (negative-logand-to-positive-logand-with-integerp-x + :in-theory (e/d* (get-prefixes + las-to-pas + rb) + (rm08 + negative-logand-to-positive-logand-with-integerp-x unsigned-byte-p-of-logior acl2::ash-0 acl2::zip-open acl2::ifix-when-not-integerp acl2::loghead-identity - rm08-to-rb (:t bitops::logior-natp-type) (:t natp-get-prefixes) (:t n08p-mv-nth-1-rm08) @@ -1253,7 +1272,6 @@ acl2::zip-open acl2::ifix-when-not-integerp acl2::loghead-identity - rm08-to-rb (:t bitops::logior-natp-type) (:t natp-get-prefixes) (:t n08p-mv-nth-1-rm08) @@ -1295,7 +1313,7 @@ :induct (get-prefixes start-rip prefixes cnt x86) :expand (get-prefixes start-rip prefixes cnt (xw :rflags 0 value x86)) :in-theory (e/d* (get-prefixes) - (force (force)))))) + (rm08 force (force)))))) (defthm get-prefixes-values-and-!flgi-in-system-level-mode (implies (and (not (equal index *ac*)) @@ -1320,7 +1338,8 @@ (logand 4294955007 (xr :rflags 0 x86)))))) :in-theory (e/d* (!flgi-open-to-xw-rflags !flgi) - (get-prefixes-xw-rflags-not-ac-values-in-system-level-mode + (rm08 + get-prefixes-xw-rflags-not-ac-values-in-system-level-mode force (force)))))) ;; Opener lemmas: @@ -1633,7 +1652,8 @@ get-prefixes las-to-pas mv-nth-0-las-to-pas-subset-p) - (xlate-equiv-memory-and-mv-nth-0-rm08-cong + (rm08 + xlate-equiv-memory-and-mv-nth-0-rm08-cong xlate-equiv-memory-and-mv-nth-1-rm08 mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs (:rewrite mv-nth-0-ia32e-la-to-pa-member-of-mv-nth-1-las-to-pas-if-lin-addr-member-p) @@ -1651,7 +1671,8 @@ :hints (("Goal" :induct (get-prefixes start-rip prefixes cnt x86) :in-theory (e/d* (get-prefixes mv-nth-0-las-to-pas-subset-p subset-p) - (acl2::ash-0 + (rm08 + acl2::ash-0 acl2::zip-open cdr-create-canonical-address-list force (force)))) @@ -1660,7 +1681,8 @@ (and (consp (car id)) (< 1 (len (car id)))) '(:in-theory (e/d* (subset-p get-prefixes mv-nth-0-las-to-pas-subset-p) - (acl2::ash-0 + (rm08 + acl2::ash-0 acl2::zip-open cdr-create-canonical-address-list force (force))) diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/non-marking-mode-top.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/non-marking-mode-top.lisp index 482f7d0d05c..9d73e42c6db 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/non-marking-mode-top.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/non-marking-mode-top.lisp @@ -94,7 +94,6 @@ (member-p lin-addr (create-canonical-address-list n prog-addr)) (syntaxp (quotep n)) (not (mv-nth 0 (ia32e-la-to-pa lin-addr :x (cpl x86) x86))) - ;; (not (mv-nth 0 (rb (list lin-addr) :x x86))) (not (programmer-level-mode x86)) (not (page-structure-marking-mode x86)) (x86p x86)) @@ -103,13 +102,11 @@ :hints (("Goal" :do-not-induct t :in-theory (e/d (program-at + rm08 rb-in-terms-of-nth-and-pos-in-system-level-non-marking-mode-helper) (acl2::mv-nth-cons-meta - rm08-to-rb member-p-canonical-address-p-canonical-address-listp)) - :use ((:instance rm08-to-rb - (r-w-x :x)) - (:instance member-p-canonical-address-p-canonical-address-listp + :use ((:instance member-p-canonical-address-p-canonical-address-listp (e lin-addr)) (:instance rm08-in-terms-of-nth-pos-and-rb-in-system-level-non-marking-mode (addr lin-addr) @@ -743,4 +740,17 @@ unsigned-byte-p signed-byte-p las-to-pas all-translation-governing-addresses)) +(in-theory (e/d* + ;; We enable all these functions so that reasoning about + ;; memory can be done in terms of rb and wb. + (rim-size + rm-size + wim-size + wm-size + rm08 rim08 wm08 wim08 + rm16 rim16 wm16 wim16 + rm32 rim32 wm32 wim32 + rm64 rim64 wm64 wim64) + ())) + ;; ====================================================================== diff --git a/books/projects/x86isa/proofs/wordCount/wc.lisp b/books/projects/x86isa/proofs/wordCount/wc.lisp index 6dd72bb5755..e221467ac34 100644 --- a/books/projects/x86isa/proofs/wordCount/wc.lisp +++ b/books/projects/x86isa/proofs/wordCount/wc.lisp @@ -17,9 +17,7 @@ (include-book "centaur/bitops/ihs-extensions" :dir :system) (local (include-book "centaur/bitops/signed-byte-p" :dir :system)) (local (in-theory (e/d () - (wb-remove-duplicate-writes - mv-nth-1-wb-and-!flgi-commute - byte-ify-and-combine-bytes)))) + (byte-ify-and-combine-bytes)))) ;; ====================================================================== @@ -2408,15 +2406,13 @@ (mv-nth 1 (rb addresses :r x86)))) :hints (("Goal" :in-theory (e/d* (rb rm08) (rb-1-accumulator-thm - rm08-to-rb (:meta acl2::mv-nth-cons-meta)))) (if ;; Apply to all subgoals under a top-level induction. (and (consp (car id)) (< 1 (len (car id)))) '(:in-theory (e/d* (rb rm08) - (rm08-to-rb - rb-1-accumulator-thm + (rb-1-accumulator-thm (:meta acl2::mv-nth-cons-meta))) :use ((:instance rb-1-accumulator-thm (acc (list (mv-nth 1 (rvm08 (car addresses) x86)))) diff --git a/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy.lisp b/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy.lisp index 26879430df9..1d786acaef1 100644 --- a/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy.lisp +++ b/books/projects/x86isa/proofs/zeroCopy/marking-mode/zeroCopy.lisp @@ -1004,7 +1004,6 @@ combine-mv-nth-2-las-to-pas-same-r-w-x-when-addresses-in-sequence mv-nth-2-las-to-pas-system-level-non-marking-mode mv-nth-2-get-prefixes-alt-no-prefix-byte - rm08-to-rb rewrite-rb-to-rb-alt page-dir-ptr-table-entry-addr-to-c-program-optimized-form unsigned-byte-p-52-of-left-shifting-a-40-bit-vector-by-12 From 49282cfdf5987b37b460d7532068c3cc03aa6b83 Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Tue, 26 Jul 2016 11:29:52 -0500 Subject: [PATCH 33/70] Updated Windows build instructions (thanks to Sandip for the help). --- installation/windows7.html | 80 ++++++++++++++++++++++---------------- 1 file changed, 47 insertions(+), 33 deletions(-) diff --git a/installation/windows7.html b/installation/windows7.html index fb8350fbd66..f9afdbb69ee 100644 --- a/installation/windows7.html +++ b/installation/windows7.html @@ -1,34 +1,48 @@ - + Helpful Instructions for Setting up ACL2 and Windows - + -

    Helpful Instructions for Setting up ACL2 and Windows

    - -

    We thank David Rager for providing the following - instructions, which we include verbatim and expect apply to +

    Helpful Instructions for Setting up ACL2 and Windows

    + +

    We thank David Rager for providing + instructions, which we include verbatim below and expect apply to future versions. Note: We recommend using CCL for Windows - builds, in part so that interrupts (Control-C) will work. If - you are using Windows, please note that there have been stalls - using CCL 1.5 on Windows, though not with CCL 1.4. We have - been told by a CCL implementor that this bug has been fixed, - and people running CCL 1.5 under Windows at a revision less - than 13900 should update. + builds, in part so that interrupts (Control-C) will work. But + first, a remark:

    + +

    At least one user has built ACL2 on Windows 10 in July, 2016 by +following the instructions below, using the "bleeding edge" versions +of CCL, mingw, and ACL2. This user said the the bleeding edge +versions might not be necessary, but with older versions there were +too many times that the ACL2 build was hanging. Even with the +bleeding edge versions there were some hangs, but it wasn't clear if +that was the fault of CCL, Mingw, MSys, or something else. This user +explained further:

    + +
    + +The problem with hangs: It seems that while compiling ACL2 there were +a few times when it simply hung. But apparently this is +non-deterministic. Simply cleaning and retrying several times managed +to get me out of the problem. + +
    -

    +

    Here are David Rager's instructions.

    I was able to get ACL2 3.6.1 to install and build the regression suite on Windows 7 with the following steps. I did not have to install cygwin.

    - - + +

    1. Install MinGW. At the time of this writing, the following direct link works
      - + MinGW-5.1.6.exe

      @@ -38,21 +52,21 @@

      Helpful Instructions for Setting up MSYS-1.0.11.exe

      - +

      If that direct link doesn't work, click on "MSYS Base System" on the more general MinWG project files page.

      - +

      2. - - + +
    2. Add "C:\msys\1.0\bin" to my environment variable "path". The way you do this varies with each Windows XP/Vista/7. Roughly speaking, you need to go to the control panel, and open up your system settings. Get to the @@ -60,33 +74,33 @@

      Helpful Instructions for Setting up - +

    3. Realize that using "\" to indicate paths in windows confuses some linux programs and that you might need to use "/" sometimes.

      4. - +

    4. After expanding the ACL2 sources, cd to that directory and type something similar to the following (modify it to set LISP to your LISP executable1)
      - + make LISP=c:/ccl/wx86cl64.exe
      - + The "make.exe" that will be used is intentionally the MSys version, not the MinGW version.

      5. - +
    5. After your ACL2 image builds, make acl2 executable, specifically - +
      • Remove the "$*" from the saved_acl2 script (because Windows does not understand $*). Consequently, any arguments you pass to ACL2 via the command line will be ignored.
        • - +
      • Rename saved_acl2 to saved_acl2.bat, for example by executing the following command: rename saved_acl2 saved_acl2.bat
      6. - +

    6. You can now make the regression suite by typing
      make regression ACL2=c:/acl2-3.6.1/acl2-sources/saved_acl2.bat

      @@ -94,9 +108,9 @@

      Helpful Instructions for Setting up " ((byte-operand? :type (or t nil)) (rex-byte :type (unsigned-byte 8)) (imm? :type (or t nil)) - (prefixes :type (unsigned-byte 43))) + (prefixes :type (unsigned-byte 44))) :inline t :parents (x86-decoding-and-spec-utils) diff --git a/books/projects/x86isa/machine/x86.lisp b/books/projects/x86isa/machine/x86.lisp index 1ed0a400afe..b535424b9b8 100644 --- a/books/projects/x86isa/machine/x86.lisp +++ b/books/projects/x86isa/machine/x86.lisp @@ -988,7 +988,7 @@ ((start-rip :type (signed-byte #.*max-linear-address-size*)) (temp-rip :type (signed-byte #.*max-linear-address-size*)) - (prefixes :type (unsigned-byte 43)) + (prefixes :type (unsigned-byte 44)) (rex-byte :type (unsigned-byte 8)) (opcode :type (unsigned-byte 8)) (modr/m :type (unsigned-byte 8)) @@ -1024,7 +1024,7 @@ (define two-byte-opcode-decode-and-execute ((start-rip :type (signed-byte #.*max-linear-address-size*)) (temp-rip :type (signed-byte #.*max-linear-address-size*)) - (prefixes :type (unsigned-byte 43)) + (prefixes :type (unsigned-byte 44)) (rex-byte :type (unsigned-byte 8)) (escape-byte :type (unsigned-byte 8)) x86) @@ -2554,7 +2554,7 @@ ((start-rip :type (signed-byte #.*max-linear-address-size*)) (temp-rip :type (signed-byte #.*max-linear-address-size*)) - (prefixes :type (unsigned-byte 43)) + (prefixes :type (unsigned-byte 44)) (rex-byte :type (unsigned-byte 8)) (opcode :type (unsigned-byte 8)) (modr/m :type (unsigned-byte 8)) @@ -2591,8 +2591,8 @@ (define get-prefixes ((start-rip :type (signed-byte #.*max-linear-address-size*)) - (prefixes :type (unsigned-byte 43)) - (cnt :type (integer 0 5)) + (prefixes :type (unsigned-byte 44)) + (cnt :type (integer 0 15)) x86) :guard-hints (("Goal" :in-theory @@ -2662,20 +2662,20 @@ () (local (include-book "arithmetic-5/top" :dir :system)) - (defthm negative-logand-to-positive-logand-with-n43p-x + (defthm negative-logand-to-positive-logand-with-n44p-x (implies (and (< n 0) (syntaxp (quotep n)) - (equal m 43) + (equal m 44) (integerp n) - (n43p x)) + (n44p x)) (equal (logand n x) (logand (logand (1- (ash 1 m)) n) x))))))) (if (mbe :logic (zp cnt) :exec (eql cnt 0)) - ;; Error, too many prefix bytes - (mv nil prefixes x86) + ;; Error, too many prefix bytes --- invalid instruction length. + (mv t prefixes x86) (b* ((ctx 'get-prefixes) ((mv flg (the (unsigned-byte 8) byte) x86) @@ -2693,7 +2693,7 @@ ;; following the prefixes in "prefixes"... (let ((prefixes (!prefixes-slice :next-byte byte prefixes))) - (mv nil (!prefixes-slice :num-prefixes (- 5 cnt) prefixes) + (mv nil (!prefixes-slice :num-prefixes (- 15 cnt) prefixes) x86)) (case prefix-byte-group-code @@ -2713,11 +2713,11 @@ #.*2^47*)) ;; Storing the group 1 prefix and going on... (get-prefixes next-rip - (the (unsigned-byte 43) + (the (unsigned-byte 44) (!prefixes-slice :group-1-prefix byte prefixes)) - (the (integer 0 5) (1- cnt)) x86) + (the (integer 0 15) (1- cnt)) x86) (mv (cons 'non-canonical-address next-rip) prefixes x86))) ;; We do not tolerate more than one prefix from a prefix group. (mv t prefixes x86)))) @@ -2741,7 +2741,7 @@ (!prefixes-slice :group-2-prefix byte prefixes) - (the (integer 0 5) (1- cnt)) x86) + (the (integer 0 15) (1- cnt)) x86) (mv (cons 'non-canonical-address next-rip) prefixes x86))) ;; We do not tolerate more than one prefix from a prefix group. @@ -2767,7 +2767,7 @@ (!prefixes-slice :group-3-prefix byte prefixes) - (the (integer 0 5) (1- cnt)) x86) + (the (integer 0 15) (1- cnt)) x86) (mv (cons 'non-canonical-address next-rip) prefixes x86))) ;; We do not tolerate more than one prefix from a prefix group. @@ -2792,7 +2792,7 @@ (!prefixes-slice :group-4-prefix byte prefixes) - (the (integer 0 5) (1- cnt)) x86) + (the (integer 0 15) (1- cnt)) x86) (mv (cons 'non-canonical-address next-rip) prefixes x86))) ;; We do not tolerate more than one prefix from a prefix group. @@ -2822,11 +2822,11 @@ bitops::unsigned-byte-p-when-unsigned-byte-p-less)))) :rule-classes :type-prescription) - (defthm-usb n43p-get-prefixes - :hyp (and (n43p prefixes) + (defthm-usb n44p-get-prefixes + :hyp (and (n44p prefixes) (canonical-address-p start-rip) (x86p x86)) - :bound 43 + :bound 44 :concl (mv-nth 1 (get-prefixes start-rip prefixes cnt x86)) :hints (("Goal" :in-theory (e/d () (signed-byte-p @@ -2873,7 +2873,7 @@ bitops::basic-signed-byte-p-of-+ default-<-1 negative-logand-to-positive-logand-with-integerp-x - negative-logand-to-positive-logand-with-n43p-x + negative-logand-to-positive-logand-with-n44p-x force (force)))))) (defthm get-prefixes-does-not-modify-x86-state-in-programmer-level-mode @@ -2912,16 +2912,16 @@ (defthm num-prefixes-get-prefixes-bound - (implies (and (<= cnt 5) + (implies (and (<= cnt 15) (x86p x86) (canonical-address-p start-rip) - (n43p prefixes) + (n44p prefixes) (< (part-select prefixes :low 0 :high 2) 5)) - (< + (<= (prefixes-slice :num-prefixes (mv-nth 1 (get-prefixes start-rip prefixes cnt x86))) - 5)) + 15)) :hints (("Goal" :induct (get-prefixes start-rip prefixes cnt x86) :in-theory (e/d (rm08-value-when-error) @@ -2951,7 +2951,7 @@ (defthm get-prefixes-opener-lemma-zero-cnt (implies (zp cnt) (equal (get-prefixes start-rip prefixes cnt x86) - (mv nil prefixes x86))) + (mv t prefixes x86))) :hints (("Goal" :in-theory (e/d (get-prefixes) ())))) (defthm get-prefixes-opener-lemma-no-prefix-byte @@ -2973,7 +2973,7 @@ (!prefixes-slice :next-byte (mv-nth 1 (rm08 start-rip :x x86)) prefixes))) - (!prefixes-slice :num-prefixes (- 5 cnt) prefixes)))))) + (!prefixes-slice :num-prefixes (- 15 cnt) prefixes)))))) (defthm get-prefixes-opener-lemma-group-1-prefix (implies (and (or (programmer-level-mode x86) @@ -2996,7 +2996,7 @@ (1- cnt) x86))) :hints (("Goal" :in-theory (e/d* () (unsigned-byte-p - negative-logand-to-positive-logand-with-n43p-x + negative-logand-to-positive-logand-with-n44p-x negative-logand-to-positive-logand-with-integerp-x))))) (defthm get-prefixes-opener-lemma-group-2-prefix @@ -3020,7 +3020,7 @@ (1- cnt) x86))) :hints (("Goal" :in-theory (e/d* () (unsigned-byte-p - negative-logand-to-positive-logand-with-n43p-x + negative-logand-to-positive-logand-with-n44p-x negative-logand-to-positive-logand-with-integerp-x))))) (defthm get-prefixes-opener-lemma-group-3-prefix @@ -3044,7 +3044,7 @@ (1- cnt) x86))) :hints (("Goal" :in-theory (e/d* () (unsigned-byte-p - negative-logand-to-positive-logand-with-n43p-x + negative-logand-to-positive-logand-with-n44p-x negative-logand-to-positive-logand-with-integerp-x))))) (defthm get-prefixes-opener-lemma-group-4-prefix @@ -3068,7 +3068,7 @@ (1- cnt) x86))) :hints (("Goal" :in-theory (e/d* () (unsigned-byte-p - negative-logand-to-positive-logand-with-n43p-x + negative-logand-to-positive-logand-with-n44p-x negative-logand-to-positive-logand-with-integerp-x)))))) ;; ====================================================================== @@ -3084,6 +3084,7 @@ address indicated by the instruction pointer @('rip'), decodes that instruction, and dispatches control to the appropriate instruction semantic function.

      " + :guard-debug t :prepwork ((local (in-theory (e/d* () (unsigned-byte-p not))))) @@ -3099,13 +3100,15 @@ semantic function.

      " (start-rip (the (signed-byte #.*max-linear-address-size*) (rip x86))) - ((mv flg0 (the (unsigned-byte 43) prefixes) x86) - (get-prefixes start-rip 0 5 x86)) - ;; Among other errors, if get-prefixes detects a non-canonical + ((mv flg0 (the (unsigned-byte 44) prefixes) x86) + (get-prefixes start-rip 0 15 x86)) + ;; Among other errors (including if there are 15 prefix bytes, + ;; which leaves no room for an opcode byte in a legal + ;; instruction), if get-prefixes detects a non-canonical ;; address while attempting to fetch prefixes, flg0 will be ;; non-nil. ((when flg0) - (!!ms-fresh :memory-error-in-reading-prefixes flg0)) + (!!ms-fresh :error-in-reading-prefixes flg0)) ((the (unsigned-byte 8) opcode/rex/escape-byte) (prefixes-slice :next-byte prefixes)) @@ -3265,7 +3268,7 @@ semantic function.

      " (defthm x86-fetch-decode-execute-opener (implies (and (equal start-rip (rip x86)) - (equal prefixes (mv-nth 1 (get-prefixes start-rip 0 5 x86))) + (equal prefixes (mv-nth 1 (get-prefixes start-rip 0 15 x86))) (equal opcode/rex/escape-byte (prefixes-slice :next-byte prefixes)) (equal prefix-length (prefixes-slice :num-prefixes prefixes)) @@ -3294,7 +3297,7 @@ semantic function.

      " (not (page-structure-marking-mode x86)))) (not (ms x86)) (not (fault x86)) - (not (mv-nth 0 (get-prefixes start-rip 0 5 x86))) + (not (mv-nth 0 (get-prefixes start-rip 0 15 x86))) (canonical-address-p temp-rip0) (if (and (equal prefix-length 0) (equal rex-byte 0) diff --git a/books/projects/x86isa/portcullis/sharp-dot-constants.lisp b/books/projects/x86isa/portcullis/sharp-dot-constants.lisp index ed8e05e071d..8c2395717e3 100644 --- a/books/projects/x86isa/portcullis/sharp-dot-constants.lisp +++ b/books/projects/x86isa/portcullis/sharp-dot-constants.lisp @@ -9,27 +9,27 @@ (defun power-of-2-measure (x) (cond ((or (not (natp x)) - (<= x 1)) - 0) - (t (floor x 1)))) + (<= x 1)) + 0) + (t (floor x 1)))) (defn power-of-2 (x count) (declare (xargs :measure (power-of-2-measure x) - :guard (natp count))) + :guard (natp count))) (if (natp x) (if (<= x 1) - count - (power-of-2 (* 1/2 x) (1+ count))) + count + (power-of-2 (* 1/2 x) (1+ count))) count)) (defun gl-int (start by count) (declare (xargs :guard (and (natp start) - (natp by) - (natp count)))) + (natp by) + (natp count)))) (if (zp count) nil (cons start - (gl-int (+ by start) by (1- count))))) + (gl-int (+ by start) by (1- count))))) ;; ====================================================================== ;; Some expt constants: @@ -65,6 +65,7 @@ (defconst *2^32* (expt 2 32)) (defconst *2^35* (expt 2 35)) (defconst *2^43* (expt 2 43)) +(defconst *2^44* (expt 2 44)) (defconst *2^45* (expt 2 45)) (defconst *2^47* (expt 2 47)) (defconst *-2^47* (- (expt 2 47))) @@ -219,14 +220,14 @@ (defconst *flg-names* (list *cf* *pf* *af* *zf* *sf* *tf* *if* *df* - *of* *iopl* *nt* *rf* *vm* *ac* *vif* *vip* *id*)) + *of* *iopl* *nt* *rf* *vm* *ac* *vif* *vip* *id*)) (defun max-list (l) (if (or (endp l) - (equal (len l) 1)) + (equal (len l) 1)) (car l) (if (> (car l) (max-list (cdr l))) - (car l) + (car l) (max-list (cdr l))))) (defconst *max-flg-index* @@ -251,7 +252,7 @@ (defconst *fp-status-names* (list *fp-ie* *fp-de* *fp-ze* *fp-oe* *fp-ue* *fp-pe* *fp-sf* - *fp-es* *fp-c0* *fp-c1* *fp-c2* *fp-top* *fp-c3* *fp-b*)) + *fp-es* *fp-c0* *fp-c1* *fp-c2* *fp-top* *fp-c3* *fp-b*)) ;; MXCSR (Intel Manual, Feb'14, Vol. 1, Section 10.2.3) @@ -281,9 +282,9 @@ (defconst *mxcsr-names* (list *mxcsr-ie* *mxcsr-de* *mxcsr-ze* *mxcsr-oe* *mxcsr-ue* - *mxcsr-pe* *mxcsr-daz* *mxcsr-im* *mxcsr-dm* *mxcsr-zm* - *mxcsr-om* *mxcsr-um* *mxcsr-pm* *mxcsr-rc* *mxcsr-fz* - *mxcsr-reserved*)) + *mxcsr-pe* *mxcsr-daz* *mxcsr-im* *mxcsr-dm* *mxcsr-zm* + *mxcsr-om* *mxcsr-um* *mxcsr-pm* *mxcsr-rc* *mxcsr-fz* + *mxcsr-reserved*)) ;; Access RGF or XMM @@ -317,13 +318,13 @@ (defconst *ieee-dp-frac-width* 52) (defconst *ia32_efer-sce* 0) ;; Syscall Enable (R/W) --- enables - ;; SYSCALL/SYSRET + ;; SYSCALL/SYSRET (defconst *ia32_efer-lme* 8) ;; Long Mode Enabled (R/W) (defconst *ia32_efer-lma* 10) ;; Long Mode Active (R) (defconst *ia32_efer-nxe* 11) ;; Execute Disable Bit Enable (R/W) - ;; (Enables page access restriction by - ;; preventing instruction fetches from - ;; PAE pages with the XD bit set) + ;; (Enables page access restriction by + ;; preventing instruction fetches from + ;; PAE pages with the XD bit set) (defconst *ia32_efer-names* (list *ia32_efer-sce* *ia32_efer-lme* *ia32_efer-lma* *ia32_efer-nxe*)) @@ -447,7 +448,7 @@ (defconst *mem-table-size* ;; Size of table for address-to-pseudo-page translation (floor *mem-size-in-bytes* - *pseudo-page-size-in-bytes*)) + *pseudo-page-size-in-bytes*)) (defconst *mem-table-size-bits* (power-of-2 *mem-table-size* 0)) @@ -480,73 +481,73 @@ (defun define-general-purpose-registers () `(defconsts (*RAX* *RCX* *RDX* *RBX* *RSP* *RBP* *RSI* *RDI* - *R8* *R9* *R10* *R11* *R12* *R13* *R14* *R15* - *64-bit-general-purpose-registers-len*) + *R8* *R9* *R10* *R11* *R12* *R13* *R14* *R15* + *64-bit-general-purpose-registers-len*) ,(b* ((lst (gl-int 0 1 16)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) (defun define-segment-registers () `(defconsts (*ES* *CS* *SS* *DS* *FS* *GS* - *segment-register-names-len*) + *segment-register-names-len*) ,(b* ((lst (gl-int 0 1 6)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) (defun define-gdtr/idtr-registers () `(defconsts (*GDTR* *IDTR* *gdtr-idtr-names-len*) ,(b* ((lst (gl-int 0 1 2)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) (defun define-ldtr/tr-registers () `(defconsts (*LDTR* *TR* *ldtr-tr-names-len*) ,(b* ((lst (gl-int 0 1 2)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) ;; Source: Intel Manual, Feb-14, Vol. 3A, Section 2.5 (defun define-control-registers () `(defconsts (*CR0* ;; cr0 controls operating mode and states of - ;; processor - *CR1* ;; cr1 is reserved - *CR2* ;; cr2 holds the page fault linear address (the - ;; one that caused the page fault) - *CR3* ;; cr3 is associated with paging - *CR4* ;; cr4 enables or indicates support for processor - ;; extensions - *CR5* ;; cr5 is reserved - *CR6* ;; cr6 is reserved - *CR7* ;; cr7 is reserved - *CR8* ;; cr8 provides read/write access to the TPR. - ;; (Task Priority Register) available only in 64 - ;; bit mode - ;; cr9 thru cr15 are not implemented in our model yet. - *CR9* *CR10* *CR11* *CR12* *CR13* *CR14* *CR15* - *XCR0* - *control-register-names-len*) + ;; processor + *CR1* ;; cr1 is reserved + *CR2* ;; cr2 holds the page fault linear address (the + ;; one that caused the page fault) + *CR3* ;; cr3 is associated with paging + *CR4* ;; cr4 enables or indicates support for processor + ;; extensions + *CR5* ;; cr5 is reserved + *CR6* ;; cr6 is reserved + *CR7* ;; cr7 is reserved + *CR8* ;; cr8 provides read/write access to the TPR. + ;; (Task Priority Register) available only in 64 + ;; bit mode + ;; cr9 thru cr15 are not implemented in our model yet. + *CR9* *CR10* *CR11* *CR12* *CR13* *CR14* *CR15* + *XCR0* + *control-register-names-len*) ,(b* ((lst (gl-int 0 1 17)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) (defun define-debug-registers () `(defconsts (*DR0* ;; dr0 holds breakpoint 0 virtual address, 64/32 bit - *DR1* ;; dr1 holds breakpoint 1 virtual address, 64/32 bit - *DR2* ;; dr2 holds breakpoint 2 virtual address, 64/32 bit - *DR3* ;; dr3 holds breakpoint 3 virtual address, 64/32 bit - *DR4* ;; dr4 is reserved - *DR5* ;; dr5 is reserved - *DR6* ;; dr6 - *DR7* ;; dr7 - *debug-register-names-len*) + *DR1* ;; dr1 holds breakpoint 1 virtual address, 64/32 bit + *DR2* ;; dr2 holds breakpoint 2 virtual address, 64/32 bit + *DR3* ;; dr3 holds breakpoint 3 virtual address, 64/32 bit + *DR4* ;; dr4 is reserved + *DR5* ;; dr5 is reserved + *DR6* ;; dr6 + *DR7* ;; dr7 + *debug-register-names-len*) ,(b* ((lst (gl-int 0 1 8)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) (defun define-fp-registers () ;; 80-bit registers @@ -556,11 +557,11 @@ ;; FP7. `(defconsts (*FP0* *FP1* *FP2* *FP3* *FP4* *FP5* *FP6* *FP7* - *fp-data-register-names-len*) + *fp-data-register-names-len*) ,(b* ((lst (gl-int 0 1 8)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) (defun define-mmx-registers () ;; 64-bit registers @@ -569,23 +570,23 @@ ;; of the FPU data registers. `(defconsts (*MM0* *MM1* *MM2* *MM3* *MM4* *MM5* *MM6* *MM7* - *mmx-register-names-len*) + *mmx-register-names-len*) ,(b* ((lst (gl-int 0 1 8)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) (defun define-xmm-registers () ;; 128-bit registers `(defconsts (*XMM0* *XMM1* *XMM2* *XMM3* *XMM4* *XMM5* *XMM6* *XMM7* - *XMM8* *XMM9* *XMM10* *XMM11* - *XMM12* *XMM13* *XMM14* *XMM15* - *xmm-register-names-len*) + *XMM8* *XMM9* *XMM10* *XMM11* + *XMM12* *XMM13* *XMM14* *XMM15* + *xmm-register-names-len*) ,(b* ((lst (gl-int 0 1 16)) - (len (len lst))) - (cons 'mv (append lst (list len)))))) + (len (len lst))) + (cons 'mv (append lst (list len)))))) (defun define-model-specific-registers () ;; At this point, we only model the MSRs that we need. Remember, @@ -597,61 +598,61 @@ `(defconsts ( - ;; extended features enables --- If - ;; CPUID.80000001.EDX.[bit 20] or - ;; CPUID.80000001.EDX.[bit 29] - *IA32_EFER* - *IA32_EFER-IDX* - - ;; Map of BASE Address of FS (R/W) --- If - ;; CPUID.80000001.EDX.[bit 29] = 1 - *IA32_FS_BASE* - *IA32_FS_BASE-IDX* - - ;; Map of BASE Address of GB (R/W) --- If - ;; CPUID.80000001.EDX.[bit 29] = 1 - *IA32_GS_BASE* - *IA32_GS_BASE-IDX* - - ;; Swap Target of BASE Address of GS (R/W) --- If - ;; CPUID.80000001.EDX.[bit 29] = 1 - *IA32_KERNEL_GS_BASE* - *IA32_KERNEL_GS_BASE-IDX* - - ;; System Call Target Address (R/W) --- If - ;; CPUID.80000001.EDX.[bit 29] = 1 - *IA32_STAR* - *IA32_STAR-IDX* - - ;; IA-32e Mode System Call Target Address (R/W) --- If - ;; CPUID.80000001.EDX.[bit 29] = 1 - *IA32_LSTAR* - *IA32_LSTAR-IDX* - - ;; System Call Flag Mask (R/W) --- If - ;; CPUID.80000001.EDX.[bit 29] = 1 - *IA32_FMASK* - *IA32_FMASK-IDX* - - *model-specific-register-names-len*) + ;; extended features enables --- If + ;; CPUID.80000001.EDX.[bit 20] or + ;; CPUID.80000001.EDX.[bit 29] + *IA32_EFER* + *IA32_EFER-IDX* + + ;; Map of BASE Address of FS (R/W) --- If + ;; CPUID.80000001.EDX.[bit 29] = 1 + *IA32_FS_BASE* + *IA32_FS_BASE-IDX* + + ;; Map of BASE Address of GB (R/W) --- If + ;; CPUID.80000001.EDX.[bit 29] = 1 + *IA32_GS_BASE* + *IA32_GS_BASE-IDX* + + ;; Swap Target of BASE Address of GS (R/W) --- If + ;; CPUID.80000001.EDX.[bit 29] = 1 + *IA32_KERNEL_GS_BASE* + *IA32_KERNEL_GS_BASE-IDX* + + ;; System Call Target Address (R/W) --- If + ;; CPUID.80000001.EDX.[bit 29] = 1 + *IA32_STAR* + *IA32_STAR-IDX* + + ;; IA-32e Mode System Call Target Address (R/W) --- If + ;; CPUID.80000001.EDX.[bit 29] = 1 + *IA32_LSTAR* + *IA32_LSTAR-IDX* + + ;; System Call Flag Mask (R/W) --- If + ;; CPUID.80000001.EDX.[bit 29] = 1 + *IA32_FMASK* + *IA32_FMASK-IDX* + + *model-specific-register-names-len*) ,(b* ((lst (list #uxC000_0080 ;; ia32_efer and idx - 0 - #uxC000_0100 ;; ia32_fs_base and idx - 1 - #uxC000_0101 ;; ia32_gs_base and idx - 2 - #uxC000_0102 ;; ia32_kernel_gs_base and idx - 3 - #uxC000_0081 ;; ia32_star and idx - 4 - #uxC000_0082 ;; ia32_lstar and idx - 5 - #uxC000_0084 ;; ia32_fmask and idx - 6 - )) - (len (/ (len lst) 2))) - (cons 'mv (append lst (list len)))))) + 0 + #uxC000_0100 ;; ia32_fs_base and idx + 1 + #uxC000_0101 ;; ia32_gs_base and idx + 2 + #uxC000_0102 ;; ia32_kernel_gs_base and idx + 3 + #uxC000_0081 ;; ia32_star and idx + 4 + #uxC000_0082 ;; ia32_lstar and idx + 5 + #uxC000_0084 ;; ia32_fmask and idx + 6 + )) + (len (/ (len lst) 2))) + (cons 'mv (append lst (list len)))))) (make-event (define-general-purpose-registers)) (make-event (define-segment-registers)) diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp index c385786d2a6..a925d65c448 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp @@ -143,8 +143,8 @@ (define get-prefixes-alt ((start-rip :type (signed-byte #.*max-linear-address-size*)) - (prefixes :type (unsigned-byte 43)) - (cnt :type (integer 0 5)) + (prefixes :type (unsigned-byte 44)) + (cnt :type (integer 0 15)) x86) :non-executable t :guard (canonical-address-p (+ cnt start-rip)) @@ -180,15 +180,15 @@ ()))) :rule-classes :type-prescription) - (defthm-usb n43p-get-prefixes-alt - :hyp (and (n43p prefixes) + (defthm-usb n44p-get-prefixes-alt + :hyp (and (n44p prefixes) (canonical-address-p start-rip) (x86p x86)) - :bound 43 + :bound 44 :concl (mv-nth 1 (get-prefixes-alt start-rip prefixes cnt x86)) :hints (("Goal" - :use ((:instance n43p-get-prefixes)) - :in-theory (e/d () (n43p-get-prefixes)))) + :use ((:instance n44p-get-prefixes)) + :in-theory (e/d () (n44p-get-prefixes)))) :gen-linear t) (defthm x86p-get-prefixes-alt @@ -316,7 +316,7 @@ (not (programmer-level-mode x86)) (canonical-address-p start-rip)) (equal (get-prefixes-alt start-rip prefixes cnt x86) - (mv nil prefixes x86))) + (mv t prefixes x86))) :hints (("Goal" :use ((:instance get-prefixes-opener-lemma-zero-cnt)) :in-theory (e/d () (get-prefixes-opener-lemma-zero-cnt @@ -353,7 +353,7 @@ (!prefixes-slice :next-byte (mv-nth 1 (rm08 start-rip :x x86)) prefixes))) - (!prefixes-slice :num-prefixes (- 5 cnt) prefixes))))) + (!prefixes-slice :num-prefixes (- 15 cnt) prefixes))))) :hints (("Goal" :use ((:instance get-prefixes-opener-lemma-no-prefix-byte)) :in-theory (e/d* () (get-prefixes-opener-lemma-no-prefix-byte))))) @@ -856,7 +856,7 @@ (:rewrite subset-p-cdr-x) (:type-prescription n52p-mv-nth-1-ia32e-la-to-pa) (:linear <=-logior) - (:linear n43p-get-prefixes) + (:linear n44p-get-prefixes) (:rewrite get-prefixes-opener-lemma-group-4-prefix) (:rewrite get-prefixes-opener-lemma-group-3-prefix) (:rewrite get-prefixes-opener-lemma-group-2-prefix) @@ -864,7 +864,7 @@ (:rewrite unsigned-byte-p-of-ash) (:linear bitops::logior->=-0-linear) (:rewrite rb-in-terms-of-rb-subset-p-in-system-level-mode) - (:definition n43p$inline) + (:definition n44p$inline) (:rewrite bitops::logtail-of-logtail) (:rewrite mv-nth-2-las-to-pas-system-level-non-marking-mode) (:rewrite mv-nth-1-las-to-pas-when-error) @@ -896,7 +896,7 @@ (:type-prescription all-translation-governing-addresses) (:rewrite acl2::unsigned-byte-p-loghead) (:rewrite bitops::loghead-of-ash-same) - (:type-prescription n43p$inline) + (:type-prescription n44p$inline) (:type-prescription ash) (:rewrite bitops::loghead-of-0-i) (:rewrite acl2::equal-constant-+) @@ -2060,7 +2060,7 @@ ;; Start: binding hypotheses. (equal start-rip (rip x86)) ;; get-prefixes-alt: - (equal three-vals-of-get-prefixes (get-prefixes-alt start-rip 0 5 x86)) + (equal three-vals-of-get-prefixes (get-prefixes-alt start-rip 0 15 x86)) (equal flg-get-prefixes (mv-nth 0 three-vals-of-get-prefixes)) (equal prefixes (mv-nth 1 three-vals-of-get-prefixes)) (equal x86-1 (mv-nth 2 three-vals-of-get-prefixes)) @@ -2146,7 +2146,7 @@ (mv-nth 1 (las-to-pas - (create-canonical-address-list 5 (xr :rip 0 x86)) + (create-canonical-address-list 15 (xr :rip 0 x86)) :x (cpl x86) (double-rewrite x86))) (open-qword-paddr-list (gather-all-paging-structure-qword-addresses (double-rewrite x86)))) @@ -2154,7 +2154,7 @@ (mv-nth 0 (las-to-pas - (create-canonical-address-list 5 (xr :rip 0 x86)) + (create-canonical-address-list 15 (xr :rip 0 x86)) :x (cpl x86) (double-rewrite x86))))) (equal (x86-fetch-decode-execute x86) (top-level-opcode-execute diff --git a/books/projects/x86isa/tools/execution/examples/nop-sequence/acl2-customization.lsp b/books/projects/x86isa/tools/execution/examples/nop-sequence/acl2-customization.lsp new file mode 100644 index 00000000000..977a63070f1 --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/nop-sequence/acl2-customization.lsp @@ -0,0 +1,7 @@ +;; Shilpi Goel + +(ld "~/acl2-customization.lsp" :ld-missing-input-ok t) +(set-deferred-ttag-notes t state) + +(ld "cert.acl2" :ld-missing-input-ok t) +(in-package "X86ISA") diff --git a/books/projects/x86isa/tools/execution/examples/nop-sequence/cert.acl2 b/books/projects/x86isa/tools/execution/examples/nop-sequence/cert.acl2 new file mode 100644 index 00000000000..2ad3dbde7d5 --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/nop-sequence/cert.acl2 @@ -0,0 +1,9 @@ +;; Shilpi Goel + +;; ====================================================================== + +(set-waterfall-parallelism t) +(include-book "../../../../portcullis/sharp-dot-constants") +;; cert-flags: ? t :ttags (:include-raw :syscall-exec :other-non-det :undef-flg :instrument) :skip-proofs-okp t + +;; ====================================================================== \ No newline at end of file diff --git a/books/projects/x86isa/tools/execution/examples/nop-sequence/nop.lsp b/books/projects/x86isa/tools/execution/examples/nop-sequence/nop.lsp new file mode 100644 index 00000000000..017129fa9cd --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/nop-sequence/nop.lsp @@ -0,0 +1,78 @@ +;; Author: Shilpi Goel + +;; Checking if the "Recommended multi-byte sequence of NOP +;; Instruction" (Intel Vol. 2B, NOP Instruction-Set Reference) is +;; supported by the x86isa model: + +(in-package "X86ISA") + +(include-book "../../top" :ttags :all) + +;; ====================================================================== + +;; Set the OS-Info: +(!programmer-level-mode t x86) + +;; Recommended NOP Sequence: + +;; 1. #x66 #x90 +;; 2. #x0F #x1F #x00 +;; 3. #x0F #x1F #x40 #x00 +;; 4. #x0F #x1F #x44 #x00 #x00 +;; 5. #x66 #x0F #x1F #x44 #x00 #x00 +;; 6. #x0F #x1F #x80 #x00 #x00 #x00 #x00 +;; 7. #x0F #x1F #x84 #x00 #x00 #x00 #x00 #x00 +;; 8. #x66 #x0F #x1F #x84 #x00 #x00 #x00 #x00 #x00 + +(defconst *nop* + '( + ;; RIP: 0 + #x66 #x90 + ;; RIP: 2 + #x0F #x1F #x00 + ;; RIP: 5 + #x0F #x1F #x40 #x00 + ;; RIP: 9 + #x0F #x1F #x44 #x00 #x00 + ;; RIP: 0E + #x66 #x0F #x1F #x44 #x00 #x00 + ;; RIP: 14 + #x0F #x1F #x80 #x00 #x00 #x00 #x00 + ;; RIP: 1B + #x0F #x1F #x84 #x00 #x00 #x00 #x00 #x00 + ;; The following instruction is the odd one out. Note #x67 prefix. + ;; RIP: 23 + #x67 #x66 #x0F #x1F #x84 #x00 #x00 #x00 #x00 #x00 + ;; RIP: 2D + #x66 #x0F #x1F #x84 #x00 #x00 #x00 #x00 #x00)) + +;; Initialize the x86 state: +(init-x86-state + ;; Status (MS and fault field) + nil + ;; Start Address --- set the RIP to this address + 0 + ;; Halt Address --- overwrites this address by #xF4 (HLT) + (len *nop*) + ;; Initial values of General-Purpose Registers + nil + ;; Control Registers + nil + ;; Model-Specific Registers + nil + ;; Rflags Register + 2 + ;; Memory image + (pairlis$ + (create-canonical-address-list (len *nop*) 0) + *nop*) + ;; x86 state + x86) + +(!log-file-name "nop.log") +(log_instr) + +;; Run the program for up to 1000000 steps or till the machine halts, whatever comes first: +;; (x86-run-steps 1000000 x86) + +;; ====================================================================== diff --git a/books/projects/x86isa/utils/decoding-utilities.lisp b/books/projects/x86isa/utils/decoding-utilities.lisp index 1f98df0c488..de40c24ea9b 100644 --- a/books/projects/x86isa/utils/decoding-utilities.lisp +++ b/books/projects/x86isa/utils/decoding-utilities.lisp @@ -1638,23 +1638,23 @@ v1: VEX128 & SSE forms only exist (no VEX256), when can t be inferred :short "Functions to detect and decode ModR/M and SIB bytes" (defconst *prefixes-layout* - '((:num-prefixes 0 3) ;; Number of prefixes - (:group-1-prefix 3 8) ;; Lock, Repeat prefix - (:group-2-prefix 11 8) ;; Segment Override prefix - (:group-3-prefix 19 8) ;; Operand-Size Override prefix - (:group-4-prefix 27 8) ;; Address-Size Override prefix - (:next-byte 35 8) ;; Byte following the prefixes + '((:num-prefixes 0 4) ;; Number of prefixes + (:group-1-prefix 4 8) ;; Lock, Repeat prefix + (:group-2-prefix 12 8) ;; Segment Override prefix + (:group-3-prefix 20 8) ;; Operand-Size Override prefix + (:group-4-prefix 28 8) ;; Address-Size Override prefix + (:next-byte 36 8) ;; Byte following the prefixes )) (defthm prefixes-table-ok - (layout-constant-alistp *prefixes-layout* 0 43) + (layout-constant-alistp *prefixes-layout* 0 44) :rule-classes nil) (defmacro prefixes-slice (flg prefixes) - (slice flg prefixes 43 *prefixes-layout*)) + (slice flg prefixes 44 *prefixes-layout*)) (defmacro !prefixes-slice (flg val reg) - (!slice flg val reg 43 *prefixes-layout*)) + (!slice flg val reg 44 *prefixes-layout*)) ) diff --git a/books/projects/x86isa/utils/utilities.lisp b/books/projects/x86isa/utils/utilities.lisp index afa22e02459..0ffdaa26dbe 100644 --- a/books/projects/x86isa/utils/utilities.lisp +++ b/books/projects/x86isa/utils/utilities.lisp @@ -554,7 +554,7 @@ constants and functions; it also proves some associated lemmas.

      " (cons 'progn (np-defs lst))) (defuns-np 1 2 3 4 5 6 8 9 11 12 16 17 18 20 21 22 24 25 26 27 28 - 30 32 33 35 43 45 47 48 49 51 52 59 60 64 65 80 112 120 128) + 30 32 33 35 43 44 45 47 48 49 51 52 59 60 64 65 80 112 120 128) (defmacro n-size (n x) From 85bfc05c54535448dd061382be5ce9ba95bad5ca Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Tue, 26 Jul 2016 18:58:48 -0700 Subject: [PATCH 35/70] Simplify implementation of SOFT. Avoid generating the :T-PROOF option for DEFINE, since now the :TERMINATION-THEOREM is used to prove the termination of instances of recursive second-order functions. --- books/kestrel/soft/implementation.lisp | 23 +---------------------- 1 file changed, 1 insertion(+), 22 deletions(-) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index 1c625b11d3c..b764d189561 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -322,18 +322,6 @@ ; If the new function is recursive, ; it also checks that the well-founded relation is O<. ; -; DEFUN2 sets the :T-PROOF option of DEFINE to T, -; in order to introduce an explicit termination theorem -; (if the function is recursive). -; :BOGUS-DEFUN-HINTS-OK is set to T just before the DEFINE, -; so that if the function is not recursive -; the :T-PROOF option does not cause an error -; (checking whether the function is recursive before submitting it to ACL2 -; would involve parsing, expanding macros, etc., -; to see if the function is called in the body; -; this is avoided by setting :BOGUS-DEFUN-HINTS-OK to T); -; :BOGUS-DEFUN-HINTS-OK is restored to its previous value just after DEFINE. -; ; DEFUN2 sets the :NO-FUNCTION option of DEFINE to T, ; to prevent DEFINE from wrapping the function body ; with a LET binding of __FUNCTION__ to the name of the function. @@ -367,7 +355,7 @@ (bogus-defun-hints-ok (get-bogus-defun-hints-ok w))) `(progn (set-bogus-defun-hints-ok t) - (define ,sofun ,@rest :t-proof t :no-function t :enabled t) + (define ,sofun ,@rest :no-function t :enabled t) (set-bogus-defun-hints-ok ,bogus-defun-hints-ok) (table second-order-functions ',sofun ',info) (value-triple (and (check-wfrel-o< ',sofun (w state)) @@ -1027,12 +1015,6 @@ ; DEFUN-INST generates a :HINTS for the termination proof of the same form ; as the generated proof of an instance of a second-order theorem above. ; -; If FUN is second-order and recursive, the :T-PROOF option is used, -; so that the termination theorem of FUN can be later used -; to prove the termination of instances of FUN. -; Unlike DEFUN2, :BOGUS-DEFUN-HINTS-OK is not set to T and then restored, -; because DEFUN-INST generates the :T-PROOF option -; only if SOFUN and FUN are recursive. ; Similarly to DEFUN2, DEFUN-INST sets ; the :NO-FUNCTION and :ENABLED options of DEFINE to T. ; DEFUN-INST sets @@ -1143,8 +1125,6 @@ (measure (if fun-measure `(:measure ,fun-measure) nil)) ;; :GUARD of FUN if guarded, otherwise NIL: (guard (if fun-guard `(:guard ,fun-guard) nil)) - ;; :T-PROOF option if FUN is recursive, otherwise NIL: - (t-proof (if fun-measure '(:t-proof t) nil)) ;; info about FUN to add to the table of second-order functions ;; (if FUN is second-order): (info (list 'plain fparams)) @@ -1160,7 +1140,6 @@ ,@measure ,@hints ,@guard - ,@t-proof :no-function t :enabled t :ignore-ok t From bfc7e39a8e7fb468613cdb61e5786ddb737120d7 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Tue, 26 Jul 2016 19:02:04 -0700 Subject: [PATCH 36/70] Simplify implementation of SOFT. Avoid setting and restoring :BOGUS-DEFUN-HINTS-OK when submitting the DEFINE that DEFUN2 expands into, since the :T-PROOF option is no longer generated. --- books/kestrel/soft/implementation.lisp | 28 +++++++++----------------- 1 file changed, 9 insertions(+), 19 deletions(-) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index b764d189561..fb703bb12f2 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -33,13 +33,6 @@ (and (function-symbolp (car syms) w) (function-symbol-listp (cdr syms) w)))) -; The :BOGUS-DEFUN-HINTS-OK setting is in the ACL2-DEFAULTS-TABLE. - -(define get-bogus-defun-hints-ok ((w plist-worldp)) - :verify-guards nil - (let ((table (table-alist 'acl2::acl2-defaults-table w))) - (cdr (assoc-eq :bogus-defun-hints-ok table)))) - ; Second-order functions and theorems depend on function variables. ; Each function variable is typed by the number of its arguments (1 or more). ; Types of function variables are denoted @@ -351,18 +344,15 @@ (raise "~x0 must be a non-empty list of function variables ~ without duplicates." fparams)) - (info (list 'plain fparams)) - (bogus-defun-hints-ok (get-bogus-defun-hints-ok w))) - `(progn - (set-bogus-defun-hints-ok t) - (define ,sofun ,@rest :no-function t :enabled t) - (set-bogus-defun-hints-ok ,bogus-defun-hints-ok) - (table second-order-functions ',sofun ',info) - (value-triple (and (check-wfrel-o< ',sofun (w state)) - (check-fparams-dependency ',sofun - 'plain - ',fparams - (w state))))))) + (info (list 'plain fparams))) + `(progn + (define ,sofun ,@rest :no-function t :enabled t) + (table second-order-functions ',sofun ',info) + (value-triple (and (check-wfrel-o< ',sofun (w state)) + (check-fparams-dependency ',sofun + 'plain + ',fparams + (w state))))))) (defmacro defun2 (sofun fparams &rest rest) `(make-event (defun2-event ',sofun ',fparams ',rest (w state)))) From 798e49872d025baf96df28cd5643c3ee7e1fdfe9 Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Tue, 26 Jul 2016 22:26:02 -0500 Subject: [PATCH 37/70] Added eager sharing for iprinting. Fixed ACL2(p) bug due to earlier load of hons-raw.lisp during build. Removed books/misc/check-acl2-exports.cert from ordinary regressions. Quoting :doc note-7-3 -- this is an existing item that I modified to mention eager sharing. The iprinting utility has a new keyword option, :share, which causes iprint indices to be re-used (using so-called ``iprint sharing'' and ``iprint eager sharing''. See [set-iprint]. Thanks to David Rager for suggesting a notion of iprint sharing. I also updated :doc set-iprint, not only to document eager sharing but also to clarify how normal sharing works. Thanks to David Rager for pointing out the compilation warning for ACL2(p) builds that were occurring after loading hons-raw.lisp before basis-a.lisp. Note that books/misc/check-acl2-exports.cert will still be built in "everything" regressions. I removed this from ordinary regressions because it was too easy for someone to break the build by documenting a system function or macro symbol, since that requires either adding that symbol to system constant *acl2-exports* or to the constant *acl2-exports-exclusions* in books/misc/check-acl2-exports.lisp. I routinely do "everything" regressions, and I'm happy to have sole responsibility for maintaining books/misc/check-acl2-exports.lisp, which I think of as merely implementing a check on the system. Clarified the binding of :stobjs-out in bindings returned by translate1-cmp and translate11. Thanks to Alessandro Coglio for a query leading us to make this clarification. --- axioms.lisp | 34 +++++++++ basis-a.lisp | 129 +++++++++++++++++++-------------- basis-b.lisp | 19 ++--- books/GNUmakefile | 15 ++-- books/system/doc/acl2-doc.lisp | 73 +++++++++++++------ doc.lisp | 64 +++++++++++----- translate.lisp | 24 +++--- 7 files changed, 237 insertions(+), 121 deletions(-) diff --git a/axioms.lisp b/axioms.lisp index 61c407c5289..24370345701 100644 --- a/axioms.lisp +++ b/axioms.lisp @@ -6865,6 +6865,40 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step (list 'cons (car chars) (car forms)) (make-fmt-bindings (cdr chars) (cdr forms)))))) +(defmacro warning$ (ctx summary str+ &rest fmt-args) + +; Warning: Keep this in sync with warning$-cw1. + +; Note: This macro was originally defined in basis-a.lisp, but was moved +; forward after *acl2-files* was changed so that "hons-raw" occurs before +; "basis-a". + +; A typical use of this macro might be: +; (warning$ ctx "Loops" "The :REWRITE rule ~x0 loops forever." name) or +; (warning$ ctx nil "The :REWRITE rule ~x0 loops forever." name). +; If the second argument is wrapped in a one-element list, as in +; (warning$ ctx ("Loops") "The :REWRITE rule ~x0 loops forever." name), +; then that argument is quoted, and no check will be made for whether the +; warning is disabled, presumably because we are in a context where we know the +; warning is enabled. + + (list 'warning1 + ctx + +; We seem to have seen a GCL 2.6.7 compiler bug, laying down bogus calls of +; load-time-value, when replacing (consp (cadr args)) with (and (consp (cadr +; args)) (stringp (car (cadr args)))). But it seems fine to have the semantics +; of warning$ be that conses are quoted in the second argument position. + + (if (consp summary) + (kwote summary) + summary) + str+ + (make-fmt-bindings '(#\0 #\1 #\2 #\3 #\4 + #\5 #\6 #\7 #\8 #\9) + fmt-args) + 'state)) + (defmacro msg (str &rest args) ; Fmt is defined much later. But we need msg now because several of our macros diff --git a/basis-a.lisp b/basis-a.lisp index 9d44eaa7cf1..7b1338c8c9a 100644 --- a/basis-a.lisp +++ b/basis-a.lisp @@ -695,9 +695,11 @@ ; call such i the last-index, and it is initially 0. Note that state global ; 'iprint-ar is thus always bound to an installed ACL2 array. -; When state global 'iprint-fal has a non-nil value, it is a fast-alist that -; inverts iprint-ar in the following sense: for every pair (i . v) in iprint-ar -; with 1 <= i <= last-index, (v . i) is in the value of 'iprint-fal. +; When state global 'iprint-fal has a non-nil value (which is exactly when +; set-iprint was last called with a non-nil value of :share), it is a +; fast-alist that inverts iprint-ar in the following sense: for every pair (i +; . v) in iprint-ar with 1 <= i <= last-index, (v . i) is in the value of +; 'iprint-fal. See :doc set-iprint for more about :share. ; We have to face a fundamental question: Do we use acons or aset1 as we ; encounter a new form to assign to some #@i# during those recursive @@ -808,7 +810,7 @@ (mutual-recursion (defun eviscerate1 (x v max-v max-n alist evisc-table hiding-cars - iprint-alist iprint-fal-new iprint-fal-old) + iprint-alist iprint-fal-new iprint-fal-old eager-p) ; Iprint-alist is either a symbol, indicating that we are not doing iprinting; a ; positive integer, representing the last-index but no accumulated iprint-alist; @@ -816,8 +818,19 @@ ; Note that if iprint-alist is a symbol, then it is nil if no evisceration has ; been done based on print-length or print-level, else t. - (let ((temp (or (hons-assoc-equal x alist) - (hons-assoc-equal x evisc-table)))) +; If iprint-fal-old is nil (i.e., if iprinting is off), then eager-p is +; essentially irrelevant; but as a sanity check, we insist that eager-p is nil +; in that case (as enforced by the assert$ call below). + + (let* ((temp (or (hons-assoc-equal x alist) + (hons-assoc-equal x evisc-table))) + (eager-pair (and eager-p + (null (cdr temp)) + (consp x) + (assert$ + iprint-fal-old + (or (hons-get x iprint-fal-new) + (hons-get x iprint-fal-old)))))) (cond ((cdr temp) (mv (cond ((stringp (cdr temp)) (cons *evisceration-mark* (cdr temp))) @@ -829,6 +842,11 @@ (t x)) iprint-alist iprint-fal-new)) + (eager-pair + (mv (cons *evisceration-mark* + (get-sharp-atsign (cdr eager-pair))) + iprint-alist + iprint-fal-new)) ((= v max-v) (cond ((symbolp iprint-alist) (mv *evisceration-hash-mark* t iprint-fal-new)) @@ -846,12 +864,19 @@ (mv *evisceration-hiding-mark* iprint-alist iprint-fal-new)) (t (eviscerate1-lst x (1+ v) 0 max-v max-n alist evisc-table hiding-cars iprint-alist - iprint-fal-new iprint-fal-old))))) + iprint-fal-new iprint-fal-old eager-p))))) (defun eviscerate1-lst (lst v n max-v max-n alist evisc-table hiding-cars - iprint-alist iprint-fal-new iprint-fal-old) - (let ((temp (or (hons-assoc-equal lst alist) - (hons-assoc-equal lst evisc-table)))) + iprint-alist iprint-fal-new iprint-fal-old eager-p) + (let* ((temp (or (hons-assoc-equal lst alist) + (hons-assoc-equal lst evisc-table))) + (eager-pair (and eager-p + (null (cdr temp)) + (consp lst) + (assert$ + iprint-fal-old + (or (hons-get lst iprint-fal-new) + (hons-get lst iprint-fal-old)))))) (cond ((cdr temp) (mv (cond ((stringp (cdr temp)) @@ -864,6 +889,11 @@ (t lst)) iprint-alist iprint-fal-new)) + (eager-pair + (mv (cons *evisceration-mark* + (get-sharp-atsign (cdr eager-pair))) + iprint-alist + iprint-fal-new)) ((= n max-n) (cond ((symbolp iprint-alist) (mv (list *evisceration-ellipsis-mark*) t iprint-fal-new)) @@ -879,12 +909,12 @@ (t (mv-let (first iprint-alist iprint-fal-new) (eviscerate1 (car lst) v max-v max-n alist evisc-table hiding-cars iprint-alist - iprint-fal-new iprint-fal-old) + iprint-fal-new iprint-fal-old eager-p) (mv-let (rest iprint-alist iprint-fal-new) (eviscerate1-lst (cdr lst) v (1+ n) max-v max-n alist evisc-table hiding-cars iprint-alist - iprint-fal-new iprint-fal-old) + iprint-fal-new iprint-fal-old eager-p) (mv (cons first rest) iprint-alist iprint-fal-new))))))) ) @@ -919,7 +949,7 @@ ) (defun eviscerate (x print-level print-length alist evisc-table hiding-cars - iprint-alist iprint-fal-new iprint-fal-old) + iprint-alist iprint-fal-new iprint-fal-old eager-p) ; See also eviscerate-top, which takes iprint-ar from the state and installs a ; new iprint-ar in the state, and update-iprint-alist, which describes the role @@ -968,9 +998,14 @@ (cond ((eviscerate1p x alist evisc-table hiding-cars) (eviscerate1 x 0 -1 -1 alist evisc-table hiding-cars - iprint-alist iprint-fal-new iprint-fal-old)) + +; Since we are not eviscerating based on print-level or print-length, there is +; no involvement of iprinting, so we pass nil for the remaining arguments. + + nil nil nil nil)) (t (mv x iprint-alist iprint-fal-new)))) - (t (eviscerate1 x 0 + (t (eviscerate1 (if eager-p (hons-copy x) x) + 0 (or print-level -1) (or print-length -1) alist @@ -978,7 +1013,8 @@ hiding-cars iprint-alist iprint-fal-new - iprint-fal-old)))) + iprint-fal-old + eager-p)))) (defun eviscerate-simple (x print-level print-length alist evisc-table hiding-cars) @@ -992,9 +1028,10 @@ ; We normally pass in the current value of state global 'iprint-fal for the ; last argument, iprint-fal-old, of eviscerate. However, since iprint-alist is -; nil, we know that it's fine to pass in nil for iprint-fal-old +; nil, we know that it's fine to pass in nil for iprint-fal-old, and similarly +; for eager-p. - nil) + nil nil) (assert$ (and (booleanp null-iprint-alist) (null null-iprint-fal)) result))) @@ -1076,6 +1113,15 @@ acc (cons (car ar) acc)))))) +(defun iprint-fal-name (iprint-fal) + (if (consp iprint-fal) + (cdr (last iprint-fal)) + iprint-fal)) + +(defun iprint-eager-p (iprint-fal) + (eq (iprint-fal-name iprint-fal) + :eager)) + (defun init-iprint-fal (sym state) ; Warning: Consider also calling init-iprint-ar when calling this function. @@ -1086,9 +1132,7 @@ (declare (xargs :guard (symbolp sym))) (let* ((old-iprint-fal (f-get-global 'iprint-fal state)) - (old-iprint-name (if (consp old-iprint-fal) - (cdr (last old-iprint-fal)) - old-iprint-fal)) + (old-iprint-name (iprint-fal-name old-iprint-fal)) (new-iprint-fal (cond ((null sym) nil) ((eq sym t) :iprint-fal) @@ -1102,8 +1146,11 @@ ((eq old-iprint-name new-iprint-fal) nil) (new-iprint-fal - (msg "Iprinting is enabled with sharing, with a ~ - fast-alist whose name is ~x0." + (msg "Iprinting is enabled with~@0 sharing, with a ~ + fast-alist whose name is ~x1." + (if (iprint-eager-p new-iprint-fal) + " eager" + "") new-iprint-fal)) (t (msg "Iprinting is enabled without sharing."))) @@ -1203,8 +1250,8 @@ (defun update-iprint-ar-fal (iprint-alist iprint-fal-new iprint-fal-old state) ; We assume that iprinting is enabled. Iprint-alist is known to be a consp. -; We update state global 'iprint-ar by updating iprint-ar with the pairs in -; iprint-alist. +; We update state globals 'iprint-ar and 'iprint-fal by updating them with the +; pairs in iprint-alist and iprint-fal-new, respectively. (let ((last-index (caar iprint-alist))) (cond ((> last-index (iprint-hard-bound state)) @@ -1247,7 +1294,7 @@ (eviscerate x print-level print-length alist evisc-table hiding-cars (and (iprint-enabledp state) (iprint-last-index state)) - nil iprint-fal-old) + nil iprint-fal-old (iprint-eager-p iprint-fal-old)) (fast-alist-free-on-exit iprint-fal-new (let ((state @@ -5121,36 +5168,6 @@ (warning1-form nil)) -(defmacro warning$ (ctx summary str+ &rest fmt-args) - -; Warning: Keep this in sync with warning$-cw1. - -; A typical use of this macro might be: -; (warning$ ctx "Loops" "The :REWRITE rule ~x0 loops forever." name) or -; (warning$ ctx nil "The :REWRITE rule ~x0 loops forever." name). -; If the second argument is wrapped in a one-element list, as in -; (warning$ ctx ("Loops") "The :REWRITE rule ~x0 loops forever." name), -; then that argument is quoted, and no check will be made for whether the -; warning is disabled, presumably because we are in a context where we know the -; warning is enabled. - - (list 'warning1 - ctx - -; We seem to have seen a GCL 2.6.7 compiler bug, laying down bogus calls of -; load-time-value, when replacing (consp (cadr args)) with (and (consp (cadr -; args)) (stringp (car (cadr args)))). But it seems fine to have the semantics -; of warning$ be that conses are quoted in the second argument position. - - (if (consp summary) - (kwote summary) - summary) - str+ - (make-fmt-bindings '(#\0 #\1 #\2 #\3 #\4 - #\5 #\6 #\7 #\8 #\9) - fmt-args) - 'state)) - (defmacro warning-disabled-p (summary) ; We can use this function to avoid needless computation on behalf of disabled diff --git a/basis-b.lisp b/basis-b.lisp index 1c7e48c3312..333f07d0621 100644 --- a/basis-b.lisp +++ b/basis-b.lisp @@ -659,7 +659,7 @@ (defun eviscerate-stobjs1 (estobjs-out lst print-level print-length alist evisc-table hiding-cars iprint-alist - iprint-fal-new iprint-fal-old) + iprint-fal-new iprint-fal-old eager-p) (cond ((null estobjs-out) (mv nil iprint-alist iprint-fal-new)) ((car estobjs-out) @@ -667,24 +667,24 @@ (eviscerate-stobjs1 (cdr estobjs-out) (cdr lst) print-level print-length alist evisc-table hiding-cars - iprint-alist iprint-fal-new iprint-fal-old) + iprint-alist iprint-fal-new iprint-fal-old eager-p) (mv (cons (car estobjs-out) rest) iprint-alist iprint-fal-new))) (t (mv-let (first iprint-alist iprint-fal-new) (eviscerate (car lst) print-level print-length alist evisc-table hiding-cars iprint-alist - iprint-fal-new iprint-fal-old) + iprint-fal-new iprint-fal-old eager-p) (mv-let (rest iprint-alist iprint-fal-new) (eviscerate-stobjs1 (cdr estobjs-out) (cdr lst) print-level print-length alist evisc-table hiding-cars iprint-alist - iprint-fal-new iprint-fal-old) + iprint-fal-new iprint-fal-old eager-p) (mv (cons first rest) iprint-alist iprint-fal-new)))))) (defun eviscerate-stobjs (estobjs-out lst print-level print-length alist evisc-table hiding-cars - iprint-alist iprint-fal-old) + iprint-alist iprint-fal-old eager-p) ; See also eviscerate-stobjs-top, which takes iprint-ar from the state and ; installs a new iprint-ar in the state. @@ -717,7 +717,7 @@ ; eviscerate it without regard for stobjs. (eviscerate lst print-level print-length alist evisc-table hiding-cars - iprint-alist nil iprint-fal-old)) + iprint-alist nil iprint-fal-old eager-p)) ((null (cdr estobjs-out)) ; Lst is a single output, which is either a stobj or not depending on whether @@ -727,10 +727,10 @@ ((car estobjs-out) (mv (car estobjs-out) iprint-alist nil)) (t (eviscerate lst print-level print-length alist evisc-table - hiding-cars iprint-alist nil iprint-fal-old)))) + hiding-cars iprint-alist nil iprint-fal-old eager-p)))) (t (eviscerate-stobjs1 estobjs-out lst print-level print-length alist evisc-table hiding-cars iprint-alist - nil iprint-fal-old)))) + nil iprint-fal-old eager-p)))) (defun eviscerate-stobjs-top (estobjs-out lst print-level print-length alist evisc-table hiding-cars @@ -744,7 +744,8 @@ evisc-table hiding-cars (and (iprint-enabledp state) (iprint-last-index state)) - iprint-fal-old) + iprint-fal-old + (iprint-eager-p iprint-fal-old)) (fast-alist-free-on-exit iprint-fal-new (let ((state diff --git a/books/GNUmakefile b/books/GNUmakefile index 1c430a67584..e9f38118088 100644 --- a/books/GNUmakefile +++ b/books/GNUmakefile @@ -520,19 +520,20 @@ OK_CERTS := $(filter-out $(CERT_PL_USES_QUICKLISP), $(OK_CERTS)) endif -# SLOW_BOOKS is a list of books that are too slow to include as part -# of an ordinary regression. There are currently comments in some of -# the corresponding Makefiles that explain something about these -# books. WARNING: It is probably a bad idea to include targets here -# that are in ACL2_CUSTOM_TARGETS: SLOW_BOOKS is removed from OK_CERTS -# just below, but later, ACL2_CUSTOM_TARGETS adds its targets to -# OK_CERTS. +# SLOW_BOOKS is a list of books that are too slow (or in any way +# undesirable) to include as part of an ordinary regression. There +# are currently comments in some of the corresponding Makefiles that +# explain something about these books. WARNING: It is probably a bad +# idea to include targets here that are in ACL2_CUSTOM_TARGETS: +# SLOW_BOOKS is removed from OK_CERTS just below, but later, +# ACL2_CUSTOM_TARGETS adds its targets to OK_CERTS. # Before defining SLOW_BOOKS, we define ADDED_BOOKS to be the books # that we want to add back in when using target "everything" instead # of the default target, "all". ADDED_BOOKS := \ + books/misc/check-acl2-exports.cert \ coi/defung/defung-stress-long.cert \ models/jvm/m5/apprentice.cert \ system/parallel/proofs/ideal-speedup.cert \ diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index 17dfa2cab92..cd1ce2dd584 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -73899,8 +73899,9 @@ it." Davis for requesting this feature.

      The iprinting utility has a new keyword option, @(':share'), which causes - iprint indices to be re-used. See @(see set-iprint). Thanks to David Rager - for suggesting such an enhancement.

      + iprint indices to be re-used (using so-called ``iprint sharing'' and ``iprint + eager sharing''. See @(see set-iprint). Thanks to David Rager for suggesting + a notion of iprint sharing.

      Heuristic and Efficiency Improvements

      @@ -91289,10 +91290,11 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") ACL2 !> }) -

      You might wish to know which elided expressions are equal. You may specify - keyword argument @(':share t') for that purpose to turn on ``iprint sharing'', - which causes behavior as shown below: the value printed shows the iprint index - 2 being used twice for the list @('(C D E F)').

      +

      If you wish to know which elided expressions are equal, you may call + @('set-iprint') with non-@('nil') value for keyword argument @(':share'). + That will turn on iprint sharing, which causes behavior as shown below: + the value printed shows the iprint index 2 being used twice for the list @('(C + D E F)').

      @({ ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) @@ -91300,17 +91302,17 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") ACL2 !> }) -

      Remark (feel free to skip this paragraph). To understand more fully how - iprint sharing works, consider the following log. The Warning below is - pointing out that previous iprint indices are no longer valid; we are starting - over. The first Observation points out that iprint sharing is on, and gives - the name @(':IPRINT-FAL') to look for in @('(fast-alist-summary)') in case you - want information on the @(see fast-alist) that associates values with - corresponding iprint indices. To see the relevance of a fast-alist, note that - the two elided occurrences of the list @('(C D E F)') were originally not the - identical list in memory; to make them identical, @(tsee hons-copy) is applied - to each to get the same list in memory, which is the one associated with - iprint index 2 in a fast-alist named @(':IPRINT-FAL').

      +

      We use the log displayed below to explain iprint sharing a bit more. The + Warning below is pointing out that previous iprint indices are no longer + valid; we are starting over. The first Observation points out that iprint + sharing is on, and gives the name @(':IPRINT-FAL') to look for in + @('(fast-alist-summary)') in case you want information on the @(see + fast-alist) that associates values with corresponding iprint indices. To see + the relevance of a fast-alist, note that the two elided occurrences of the + list @('(C D E F)') were originally not the identical list in memory; to make + them identical, @(tsee hons-copy) is applied to each to get the same list in + memory, which is the one associated with iprint index 2 in a fast-alist named + @(':IPRINT-FAL').

      @({ ACL2 !>(set-iprint t :share t) @@ -91328,6 +91330,30 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") (:TERM :LD . #@1#) ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) ((A B . #@2#) (A B . #@2#) . #@3#) + ACL2 !>'(b c d e f) + (B C . #@4#) + ACL2 !> + }) + +

      One might have expected the last form printed above to take advantage of + the fact that the tail @('(C D E F)') of the input's value is already + associated with iprint index 2. If you want that sort of behavior — + that is, where we use an existing iprint index even when we have not yet + reached the print-level or print-depth specified by our most recent call of + @(tsee set-evisc-tuple) — then we can use the special value @(':eager') + for keyword @(':share'), which gives us eager iprinting:

      + + @({ + (set-iprint t :share :eager) + }) + +

      If we use that call of @('set-iprint') instead of our earlier one above + (that is, with @(':share t')), then the tail @('(C D E F)') is indeed + abbreviated using iprint index 2:

      + + @({ + ACL2 !>'(b c d e f) + (B . #@2#) ACL2 !> }) @@ -91386,13 +91412,18 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") assigned the next available iprint index, @('N'). If an iprint index @('I < N') is already associated with a value equal to @('V'), then ACL2 will print @('#@I') for @('V') instead of @('#@N'). Thus, @('N') will remain the next - available iprint index. This behavior is implementing using a @(see + available iprint index. This behavior is implemented using a @(see fast-alist) that associates values with indices; in our example, the @(tsee hons-copy) of @('V') is associated with @('I'). If the value of @(':share') is @('t') then the name of this fast-alist — that is, its initial value — is @(':iprint-fal'); otherwise, the value of @(':share') (other than - @('nil') or @(':same') is its name. This name is useful when viewing the - output of @(tsee fast-alist-summary).

      + @('nil') or @(':same')) is its name. This name is useful when viewing the + output of @(tsee fast-alist-summary). Finally, a special case, called ``eager + sharing'', is installed if the value of @(':share') is @(':eager'). In that + case, the behavior described above — where @('#@I') is printed for + @('V') — will occur even if the value @('V') would otherwise not be + elided, provided the most recent call of @(tsee set-evisc-tuple) specified a + non-@('nil') print-level or print-length.

      Immediately after a top-level form is read, hence before it is evaluated, a check is made for whether the latest iprint index exceeds a certain bound, @@ -97803,7 +97834,7 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") :short "Developing ACL2 system code" :long "

      ACL2 is maintained solely by Matt Kaufmann and J Moore. However, we anticipate that a few others will eventually contribute as well. The - subtopics of this topic provide information that are intended to help future + subtopics of this topic provide information that is intended to help future developers.

      ") (defxdoc system-development-hints diff --git a/doc.lisp b/doc.lisp index ce6c122a5a7..0d5703e2917 100644 --- a/doc.lisp +++ b/doc.lisp @@ -72637,8 +72637,9 @@ New Features Davis for requesting this feature. The iprinting utility has a new keyword option, :share, which causes - iprint indices to be re-used. See [set-iprint]. Thanks to David - Rager for suggesting such an enhancement. + iprint indices to be re-used (using so-called ``iprint sharing'' + and ``iprint eager sharing''. See [set-iprint]. Thanks to David + Rager for suggesting a notion of iprint sharing. Heuristic and Efficiency Improvements @@ -92260,23 +92261,22 @@ Example ACL2 !> - You might wish to know which elided expressions are equal. You may - specify keyword argument :share t for that purpose to turn on - ``iprint sharing'', which causes behavior as shown below: the value - printed shows the iprint index 2 being used twice for the list (C D - E F). + If you wish to know which elided expressions are equal, you may call + set-iprint with non-nil value for keyword argument :share. That + will turn on iprint sharing, which causes behavior as shown below: + the value printed shows the iprint index 2 being used twice for the + list (C D E F). ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) ((A B . #@2#) (A B . #@2#) . #@3#) ACL2 !> - Remark (feel free to skip this paragraph). To understand more fully - how iprint sharing works, consider the following log. The Warning - below is pointing out that previous iprint indices are no longer - valid; we are starting over. The first Observation points out that - iprint sharing is on, and gives the name :IPRINT-FAL to look for in - (fast-alist-summary) in case you want information on the - [fast-alist] that associates values with corresponding iprint + We use the log displayed below to explain iprint sharing a bit more. + The Warning below is pointing out that previous iprint indices are + no longer valid; we are starting over. The first Observation points + out that iprint sharing is on, and gives the name :IPRINT-FAL to + look for in (fast-alist-summary) in case you want information on + the [fast-alist] that associates values with corresponding iprint indices. To see the relevance of a fast-alist, note that the two elided occurrences of the list (C D E F) were originally not the identical list in memory; to make them identical, [hons-copy] is @@ -92298,6 +92298,27 @@ Example (:TERM :LD . #@1#) ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) ((A B . #@2#) (A B . #@2#) . #@3#) + ACL2 !>'(b c d e f) + (B C . #@4#) + ACL2 !> + + One might have expected the last form printed above to take advantage + of the fact that the tail (C D E F) of the input's value is already + associated with iprint index 2. If you want that sort of behavior + --- that is, where we use an existing iprint index even when we + have not yet reached the print-level or print-depth specified by + our most recent call of [set-evisc-tuple] --- then we can use the + special value :eager for keyword :share, which gives us eager + iprinting: + + (set-iprint t :share :eager) + + If we use that call of set-iprint instead of our earlier one above + (that is, with :share t), then the tail (C D E F) is indeed + abbreviated using iprint index 2: + + ACL2 !>'(b c d e f) + (B . #@2#) ACL2 !> The documentation above probably suffices for most users. For those @@ -92350,12 +92371,17 @@ Example If an iprint index I < N is already associated with a value equal to V, then ACL2 will print #@I for V instead of #@N. Thus, N will remain the next available iprint index. This behavior is - implementing using a [fast-alist] that associates values with + implemented using a [fast-alist] that associates values with indices; in our example, the [hons-copy] of V is associated with I. If the value of :share is t then the name of this fast-alist --- that is, its initial value --- is :iprint-fal; otherwise, the value - of :share (other than nil or :same is its name. This name is useful - when viewing the output of [fast-alist-summary]. + of :share (other than nil or :same) is its name. This name is + useful when viewing the output of [fast-alist-summary]. Finally, a + special case, called ``eager sharing'', is installed if the value + of :share is :eager. In that case, the behavior described above --- + where #@I is printed for V --- will occur even if the value V would + otherwise not be elided, provided the most recent call of + [set-evisc-tuple] specified a non-nil print-level or print-length. Immediately after a top-level form is read, hence before it is evaluated, a check is made for whether the latest iprint index @@ -98880,8 +98906,8 @@ Subtopics ACL2 is maintained solely by Matt Kaufmann and J Moore. However, we anticipate that a few others will eventually contribute as well. - The subtopics of this topic provide information that are intended - to help future developers. + The subtopics of this topic provide information that is intended to + help future developers. Subtopics diff --git a/translate.lisp b/translate.lisp index ad50f3a3c42..a076aeae5f8 100644 --- a/translate.lisp +++ b/translate.lisp @@ -7700,13 +7700,15 @@ ; Warning: Keep this in sync with macroexpand1*-cmp. -; Bindings is an alist binding symbols either to their corresponding -; STOBJS-OUT or to symbols. The only symbols used are (about-to-be -; introduced) function symbols or the keyword :STOBJS-OUT. When fn is -; bound to gn it means we have determined that the STOBJS-OUT of fn is -; that of gn. We allow fn to be bound to itself -- indeed, it is -; required initially! (This allows bindings to double as a recording -; of all the names currently being introduced.) +; Bindings is an alist binding symbols either to their corresponding STOBJS-OUT +; or to symbols. The only symbols used are (about-to-be introduced) function +; symbols or the keyword :STOBJS-OUT. When fn is bound to gn it means we have +; determined that the STOBJS-OUT of fn is that of gn. We allow fn to be bound +; to itself -- indeed, it is required initially! (This allows bindings to +; double as a recording of all the names currently being introduced.) A +; special case is when :STOBJS-OUT is bound in bindings: initially it is bound +; to itself, but in the returned bindings it will be bound to the stobjs-out of +; the expression being translated. ; Stobjs-out is one of: @@ -9195,8 +9197,11 @@ ; one does not have state available, and then (default-state-vars nil). ; We return (mv erp transx bindings), where transx is the translation and -; bindings has been modified to bind every fn (ultimately) to a proper stobjs -; out setting. Use translate-deref to recover the bindings. +; bindings has been modified to bind every fn (ultimately) to a proper +; stobjs-out setting. A special case is when the initial stobjs-out is +; :stobjs-out; in that case, :stobjs-out is bound in the returned bindings to +; the stobjs-out of the expression being translated. Use translate-deref to +; recover the bindings. (trans-er-let* ((result @@ -9227,6 +9232,7 @@ (default-state-vars t)))) (defun collect-programs (names wrld) + ; Names is a list of function symbols. Collect the :program ones. (cond ((null names) nil) From af5bf03a102b73221bd17847296c33ae69758cec Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Wed, 27 Jul 2016 06:26:51 -0500 Subject: [PATCH 38/70] Incorporated :doc mod that I had made but forgotten to include (thanks to David Rager for useful feedback). --- books/system/doc/acl2-doc.lisp | 7 +++++-- doc.lisp | 7 +++++-- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index cd1ce2dd584..009349efdc4 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -91348,10 +91348,13 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") })

      If we use that call of @('set-iprint') instead of our earlier one above - (that is, with @(':share t')), then the tail @('(C D E F)') is indeed - abbreviated using iprint index 2:

      + (that is, with @(':share t')), then the first of the two last results from the + log above is unchanged, but in the second result, the tail @('(C D E F)') is + indeed abbreviated using iprint index 2.

      @({ + ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) + ((A B . #@2#) (A B . #@2#) . #@3#) ACL2 !>'(b c d e f) (B . #@2#) ACL2 !> diff --git a/doc.lisp b/doc.lisp index 0d5703e2917..90ae710d28b 100644 --- a/doc.lisp +++ b/doc.lisp @@ -92314,9 +92314,12 @@ Example (set-iprint t :share :eager) If we use that call of set-iprint instead of our earlier one above - (that is, with :share t), then the tail (C D E F) is indeed - abbreviated using iprint index 2: + (that is, with :share t), then the first of the two last results + from the log above is unchanged, but in the second result, the tail + (C D E F) is indeed abbreviated using iprint index 2. + ACL2 !>'((a b c d e f) (a b c d e f) (a b c d e f)) + ((A B . #@2#) (A B . #@2#) . #@3#) ACL2 !>'(b c d e f) (B . #@2#) ACL2 !> From f90b07604b9da3704fd97e70a2f97e34d51e7ecc Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 27 Jul 2016 09:54:38 -0700 Subject: [PATCH 39/70] Add new XDOC kestrel-utilities topic. This will be the merging of the kestrel-general-utilities and kestrel-system-utilities topics. --- books/kestrel/top.lisp | 1 + books/kestrel/utilities/top.lisp | 45 ++++++++++++++++++++++++++++++++ 2 files changed, 46 insertions(+) create mode 100644 books/kestrel/utilities/top.lisp diff --git a/books/kestrel/top.lisp b/books/kestrel/top.lisp index 01b72005ca9..41083541498 100644 --- a/books/kestrel/top.lisp +++ b/books/kestrel/top.lisp @@ -15,6 +15,7 @@ (include-book "general/top") (include-book "soft/top") (include-book "system/top") +(include-book "utilities/top") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/top.lisp b/books/kestrel/utilities/top.lisp new file mode 100644 index 00000000000..0bd1b726128 --- /dev/null +++ b/books/kestrel/utilities/top.lisp @@ -0,0 +1,45 @@ +; Kestrel Utilities +; +; Copyright (C) 2016 Kestrel Institute (http://www.kestrel.edu) +; +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. +; +; Author: Alessandro Coglio (coglio@kestrel.edu) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; This file provides utilities in the Kestrel Books. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(include-book "../general/auto-termination") +(include-book "../general/define-sk") +(include-book "../general/testing") +(include-book "../general/types") +(include-book "../general/ubi") + +(include-book "../system/applicability-conditions") +(include-book "../system/defchoose-queries") +(include-book "../system/defun-sk-queries") +(include-book "../system/directed-untranslate") +(include-book "../system/event-forms") +(include-book "../system/fresh-names") +(include-book "../system/install-not-norm-event") +(include-book "../system/minimize-ruler-extenders") +(include-book "../system/numbered-names") +(include-book "../system/prove-interface") +(include-book "../system/terms") +(include-book "../system/user-interface") +(include-book "../system/verify-guards-program") +(include-book "../system/world-queries") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defxdoc kestrel-utilities + + :parents (kestrel-books) + + :short + "Utilities in the Kestrel Books.") From 06d66289e888a6240cc82e96ac0e041d1a2f8062 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 27 Jul 2016 10:13:10 -0700 Subject: [PATCH 40/70] Move topics under kestrel-utilities. All the XDOC topics that were under kestrel-general-utilities and kestrel-system-utilities are now under kestrel-utilities. --- books/kestrel/general/auto-termination.lisp | 2 +- books/kestrel/general/define-sk.lisp | 2 +- books/kestrel/general/testing.lisp | 2 +- books/kestrel/general/types.lisp | 2 +- books/kestrel/general/ubi.lisp | 2 +- books/kestrel/system/applicability-conditions.lisp | 2 +- books/kestrel/system/defchoose-queries.lisp | 2 +- books/kestrel/system/defun-sk-queries.lisp | 2 +- books/kestrel/system/directed-untranslate.lisp | 2 +- books/kestrel/system/event-forms.lisp | 2 +- books/kestrel/system/fresh-names.lisp | 2 +- books/kestrel/system/install-not-norm-event.lisp | 2 +- books/kestrel/system/minimize-ruler-extenders.lisp | 2 +- books/kestrel/system/numbered-names.lisp | 2 +- books/kestrel/system/prove-interface.lisp | 2 +- books/kestrel/system/terms.lisp | 2 +- books/kestrel/system/user-interface.lisp | 2 +- books/kestrel/system/world-queries.lisp | 2 +- 18 files changed, 18 insertions(+), 18 deletions(-) diff --git a/books/kestrel/general/auto-termination.lisp b/books/kestrel/general/auto-termination.lisp index 7cb262b2933..1a4118dff1c 100644 --- a/books/kestrel/general/auto-termination.lisp +++ b/books/kestrel/general/auto-termination.lisp @@ -751,7 +751,7 @@ *auto-termination-fns*)) (defxdoc with-auto-termination - :parents (kestrel-general-utilities) + :parents (kestrel-utilities) :short "Re-use an existing termination proof automatically." :long "

      The following (admittedly, contrived) example shows how to use this utility. First define:

      diff --git a/books/kestrel/general/define-sk.lisp b/books/kestrel/general/define-sk.lisp index 47294e48030..4310696a479 100644 --- a/books/kestrel/general/define-sk.lisp +++ b/books/kestrel/general/define-sk.lisp @@ -20,7 +20,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defxdoc define-sk - :parents (std/util defun-sk acl2::kestrel-general-utilities) + :parents (std/util defun-sk acl2::kestrel-utilities) :short "A very fine alternative to @(see defun-sk)." :long "

      Introduction

      diff --git a/books/kestrel/general/testing.lisp b/books/kestrel/general/testing.lisp index f4f1ec17d77..c91a5f0f181 100644 --- a/books/kestrel/general/testing.lisp +++ b/books/kestrel/general/testing.lisp @@ -21,7 +21,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defxdoc testing-utilities - :parents (kestrel-general-utilities) + :parents (kestrel-utilities) :short "Utilities for building tests.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/general/types.lisp b/books/kestrel/general/types.lisp index 283ce2f6fa4..404c48a8f8d 100644 --- a/books/kestrel/general/types.lisp +++ b/books/kestrel/general/types.lisp @@ -20,7 +20,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defxdoc miscellaneous-types - :parents (kestrel-general-utilities) + :parents (kestrel-utilities) :short "Some miscellaneous types.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/general/ubi.lisp b/books/kestrel/general/ubi.lisp index 1a7573d9656..7ba36ad58ba 100644 --- a/books/kestrel/general/ubi.lisp +++ b/books/kestrel/general/ubi.lisp @@ -65,7 +65,7 @@ `(ubi-fn ',args state)) (defxdoc ubi - :parents (kestrel-general-utilities history) + :parents (kestrel-utilities history) :short "Undo back up to longest initial segment containing only calls of certain symbols, including @(tsee defpkg) and @(tsee include-book)." :long "

      The following example explains how @(':ubi') works. We start up diff --git a/books/kestrel/system/applicability-conditions.lisp b/books/kestrel/system/applicability-conditions.lisp index 6f3d9729448..595dafb695c 100644 --- a/books/kestrel/system/applicability-conditions.lisp +++ b/books/kestrel/system/applicability-conditions.lisp @@ -26,7 +26,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defsection applicability-conditions - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "Utilities to manage logical formulas that must hold for certain processes to apply." diff --git a/books/kestrel/system/defchoose-queries.lisp b/books/kestrel/system/defchoose-queries.lisp index e3347b3e232..fad9d32be22 100644 --- a/books/kestrel/system/defchoose-queries.lisp +++ b/books/kestrel/system/defchoose-queries.lisp @@ -24,7 +24,7 @@ (defxdoc defchoose-queries - :parents (kestrel-system-utilities system-utilities defchoose) + :parents (kestrel-utilities system-utilities defchoose) :short "Utilities to query @(tsee defchoose) functions." diff --git a/books/kestrel/system/defun-sk-queries.lisp b/books/kestrel/system/defun-sk-queries.lisp index 8529693c586..7bb2be9b757 100644 --- a/books/kestrel/system/defun-sk-queries.lisp +++ b/books/kestrel/system/defun-sk-queries.lisp @@ -26,7 +26,7 @@ (defxdoc defun-sk-queries - :parents (kestrel-system-utilities system-utilities defun-sk) + :parents (kestrel-utilities system-utilities defun-sk) :short "Utilities to query @(tsee defun-sk) functions." diff --git a/books/kestrel/system/directed-untranslate.lisp b/books/kestrel/system/directed-untranslate.lisp index 90e4c7115b3..e14be77034c 100644 --- a/books/kestrel/system/directed-untranslate.lisp +++ b/books/kestrel/system/directed-untranslate.lisp @@ -7,7 +7,7 @@ (include-book "xdoc/top" :dir :system) (defxdoc directed-untranslate - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "Create a user-level form that reflects a given user-level form's structure." :long "

      See @(see term) for relevant background about user-level ``terms'' diff --git a/books/kestrel/system/event-forms.lisp b/books/kestrel/system/event-forms.lisp index 640df554e20..47d1c5b3184 100644 --- a/books/kestrel/system/event-forms.lisp +++ b/books/kestrel/system/event-forms.lisp @@ -21,7 +21,7 @@ (define pseudo-event-formp (x) :returns (yes/no booleanp) - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "True iff @('x') has the basic structure of an event form." :long diff --git a/books/kestrel/system/fresh-names.lisp b/books/kestrel/system/fresh-names.lisp index 5a7c54ed2bf..9faa7f2dcc5 100644 --- a/books/kestrel/system/fresh-names.lisp +++ b/books/kestrel/system/fresh-names.lisp @@ -23,7 +23,7 @@ (wrld plist-worldp)) :returns (fresh-name symbolp) :prepwork ((program)) - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "Append as many @('$') signs to @('name') as needed to make the name new in the world, i.e. not already in use, diff --git a/books/kestrel/system/install-not-norm-event.lisp b/books/kestrel/system/install-not-norm-event.lisp index 00cee73ae6e..43baa880c1e 100644 --- a/books/kestrel/system/install-not-norm-event.lisp +++ b/books/kestrel/system/install-not-norm-event.lisp @@ -25,7 +25,7 @@ (local booleanp "Make the event form local or not.")) :returns (mv (fn$not-normalized symbolp) (event-form pseudo-event-formp)) - :parents (kestrel-system-utilities system-utilities install-not-normalized) + :parents (kestrel-utilities system-utilities install-not-normalized) :short "Generate event form for @('Minimize-ruler-extenders') is really two utilities. The first, which we call MIN_NEW below, admits a proposed @(tsee defun) or @(tsee defund) diff --git a/books/kestrel/system/numbered-names.lisp b/books/kestrel/system/numbered-names.lisp index fd287ab814a..4b0d966ca66 100644 --- a/books/kestrel/system/numbered-names.lisp +++ b/books/kestrel/system/numbered-names.lisp @@ -24,7 +24,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defxdoc numbered-names - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "Utilities for numbered names." :long "

      diff --git a/books/kestrel/system/prove-interface.lisp b/books/kestrel/system/prove-interface.lisp index df1f7befb2c..4b26aa708f3 100644 --- a/books/kestrel/system/prove-interface.lisp +++ b/books/kestrel/system/prove-interface.lisp @@ -77,7 +77,7 @@ `(convert-soft-error-to-value ,form nil))) (defxdoc prove$ - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "A way to call the prover from a program." :long "

      For examples, see community book @('books/kestrel/system/prove-interface-tests.lisp').

      diff --git a/books/kestrel/system/terms.lisp b/books/kestrel/system/terms.lisp index e78d3794ab8..a6b6c079348 100644 --- a/books/kestrel/system/terms.lisp +++ b/books/kestrel/system/terms.lisp @@ -23,7 +23,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defxdoc term-utilities - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "Utilities related to @(see term)s.") (define pseudo-lambda-expr-p (x) diff --git a/books/kestrel/system/user-interface.lisp b/books/kestrel/system/user-interface.lisp index ed4ead504b0..8995bb7a2e0 100644 --- a/books/kestrel/system/user-interface.lisp +++ b/books/kestrel/system/user-interface.lisp @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defsection user-interface - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "Utilities for the user interface of macro libraries (e.g. transformations).") diff --git a/books/kestrel/system/world-queries.lisp b/books/kestrel/system/world-queries.lisp index 11f9292271f..10339af6111 100644 --- a/books/kestrel/system/world-queries.lisp +++ b/books/kestrel/system/world-queries.lisp @@ -30,7 +30,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defxdoc world-queries - :parents (kestrel-system-utilities system-utilities) + :parents (kestrel-utilities system-utilities) :short "Utilities to query @(see world)s." :long "

      From 9265370898b1e2e6c3605ede3a2dfb808aea7b51 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 27 Jul 2016 10:17:10 -0700 Subject: [PATCH 41/70] Tweak file headers and short XDOC strings. --- books/kestrel/top.lisp | 6 +++--- books/kestrel/utilities/top.lisp | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/books/kestrel/top.lisp b/books/kestrel/top.lisp index 41083541498..5fab35ac299 100644 --- a/books/kestrel/top.lisp +++ b/books/kestrel/top.lisp @@ -6,7 +6,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; This file contains the top-level documentation for the Kestrel Books. +; This file provides a collection of ACL2 books +; contributed by Kestrel Institute. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -23,8 +24,7 @@ :parents (software-verification) - :short - "A collection of ACL2 books contributed by Kestrel Institute." + :short "A collection of ACL2 books contributed by Kestrel Institute." :long " diff --git a/books/kestrel/utilities/top.lisp b/books/kestrel/utilities/top.lisp index 0bd1b726128..94aa058f10c 100644 --- a/books/kestrel/utilities/top.lisp +++ b/books/kestrel/utilities/top.lisp @@ -8,7 +8,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; This file provides utilities in the Kestrel Books. +; This file provides a collection of utilities provided by Kestrel Institute. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -41,5 +41,4 @@ :parents (kestrel-books) - :short - "Utilities in the Kestrel Books.") + :short "A collection of utilities contributed by Kestrel Institute.") From 7bd6e9f9ca9df97d74025f87bd683c1020aba3ea Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 27 Jul 2016 10:22:44 -0700 Subject: [PATCH 42/70] Remove now-obsolete top-level files. --- books/kestrel/general/top.lisp | 29 ------------------------ books/kestrel/system/top.lisp | 38 -------------------------------- books/kestrel/top.lisp | 2 -- books/kestrel/utilities/top.lisp | 2 +- 4 files changed, 1 insertion(+), 70 deletions(-) delete mode 100644 books/kestrel/general/top.lisp delete mode 100644 books/kestrel/system/top.lisp diff --git a/books/kestrel/general/top.lisp b/books/kestrel/general/top.lisp deleted file mode 100644 index 308eef74eac..00000000000 --- a/books/kestrel/general/top.lisp +++ /dev/null @@ -1,29 +0,0 @@ -; General-Purpose Utilities -; -; Copyright (C) 2015-2016 Kestrel Institute (http://www.kestrel.edu) -; -; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. -; -; Author: Alessandro Coglio (coglio@kestrel.edu) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; This file provides some general-purpose utilities. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(in-package "ACL2") - -(include-book "auto-termination") -(include-book "define-sk") -(include-book "testing") -(include-book "types") -(include-book "ubi") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defxdoc kestrel-general-utilities - - :parents (kestrel-books) - - :short "Some general-purpose utilities.") diff --git a/books/kestrel/system/top.lisp b/books/kestrel/system/top.lisp deleted file mode 100644 index 77ad0c30f6c..00000000000 --- a/books/kestrel/system/top.lisp +++ /dev/null @@ -1,38 +0,0 @@ -; System Utilities -; -; Copyright (C) 2015-2016 Kestrel Institute (http://www.kestrel.edu) -; -; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. -; -; Author: Alessandro Coglio (coglio@kestrel.edu) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; This file provides some system utilities. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(in-package "ACL2") - -(include-book "applicability-conditions") -(include-book "defchoose-queries") -(include-book "defun-sk-queries") -(include-book "directed-untranslate") -(include-book "event-forms") -(include-book "fresh-names") -(include-book "install-not-norm-event") -(include-book "minimize-ruler-extenders") -(include-book "numbered-names") -(include-book "prove-interface") -(include-book "terms") -(include-book "user-interface") -(include-book "verify-guards-program") -(include-book "world-queries") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defxdoc kestrel-system-utilities - - :parents (kestrel-books) - - :short "Some system utilities.") diff --git a/books/kestrel/top.lisp b/books/kestrel/top.lisp index 5fab35ac299..c9e6672b5bd 100644 --- a/books/kestrel/top.lisp +++ b/books/kestrel/top.lisp @@ -13,9 +13,7 @@ (in-package "ACL2") -(include-book "general/top") (include-book "soft/top") -(include-book "system/top") (include-book "utilities/top") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/top.lisp b/books/kestrel/utilities/top.lisp index 94aa058f10c..503645aa16f 100644 --- a/books/kestrel/utilities/top.lisp +++ b/books/kestrel/utilities/top.lisp @@ -8,7 +8,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; This file provides a collection of utilities provided by Kestrel Institute. +; This file provides a collection of utilities contributed by Kestrel Institute. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From c2019f2e5c6d13186adc966fc8d5fb722fd8fd2f Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 27 Jul 2016 10:26:40 -0700 Subject: [PATCH 43/70] Move files under new directory. --- .../{system => utilities}/applicability-conditions-tests.lisp | 0 books/kestrel/{system => utilities}/applicability-conditions.lisp | 0 books/kestrel/{general => utilities}/auto-termination-tests.lisp | 0 books/kestrel/{general => utilities}/auto-termination.lisp | 0 books/kestrel/{system => utilities}/defchoose-queries-tests.lisp | 0 books/kestrel/{system => utilities}/defchoose-queries.lisp | 0 books/kestrel/{general => utilities}/define-sk-tests.lisp | 0 books/kestrel/{general => utilities}/define-sk.lisp | 0 books/kestrel/{system => utilities}/defun-sk-queries-tests.lisp | 0 books/kestrel/{system => utilities}/defun-sk-queries.lisp | 0 books/kestrel/{system => utilities}/directed-untranslate.lisp | 0 books/kestrel/{system => utilities}/event-forms-tests.lisp | 0 books/kestrel/{system => utilities}/event-forms.lisp | 0 books/kestrel/{system => utilities}/fresh-names-tests.lisp | 0 books/kestrel/{system => utilities}/fresh-names.lisp | 0 .../{system => utilities}/install-not-norm-event-tests.lisp | 0 books/kestrel/{system => utilities}/install-not-norm-event.lisp | 0 books/kestrel/{system => utilities}/minimize-ruler-extenders.lisp | 0 books/kestrel/{system => utilities}/numbered-names-tests.lisp | 0 books/kestrel/{system => utilities}/numbered-names.lisp | 0 books/kestrel/{system => utilities}/prove-interface-tests.lisp | 0 books/kestrel/{system => utilities}/prove-interface.lisp | 0 books/kestrel/{system => utilities}/terms-tests.lisp | 0 books/kestrel/{system => utilities}/terms.lisp | 0 books/kestrel/{general => utilities}/testing-tests.lisp | 0 books/kestrel/{general => utilities}/testing.lisp | 0 books/kestrel/{general => utilities}/types.lisp | 0 books/kestrel/{general => utilities}/ubi.lisp | 0 books/kestrel/{system => utilities}/user-interface-tests.lisp | 0 books/kestrel/{system => utilities}/user-interface.lisp | 0 .../{system => utilities}/verify-guards-program-tests.lisp | 0 books/kestrel/{system => utilities}/verify-guards-program.lisp | 0 books/kestrel/{system => utilities}/world-queries-tests.lisp | 0 books/kestrel/{system => utilities}/world-queries.lisp | 0 34 files changed, 0 insertions(+), 0 deletions(-) rename books/kestrel/{system => utilities}/applicability-conditions-tests.lisp (100%) rename books/kestrel/{system => utilities}/applicability-conditions.lisp (100%) rename books/kestrel/{general => utilities}/auto-termination-tests.lisp (100%) rename books/kestrel/{general => utilities}/auto-termination.lisp (100%) rename books/kestrel/{system => utilities}/defchoose-queries-tests.lisp (100%) rename books/kestrel/{system => utilities}/defchoose-queries.lisp (100%) rename books/kestrel/{general => utilities}/define-sk-tests.lisp (100%) rename books/kestrel/{general => utilities}/define-sk.lisp (100%) rename books/kestrel/{system => utilities}/defun-sk-queries-tests.lisp (100%) rename books/kestrel/{system => utilities}/defun-sk-queries.lisp (100%) rename books/kestrel/{system => utilities}/directed-untranslate.lisp (100%) rename books/kestrel/{system => utilities}/event-forms-tests.lisp (100%) rename books/kestrel/{system => utilities}/event-forms.lisp (100%) rename books/kestrel/{system => utilities}/fresh-names-tests.lisp (100%) rename books/kestrel/{system => utilities}/fresh-names.lisp (100%) rename books/kestrel/{system => utilities}/install-not-norm-event-tests.lisp (100%) rename books/kestrel/{system => utilities}/install-not-norm-event.lisp (100%) rename books/kestrel/{system => utilities}/minimize-ruler-extenders.lisp (100%) rename books/kestrel/{system => utilities}/numbered-names-tests.lisp (100%) rename books/kestrel/{system => utilities}/numbered-names.lisp (100%) rename books/kestrel/{system => utilities}/prove-interface-tests.lisp (100%) rename books/kestrel/{system => utilities}/prove-interface.lisp (100%) rename books/kestrel/{system => utilities}/terms-tests.lisp (100%) rename books/kestrel/{system => utilities}/terms.lisp (100%) rename books/kestrel/{general => utilities}/testing-tests.lisp (100%) rename books/kestrel/{general => utilities}/testing.lisp (100%) rename books/kestrel/{general => utilities}/types.lisp (100%) rename books/kestrel/{general => utilities}/ubi.lisp (100%) rename books/kestrel/{system => utilities}/user-interface-tests.lisp (100%) rename books/kestrel/{system => utilities}/user-interface.lisp (100%) rename books/kestrel/{system => utilities}/verify-guards-program-tests.lisp (100%) rename books/kestrel/{system => utilities}/verify-guards-program.lisp (100%) rename books/kestrel/{system => utilities}/world-queries-tests.lisp (100%) rename books/kestrel/{system => utilities}/world-queries.lisp (100%) diff --git a/books/kestrel/system/applicability-conditions-tests.lisp b/books/kestrel/utilities/applicability-conditions-tests.lisp similarity index 100% rename from books/kestrel/system/applicability-conditions-tests.lisp rename to books/kestrel/utilities/applicability-conditions-tests.lisp diff --git a/books/kestrel/system/applicability-conditions.lisp b/books/kestrel/utilities/applicability-conditions.lisp similarity index 100% rename from books/kestrel/system/applicability-conditions.lisp rename to books/kestrel/utilities/applicability-conditions.lisp diff --git a/books/kestrel/general/auto-termination-tests.lisp b/books/kestrel/utilities/auto-termination-tests.lisp similarity index 100% rename from books/kestrel/general/auto-termination-tests.lisp rename to books/kestrel/utilities/auto-termination-tests.lisp diff --git a/books/kestrel/general/auto-termination.lisp b/books/kestrel/utilities/auto-termination.lisp similarity index 100% rename from books/kestrel/general/auto-termination.lisp rename to books/kestrel/utilities/auto-termination.lisp diff --git a/books/kestrel/system/defchoose-queries-tests.lisp b/books/kestrel/utilities/defchoose-queries-tests.lisp similarity index 100% rename from books/kestrel/system/defchoose-queries-tests.lisp rename to books/kestrel/utilities/defchoose-queries-tests.lisp diff --git a/books/kestrel/system/defchoose-queries.lisp b/books/kestrel/utilities/defchoose-queries.lisp similarity index 100% rename from books/kestrel/system/defchoose-queries.lisp rename to books/kestrel/utilities/defchoose-queries.lisp diff --git a/books/kestrel/general/define-sk-tests.lisp b/books/kestrel/utilities/define-sk-tests.lisp similarity index 100% rename from books/kestrel/general/define-sk-tests.lisp rename to books/kestrel/utilities/define-sk-tests.lisp diff --git a/books/kestrel/general/define-sk.lisp b/books/kestrel/utilities/define-sk.lisp similarity index 100% rename from books/kestrel/general/define-sk.lisp rename to books/kestrel/utilities/define-sk.lisp diff --git a/books/kestrel/system/defun-sk-queries-tests.lisp b/books/kestrel/utilities/defun-sk-queries-tests.lisp similarity index 100% rename from books/kestrel/system/defun-sk-queries-tests.lisp rename to books/kestrel/utilities/defun-sk-queries-tests.lisp diff --git a/books/kestrel/system/defun-sk-queries.lisp b/books/kestrel/utilities/defun-sk-queries.lisp similarity index 100% rename from books/kestrel/system/defun-sk-queries.lisp rename to books/kestrel/utilities/defun-sk-queries.lisp diff --git a/books/kestrel/system/directed-untranslate.lisp b/books/kestrel/utilities/directed-untranslate.lisp similarity index 100% rename from books/kestrel/system/directed-untranslate.lisp rename to books/kestrel/utilities/directed-untranslate.lisp diff --git a/books/kestrel/system/event-forms-tests.lisp b/books/kestrel/utilities/event-forms-tests.lisp similarity index 100% rename from books/kestrel/system/event-forms-tests.lisp rename to books/kestrel/utilities/event-forms-tests.lisp diff --git a/books/kestrel/system/event-forms.lisp b/books/kestrel/utilities/event-forms.lisp similarity index 100% rename from books/kestrel/system/event-forms.lisp rename to books/kestrel/utilities/event-forms.lisp diff --git a/books/kestrel/system/fresh-names-tests.lisp b/books/kestrel/utilities/fresh-names-tests.lisp similarity index 100% rename from books/kestrel/system/fresh-names-tests.lisp rename to books/kestrel/utilities/fresh-names-tests.lisp diff --git a/books/kestrel/system/fresh-names.lisp b/books/kestrel/utilities/fresh-names.lisp similarity index 100% rename from books/kestrel/system/fresh-names.lisp rename to books/kestrel/utilities/fresh-names.lisp diff --git a/books/kestrel/system/install-not-norm-event-tests.lisp b/books/kestrel/utilities/install-not-norm-event-tests.lisp similarity index 100% rename from books/kestrel/system/install-not-norm-event-tests.lisp rename to books/kestrel/utilities/install-not-norm-event-tests.lisp diff --git a/books/kestrel/system/install-not-norm-event.lisp b/books/kestrel/utilities/install-not-norm-event.lisp similarity index 100% rename from books/kestrel/system/install-not-norm-event.lisp rename to books/kestrel/utilities/install-not-norm-event.lisp diff --git a/books/kestrel/system/minimize-ruler-extenders.lisp b/books/kestrel/utilities/minimize-ruler-extenders.lisp similarity index 100% rename from books/kestrel/system/minimize-ruler-extenders.lisp rename to books/kestrel/utilities/minimize-ruler-extenders.lisp diff --git a/books/kestrel/system/numbered-names-tests.lisp b/books/kestrel/utilities/numbered-names-tests.lisp similarity index 100% rename from books/kestrel/system/numbered-names-tests.lisp rename to books/kestrel/utilities/numbered-names-tests.lisp diff --git a/books/kestrel/system/numbered-names.lisp b/books/kestrel/utilities/numbered-names.lisp similarity index 100% rename from books/kestrel/system/numbered-names.lisp rename to books/kestrel/utilities/numbered-names.lisp diff --git a/books/kestrel/system/prove-interface-tests.lisp b/books/kestrel/utilities/prove-interface-tests.lisp similarity index 100% rename from books/kestrel/system/prove-interface-tests.lisp rename to books/kestrel/utilities/prove-interface-tests.lisp diff --git a/books/kestrel/system/prove-interface.lisp b/books/kestrel/utilities/prove-interface.lisp similarity index 100% rename from books/kestrel/system/prove-interface.lisp rename to books/kestrel/utilities/prove-interface.lisp diff --git a/books/kestrel/system/terms-tests.lisp b/books/kestrel/utilities/terms-tests.lisp similarity index 100% rename from books/kestrel/system/terms-tests.lisp rename to books/kestrel/utilities/terms-tests.lisp diff --git a/books/kestrel/system/terms.lisp b/books/kestrel/utilities/terms.lisp similarity index 100% rename from books/kestrel/system/terms.lisp rename to books/kestrel/utilities/terms.lisp diff --git a/books/kestrel/general/testing-tests.lisp b/books/kestrel/utilities/testing-tests.lisp similarity index 100% rename from books/kestrel/general/testing-tests.lisp rename to books/kestrel/utilities/testing-tests.lisp diff --git a/books/kestrel/general/testing.lisp b/books/kestrel/utilities/testing.lisp similarity index 100% rename from books/kestrel/general/testing.lisp rename to books/kestrel/utilities/testing.lisp diff --git a/books/kestrel/general/types.lisp b/books/kestrel/utilities/types.lisp similarity index 100% rename from books/kestrel/general/types.lisp rename to books/kestrel/utilities/types.lisp diff --git a/books/kestrel/general/ubi.lisp b/books/kestrel/utilities/ubi.lisp similarity index 100% rename from books/kestrel/general/ubi.lisp rename to books/kestrel/utilities/ubi.lisp diff --git a/books/kestrel/system/user-interface-tests.lisp b/books/kestrel/utilities/user-interface-tests.lisp similarity index 100% rename from books/kestrel/system/user-interface-tests.lisp rename to books/kestrel/utilities/user-interface-tests.lisp diff --git a/books/kestrel/system/user-interface.lisp b/books/kestrel/utilities/user-interface.lisp similarity index 100% rename from books/kestrel/system/user-interface.lisp rename to books/kestrel/utilities/user-interface.lisp diff --git a/books/kestrel/system/verify-guards-program-tests.lisp b/books/kestrel/utilities/verify-guards-program-tests.lisp similarity index 100% rename from books/kestrel/system/verify-guards-program-tests.lisp rename to books/kestrel/utilities/verify-guards-program-tests.lisp diff --git a/books/kestrel/system/verify-guards-program.lisp b/books/kestrel/utilities/verify-guards-program.lisp similarity index 100% rename from books/kestrel/system/verify-guards-program.lisp rename to books/kestrel/utilities/verify-guards-program.lisp diff --git a/books/kestrel/system/world-queries-tests.lisp b/books/kestrel/utilities/world-queries-tests.lisp similarity index 100% rename from books/kestrel/system/world-queries-tests.lisp rename to books/kestrel/utilities/world-queries-tests.lisp diff --git a/books/kestrel/system/world-queries.lisp b/books/kestrel/utilities/world-queries.lisp similarity index 100% rename from books/kestrel/system/world-queries.lisp rename to books/kestrel/utilities/world-queries.lisp From b1b60b585829d48970f5942fe8883e0fdf67a6d0 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Wed, 27 Jul 2016 10:49:07 -0700 Subject: [PATCH 44/70] Move files to new directory. --- books/kestrel/soft/implementation.lisp | 4 +- .../applicability-conditions-tests.lisp | 4 +- .../utilities/applicability-conditions.lisp | 6 +-- .../auto-termination-tests.acl2 | 0 books/kestrel/utilities/auto-termination.lisp | 4 +- .../utilities/defchoose-queries-tests.lisp | 2 +- .../kestrel/utilities/defchoose-queries.lisp | 2 +- .../utilities/defun-sk-queries-tests.lisp | 2 +- books/kestrel/utilities/defun-sk-queries.lisp | 4 +- .../directed-untranslate.acl2 | 0 .../kestrel/utilities/fresh-names-tests.lisp | 2 +- .../install-not-norm-event-tests.lisp | 4 +- .../utilities/install-not-norm-event.lisp | 2 +- .../utilities/minimize-ruler-extenders.lisp | 2 +- .../utilities/numbered-names-tests.lisp | 2 +- books/kestrel/utilities/prove-interface.lisp | 2 +- books/kestrel/utilities/terms-tests.lisp | 2 +- books/kestrel/utilities/terms.lisp | 2 +- books/kestrel/utilities/top.lisp | 39 +++++++++---------- books/kestrel/utilities/ubi.lisp | 26 ++++++------- books/kestrel/utilities/user-interface.lisp | 2 +- .../verify-guards-program-tests.acl2 | 0 .../verify-guards-program-tests.lisp | 2 +- .../utilities/world-queries-tests.lisp | 2 +- 24 files changed, 58 insertions(+), 59 deletions(-) rename books/kestrel/{general => utilities}/auto-termination-tests.acl2 (100%) rename books/kestrel/{system => utilities}/directed-untranslate.acl2 (100%) rename books/kestrel/{system => utilities}/verify-guards-program-tests.acl2 (100%) diff --git a/books/kestrel/soft/implementation.lisp b/books/kestrel/soft/implementation.lisp index fb703bb12f2..361eadcb8b2 100644 --- a/books/kestrel/soft/implementation.lisp +++ b/books/kestrel/soft/implementation.lisp @@ -18,8 +18,8 @@ (in-package "SOFT") -(include-book "kestrel/system/defchoose-queries" :dir :system) -(include-book "kestrel/system/defun-sk-queries" :dir :system) +(include-book "kestrel/utilities/defchoose-queries" :dir :system) +(include-book "kestrel/utilities/defun-sk-queries" :dir :system) (include-book "std/alists/alist-equiv" :dir :system) (include-book "std/util/defines" :dir :system) diff --git a/books/kestrel/utilities/applicability-conditions-tests.lisp b/books/kestrel/utilities/applicability-conditions-tests.lisp index 36e1010ebc2..453adb56ab4 100644 --- a/books/kestrel/utilities/applicability-conditions-tests.lisp +++ b/books/kestrel/utilities/applicability-conditions-tests.lisp @@ -16,8 +16,8 @@ (in-package "ACL2") (include-book "applicability-conditions") -(include-book "kestrel/general/testing" :dir :system) -(include-book "kestrel/system/world-queries" :dir :system) +(include-book "kestrel/utilities/testing" :dir :system) +(include-book "kestrel/utilities/world-queries" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/applicability-conditions.lisp b/books/kestrel/utilities/applicability-conditions.lisp index 595dafb695c..7c870c04378 100644 --- a/books/kestrel/utilities/applicability-conditions.lisp +++ b/books/kestrel/utilities/applicability-conditions.lisp @@ -16,9 +16,9 @@ (in-package "ACL2") -(include-book "kestrel/system/event-forms" :dir :system) -(include-book "kestrel/system/fresh-names" :dir :system) -(include-book "kestrel/system/prove-interface" :dir :system) +(include-book "kestrel/utilities/event-forms" :dir :system) +(include-book "kestrel/utilities/fresh-names" :dir :system) +(include-book "kestrel/utilities/prove-interface" :dir :system) (include-book "std/util/defaggregate" :dir :system) (local (set-default-parents applicability-conditions)) diff --git a/books/kestrel/general/auto-termination-tests.acl2 b/books/kestrel/utilities/auto-termination-tests.acl2 similarity index 100% rename from books/kestrel/general/auto-termination-tests.acl2 rename to books/kestrel/utilities/auto-termination-tests.acl2 diff --git a/books/kestrel/utilities/auto-termination.lisp b/books/kestrel/utilities/auto-termination.lisp index 1a4118dff1c..c1e6e6ef541 100644 --- a/books/kestrel/utilities/auto-termination.lisp +++ b/books/kestrel/utilities/auto-termination.lisp @@ -31,7 +31,7 @@ (in-package "ACL2") -(include-book "kestrel/system/world-queries" :dir :system) ; for measure +(include-book "kestrel/utilities/world-queries" :dir :system) ; for measure (include-book "tools/remove-hyps" :dir :system) ; for event-steps (include-book "xdoc/top" :dir :system) @@ -867,7 +867,7 @@ -

      See community book @('kestrel/system/auto-termination-tests.lisp') for more +

      See community book @('kestrel/utilities/auto-termination-tests.lisp') for more examples.

      ") (defpointer auto-termination with-auto-termination) diff --git a/books/kestrel/utilities/defchoose-queries-tests.lisp b/books/kestrel/utilities/defchoose-queries-tests.lisp index 9a36a14e118..22bdd0f524f 100644 --- a/books/kestrel/utilities/defchoose-queries-tests.lisp +++ b/books/kestrel/utilities/defchoose-queries-tests.lisp @@ -16,7 +16,7 @@ (in-package "ACL2") (include-book "defchoose-queries") -(include-book "kestrel/general/testing" :dir :system) +(include-book "kestrel/utilities/testing" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/defchoose-queries.lisp b/books/kestrel/utilities/defchoose-queries.lisp index fad9d32be22..189305edba1 100644 --- a/books/kestrel/utilities/defchoose-queries.lisp +++ b/books/kestrel/utilities/defchoose-queries.lisp @@ -16,7 +16,7 @@ (in-package "ACL2") -(include-book "kestrel/system/world-queries" :dir :system) +(include-book "kestrel/utilities/world-queries" :dir :system) (local (set-default-parents defchoose-queries)) diff --git a/books/kestrel/utilities/defun-sk-queries-tests.lisp b/books/kestrel/utilities/defun-sk-queries-tests.lisp index bef5e38a0cd..772ec05344e 100644 --- a/books/kestrel/utilities/defun-sk-queries-tests.lisp +++ b/books/kestrel/utilities/defun-sk-queries-tests.lisp @@ -15,7 +15,7 @@ (in-package "ACL2") (include-book "defun-sk-queries") -(include-book "kestrel/general/testing" :dir :system) +(include-book "kestrel/utilities/testing" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/defun-sk-queries.lisp b/books/kestrel/utilities/defun-sk-queries.lisp index 7bb2be9b757..4af7b874e55 100644 --- a/books/kestrel/utilities/defun-sk-queries.lisp +++ b/books/kestrel/utilities/defun-sk-queries.lisp @@ -16,9 +16,9 @@ (in-package "ACL2") -(include-book "kestrel/system/world-queries" :dir :system) -(include-book "std/util/defenum" :dir :system) +(include-book "kestrel/utilities/world-queries" :dir :system) (include-book "std/util/defaggregate" :dir :system) +(include-book "std/util/defenum" :dir :system) (local (set-default-parents defun-sk-queries)) diff --git a/books/kestrel/system/directed-untranslate.acl2 b/books/kestrel/utilities/directed-untranslate.acl2 similarity index 100% rename from books/kestrel/system/directed-untranslate.acl2 rename to books/kestrel/utilities/directed-untranslate.acl2 diff --git a/books/kestrel/utilities/fresh-names-tests.lisp b/books/kestrel/utilities/fresh-names-tests.lisp index 873fee8288d..25ee856de11 100644 --- a/books/kestrel/utilities/fresh-names-tests.lisp +++ b/books/kestrel/utilities/fresh-names-tests.lisp @@ -15,7 +15,7 @@ (in-package "ACL2") (include-book "fresh-names") -(include-book "kestrel/general/testing" :dir :system) +(include-book "kestrel/utilities/testing" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/install-not-norm-event-tests.lisp b/books/kestrel/utilities/install-not-norm-event-tests.lisp index 705d5068329..e17c5decf73 100644 --- a/books/kestrel/utilities/install-not-norm-event-tests.lisp +++ b/books/kestrel/utilities/install-not-norm-event-tests.lisp @@ -16,8 +16,8 @@ (in-package "ACL2") (include-book "install-not-norm-event") -(include-book "kestrel/general/testing" :dir :system) -(include-book "kestrel/system/world-queries" :dir :system) +(include-book "kestrel/utilities/testing" :dir :system) +(include-book "kestrel/utilities/world-queries" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/install-not-norm-event.lisp b/books/kestrel/utilities/install-not-norm-event.lisp index 43baa880c1e..b0d415e2db2 100644 --- a/books/kestrel/utilities/install-not-norm-event.lisp +++ b/books/kestrel/utilities/install-not-norm-event.lisp @@ -15,7 +15,7 @@ (in-package "ACL2") -(include-book "kestrel/system/event-forms" :dir :system) +(include-book "kestrel/utilities/event-forms" :dir :system) (include-book "misc/install-not-normalized" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/minimize-ruler-extenders.lisp b/books/kestrel/utilities/minimize-ruler-extenders.lisp index d073d0ba9ef..ad0f302dbd5 100644 --- a/books/kestrel/utilities/minimize-ruler-extenders.lisp +++ b/books/kestrel/utilities/minimize-ruler-extenders.lisp @@ -10,7 +10,7 @@ (set-state-ok t) (include-book "tools/remove-hyps" :dir :system) ; for event-steps -(include-book "kestrel/system/world-queries" :dir :system) ; for ruler-extenders +(include-book "kestrel/utilities/world-queries" :dir :system) ; for ruler-extenders (defun not-none (r) diff --git a/books/kestrel/utilities/numbered-names-tests.lisp b/books/kestrel/utilities/numbered-names-tests.lisp index 01f9523430c..012db5268ed 100644 --- a/books/kestrel/utilities/numbered-names-tests.lisp +++ b/books/kestrel/utilities/numbered-names-tests.lisp @@ -15,7 +15,7 @@ (in-package "ACL2") (include-book "numbered-names") -(include-book "kestrel/general/testing" :dir :system) +(include-book "kestrel/utilities/testing" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/prove-interface.lisp b/books/kestrel/utilities/prove-interface.lisp index 4b26aa708f3..feace12abad 100644 --- a/books/kestrel/utilities/prove-interface.lisp +++ b/books/kestrel/utilities/prove-interface.lisp @@ -80,7 +80,7 @@ :parents (kestrel-utilities system-utilities) :short "A way to call the prover from a program." :long "

      For examples, see community book - @('books/kestrel/system/prove-interface-tests.lisp').

      + @('books/kestrel/utilities/prove-interface-tests.lisp').

      @({ General Form: diff --git a/books/kestrel/utilities/terms-tests.lisp b/books/kestrel/utilities/terms-tests.lisp index 0ddff5c6f12..f105565d375 100644 --- a/books/kestrel/utilities/terms-tests.lisp +++ b/books/kestrel/utilities/terms-tests.lisp @@ -15,7 +15,7 @@ (in-package "ACL2") (include-book "terms") -(include-book "kestrel/general/testing" :dir :system) +(include-book "kestrel/utilities/testing" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/terms.lisp b/books/kestrel/utilities/terms.lisp index a6b6c079348..af8051a4c38 100644 --- a/books/kestrel/utilities/terms.lisp +++ b/books/kestrel/utilities/terms.lisp @@ -15,7 +15,7 @@ (in-package "ACL2") -(include-book "kestrel/system/world-queries" :dir :system) +(include-book "kestrel/utilities/world-queries" :dir :system) (include-book "std/util/defines" :dir :system) (local (set-default-parents term-utilities)) diff --git a/books/kestrel/utilities/top.lisp b/books/kestrel/utilities/top.lisp index 503645aa16f..c2ef3d361d8 100644 --- a/books/kestrel/utilities/top.lisp +++ b/books/kestrel/utilities/top.lisp @@ -14,26 +14,25 @@ (in-package "ACL2") -(include-book "../general/auto-termination") -(include-book "../general/define-sk") -(include-book "../general/testing") -(include-book "../general/types") -(include-book "../general/ubi") - -(include-book "../system/applicability-conditions") -(include-book "../system/defchoose-queries") -(include-book "../system/defun-sk-queries") -(include-book "../system/directed-untranslate") -(include-book "../system/event-forms") -(include-book "../system/fresh-names") -(include-book "../system/install-not-norm-event") -(include-book "../system/minimize-ruler-extenders") -(include-book "../system/numbered-names") -(include-book "../system/prove-interface") -(include-book "../system/terms") -(include-book "../system/user-interface") -(include-book "../system/verify-guards-program") -(include-book "../system/world-queries") +(include-book "applicability-conditions") +(include-book "auto-termination") +(include-book "defchoose-queries") +(include-book "define-sk") +(include-book "defun-sk-queries") +(include-book "directed-untranslate") +(include-book "event-forms") +(include-book "fresh-names") +(include-book "install-not-norm-event") +(include-book "minimize-ruler-extenders") +(include-book "numbered-names") +(include-book "prove-interface") +(include-book "terms") +(include-book "testing") +(include-book "types") +(include-book "ubi") +(include-book "user-interface") +(include-book "verify-guards-program") +(include-book "world-queries") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/ubi.lisp b/books/kestrel/utilities/ubi.lisp index 7ba36ad58ba..361c615a858 100644 --- a/books/kestrel/utilities/ubi.lisp +++ b/books/kestrel/utilities/ubi.lisp @@ -72,10 +72,10 @@ ACL2 and submit the following @(see command)s.

      @({ - (include-book \"kestrel/system/ubi\" :dir :system) - (local (include-book \"kestrel/system/world-queries\" :dir :system)) + (include-book \"kestrel/utilities/ubi\" :dir :system) + (local (include-book \"kestrel/utilities/world-queries\" :dir :system)) (defpkg \"FOO\" nil) - (include-book \"kestrel/system/defun-sk-queries\" :dir :system)) + (include-book \"kestrel/utilities/defun-sk-queries\" :dir :system)) (defun f (x) x) (include-book \"arithmetic/top\" :dir :system) (defun g (x) x) @@ -86,12 +86,12 @@ @({ ACL2 !>:pbt 0 0 (EXIT-BOOT-STRAP-MODE) - d 1 (INCLUDE-BOOK \"kestrel/system/ubi\" + d 1 (INCLUDE-BOOK \"kestrel/utilities/ubi\" :DIR ...) - d 2 (LOCAL (INCLUDE-BOOK \"kestrel/system/world-queries\" + d 2 (LOCAL (INCLUDE-BOOK \"kestrel/utilities/world-queries\" :DIR ...)) 3 (DEFPKG \"FOO\" NIL) - d 4 (INCLUDE-BOOK \"kestrel/system/defun-sk-queries\" + d 4 (INCLUDE-BOOK \"kestrel/utilities/defun-sk-queries\" :DIR ...) L 5 (DEFUN F (X) ...) d 6 (INCLUDE-BOOK \"arithmetic/top\" :DIR ...) @@ -111,16 +111,16 @@ @({ ACL2 !>:ubi - d 4:x(INCLUDE-BOOK \"kestrel/system/defun-sk-queries\" + d 4:x(INCLUDE-BOOK \"kestrel/utilities/defun-sk-queries\" :DIR ...) ACL2 !>:pbt 0 0 (EXIT-BOOT-STRAP-MODE) - d 1 (INCLUDE-BOOK \"kestrel/system/ubi\" + d 1 (INCLUDE-BOOK \"kestrel/utilities/ubi\" :DIR ...) - d 2 (LOCAL (INCLUDE-BOOK \"kestrel/system/world-queries\" + d 2 (LOCAL (INCLUDE-BOOK \"kestrel/utilities/world-queries\" :DIR ...)) 3 (DEFPKG \"FOO\" NIL) - d 4:x(INCLUDE-BOOK \"kestrel/system/defun-sk-queries\" + d 4:x(INCLUDE-BOOK \"kestrel/utilities/defun-sk-queries\" :DIR ...) ACL2 !> }) @@ -175,12 +175,12 @@ @({ ACL2 !>:pbt 0 0 (EXIT-BOOT-STRAP-MODE) - d 1 (INCLUDE-BOOK \"kestrel/system/ubi\" + d 1 (INCLUDE-BOOK \"kestrel/utilities/ubi\" :DIR ...) - d 2 (LOCAL (INCLUDE-BOOK \"kestrel/system/world-queries\" + d 2 (LOCAL (INCLUDE-BOOK \"kestrel/utilities/world-queries\" :DIR ...)) 3 (DEFPKG \"FOO\" NIL) - d 4 (INCLUDE-BOOK \"kestrel/system/defun-sk-queries\" + d 4 (INCLUDE-BOOK \"kestrel/utilities/defun-sk-queries\" :DIR ...) L 5 (DEFUN F (X) ...) d 6 (INCLUDE-BOOK \"arithmetic/top\" :DIR ...) diff --git a/books/kestrel/utilities/user-interface.lisp b/books/kestrel/utilities/user-interface.lisp index 8995bb7a2e0..15955aef145 100644 --- a/books/kestrel/utilities/user-interface.lisp +++ b/books/kestrel/utilities/user-interface.lisp @@ -20,7 +20,7 @@ (in-package "ACL2") -(include-book "kestrel/system/event-forms" :dir :system) +(include-book "kestrel/utilities/event-forms" :dir :system) (local (set-default-parents user-interface)) diff --git a/books/kestrel/system/verify-guards-program-tests.acl2 b/books/kestrel/utilities/verify-guards-program-tests.acl2 similarity index 100% rename from books/kestrel/system/verify-guards-program-tests.acl2 rename to books/kestrel/utilities/verify-guards-program-tests.acl2 diff --git a/books/kestrel/utilities/verify-guards-program-tests.lisp b/books/kestrel/utilities/verify-guards-program-tests.lisp index a025c12c484..971ea4df404 100644 --- a/books/kestrel/utilities/verify-guards-program-tests.lisp +++ b/books/kestrel/utilities/verify-guards-program-tests.lisp @@ -7,7 +7,7 @@ ; Tests for verify-guards-program (include-book "verify-guards-program") -(include-book "../general/testing") +(include-book "kestrel/utilities/testing" :dir :system) (defun f1p (x) (declare (xargs :mode :program)) x) (defun f2p (x) diff --git a/books/kestrel/utilities/world-queries-tests.lisp b/books/kestrel/utilities/world-queries-tests.lisp index c37b9d8ba3c..2a40c4cfc97 100644 --- a/books/kestrel/utilities/world-queries-tests.lisp +++ b/books/kestrel/utilities/world-queries-tests.lisp @@ -15,7 +15,7 @@ (in-package "ACL2") (include-book "world-queries") -(include-book "kestrel/general/testing" :dir :system) +(include-book "kestrel/utilities/testing" :dir :system) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From d8131c1486980dfc77fce575ea7892e58ed38cbb Mon Sep 17 00:00:00 2001 From: Shilpi Goel Date: Thu, 28 Jul 2016 17:21:39 -0500 Subject: [PATCH 45/70] x86isa: Added some very simple symbolic simulation examples I'll use in my dissertation --- .../acl2-customization.lsp | 11 +++ .../proofs/dissertation-examples/cert.acl2 | 11 +++ .../clc-stc-programmer-mode.lisp | 55 ++++++++++++ .../clc-stc-system-level-marking-mode.lisp | 88 +++++++++++++++++++ ...clc-stc-system-level-non-marking-mode.lisp | 69 +++++++++++++++ books/projects/x86isa/proofs/top.lisp | 19 ++++ .../system-level-mode/marking-mode-top.lisp | 83 ++++++++++++----- 7 files changed, 316 insertions(+), 20 deletions(-) create mode 100644 books/projects/x86isa/proofs/dissertation-examples/acl2-customization.lsp create mode 100644 books/projects/x86isa/proofs/dissertation-examples/cert.acl2 create mode 100644 books/projects/x86isa/proofs/dissertation-examples/clc-stc-programmer-mode.lisp create mode 100644 books/projects/x86isa/proofs/dissertation-examples/clc-stc-system-level-marking-mode.lisp create mode 100644 books/projects/x86isa/proofs/dissertation-examples/clc-stc-system-level-non-marking-mode.lisp diff --git a/books/projects/x86isa/proofs/dissertation-examples/acl2-customization.lsp b/books/projects/x86isa/proofs/dissertation-examples/acl2-customization.lsp new file mode 100644 index 00000000000..dc127e3a257 --- /dev/null +++ b/books/projects/x86isa/proofs/dissertation-examples/acl2-customization.lsp @@ -0,0 +1,11 @@ +;; Shilpi Goel + +;; ====================================================================== + +(ld "~/acl2-customization.lsp" :ld-missing-input-ok t) +(set-deferred-ttag-notes t state) + +(ld "cert.acl2" :ld-missing-input-ok t) +(in-package "X86ISA") + +;; ====================================================================== diff --git a/books/projects/x86isa/proofs/dissertation-examples/cert.acl2 b/books/projects/x86isa/proofs/dissertation-examples/cert.acl2 new file mode 100644 index 00000000000..ccdf66c759a --- /dev/null +++ b/books/projects/x86isa/proofs/dissertation-examples/cert.acl2 @@ -0,0 +1,11 @@ +;; Shilpi Goel + +;; ====================================================================== + +(set-waterfall-parallelism t) +(add-include-book-dir :proof-utils "../utilities") +(include-book "../../portcullis/sharp-dot-constants") + +;; cert-flags: ? t :ttags (:include-raw :syscall-exec :other-non-det :undef-flg) :skip-proofs-okp t + +;; ====================================================================== \ No newline at end of file diff --git a/books/projects/x86isa/proofs/dissertation-examples/clc-stc-programmer-mode.lisp b/books/projects/x86isa/proofs/dissertation-examples/clc-stc-programmer-mode.lisp new file mode 100644 index 00000000000..eab9cc9ba43 --- /dev/null +++ b/books/projects/x86isa/proofs/dissertation-examples/clc-stc-programmer-mode.lisp @@ -0,0 +1,55 @@ +;; AUTHOR: +;; Shilpi Goel + +(in-package "X86ISA") + +(include-book "programmer-level-mode/programmer-level-memory-utils" :dir :proof-utils :ttags :all) + +(include-book "centaur/bitops/ihs-extensions" :dir :system) +(local (include-book "centaur/bitops/signed-byte-p" :dir :system)) + +;; ====================================================================== + +(defconst *program* + '(#xf8 ;; CLC + #xf9 ;; STC + )) + +(defun-nx preconditions (x86) + (and + ;; The x86 state is well-formed. + (x86p x86) + ;; The model is operating in the programmer-level mode. + (programmer-level-mode x86) + ;; The program is located at linear addresses ranging from (rip + ;; x86) to (+ -1 (len *program*) (rip x86)). + (program-at (create-canonical-address-list (len *program*) (rip x86)) + *program* x86) + ;; The addresses where the program is located are canonical. + (canonical-address-p (rip x86)) + (canonical-address-p (+ (len *program*) (rip x86))) + ;; The initial state is error-free. + (equal (ms x86) nil) + (equal (fault x86) nil))) + +;; (acl2::why x86-fetch-decode-execute-opener) +;; (acl2::why get-prefixes-opener-lemma-no-prefix-byte) +;; (acl2::why rb-in-terms-of-nth-and-pos) + +(defthm program-effects-1 + (implies (preconditions x86) + (equal (x86-run 1 x86) + (!rip (+ 1 (rip x86)) (!flgi *cf* 0 x86)))) + :hints (("Goal" :in-theory (e/d* (x86-cmc/clc/stc/cld/std) + (create-canonical-address-list + (create-canonical-address-list)))))) + +(defthm program-effects-2 + (implies (preconditions x86) + (equal (x86-run 2 x86) + (!rip (+ 2 (rip x86)) (!flgi *cf* 1 x86)))) + :hints (("Goal" :in-theory (e/d* (x86-cmc/clc/stc/cld/std) + (create-canonical-address-list + (create-canonical-address-list)))))) + +;; ====================================================================== diff --git a/books/projects/x86isa/proofs/dissertation-examples/clc-stc-system-level-marking-mode.lisp b/books/projects/x86isa/proofs/dissertation-examples/clc-stc-system-level-marking-mode.lisp new file mode 100644 index 00000000000..0679e115c07 --- /dev/null +++ b/books/projects/x86isa/proofs/dissertation-examples/clc-stc-system-level-marking-mode.lisp @@ -0,0 +1,88 @@ +(in-package "X86ISA") + +(include-book "system-level-mode/marking-mode-top" :dir :proof-utils :ttags :all) + +(include-book "centaur/bitops/ihs-extensions" :dir :system) +(local (include-book "centaur/bitops/signed-byte-p" :dir :system)) + +;; ====================================================================== + +(local (include-book "tools/trivial-ancestors-check" :dir :system)) +(local (acl2::use-trivial-ancestors-check)) + +(defconst *program* + '(#xf8 ;; CLC + #xf9 ;; STC + ;; Padding so that get-prefixes-alt works... + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0)) + +(defun-nx preconditions (x86) + (and + ;; The x86 state is well-formed. + (x86p x86) + ;; The model is operating in the system-level marking mode. + (not (programmer-level-mode x86)) + (page-structure-marking-mode x86) + ;; The program is located at linear addresses ranging from (rip + ;; x86) to (+ -1 (len *program*) (rip x86)). + (program-at (create-canonical-address-list (len *program*) (rip x86)) + *program* x86) + ;; No error is encountered when translating the program's linear + ;; addresses to physical addresses. + (not (mv-nth 0 + (las-to-pas + (create-canonical-address-list (len *program*) (rip x86)) + :x (cpl x86) x86))) + ;; The program's physical addresses are disjoint from the physical + ;; addresses of the paging structures. . + (disjoint-p + (mv-nth 1 + (las-to-pas (create-canonical-address-list + (len *program*) (rip x86)) + :x (cpl x86) x86)) + (open-qword-paddr-list (gather-all-paging-structure-qword-addresses x86))) + ;; The addresses where the program is located are canonical. + (canonical-address-p (rip x86)) + (canonical-address-p (+ (len *program*) (rip x86))) + ;; The initial state is error-free. + (equal (ms x86) nil) + (equal (fault x86) nil))) + +;; (acl2::why x86-fetch-decode-execute-opener-in-marking-mode) +;; (acl2::why get-prefixes-alt-opener-lemma-no-prefix-byte) +;; (acl2::why rb-alt-in-terms-of-nth-and-pos-in-system-level-mode) + +(defthm program-effects-1 + (implies (preconditions x86) + (equal (x86-run 1 x86) + (!rip (+ 1 (xr :rip 0 x86)) + (!flgi *cf* 0 + (mv-nth 2 (las-to-pas (list (rip x86)) :x (cpl x86) x86)))))) + :hints (("Goal" :in-theory (e/d* (x86-cmc/clc/stc/cld/std + rm08 + pos + mv-nth-0-las-to-pas-subset-p + member-p + subset-p + disjoint-p$) + ())))) + + +(defthm program-effects-2 + (implies (preconditions x86) + (equal (x86-run 2 x86) + (!rip (+ 2 (xr :rip 0 x86)) + (!flgi *cf* 1 + (mv-nth 2 + (las-to-pas (list (xr :rip 0 x86) (+ 1 (xr :rip 0 x86))) :x (cpl x86) x86)))))) + :hints (("Goal" :in-theory (e/d* (x86-cmc/clc/stc/cld/std + rm08 + pos + mv-nth-0-las-to-pas-subset-p + member-p + subset-p + disjoint-p$) + ())))) + +;; ====================================================================== diff --git a/books/projects/x86isa/proofs/dissertation-examples/clc-stc-system-level-non-marking-mode.lisp b/books/projects/x86isa/proofs/dissertation-examples/clc-stc-system-level-non-marking-mode.lisp new file mode 100644 index 00000000000..484dd44a42c --- /dev/null +++ b/books/projects/x86isa/proofs/dissertation-examples/clc-stc-system-level-non-marking-mode.lisp @@ -0,0 +1,69 @@ +(in-package "X86ISA") + +(include-book "system-level-mode/non-marking-mode-top" :dir :proof-utils :ttags :all) + +(include-book "centaur/bitops/ihs-extensions" :dir :system) +(local (include-book "centaur/bitops/signed-byte-p" :dir :system)) + +;; ====================================================================== + +(local (include-book "tools/trivial-ancestors-check" :dir :system)) +(local (acl2::use-trivial-ancestors-check)) + +(defconst *program* + '(#xf8 ;; CLC + #xf9 ;; STC + )) + +(defun-nx preconditions (x86) + (and + ;; The x86 state is well-formed. + (x86p x86) + ;; The model is operating in the system-level non-marking mode. + (not (programmer-level-mode x86)) + (not (page-structure-marking-mode x86)) + ;; The program is located at linear addresses ranging from (rip + ;; x86) to (+ -1 (len *program*) (rip x86)). + (program-at (create-canonical-address-list (len *program*) (rip x86)) + *program* x86) + ;; No error encountered when translating the programs linear + ;; addresses to physical addresses. + (not (mv-nth 0 + (las-to-pas + (create-canonical-address-list (len *program*) (rip x86)) + :x (cpl x86) x86))) + ;; The addresses where the program is located are canonical. + (canonical-address-p (rip x86)) + (canonical-address-p (+ (len *program*) (rip x86))) + ;; The initial state is error-free. + (equal (ms x86) nil) + (equal (fault x86) nil))) + +;; (acl2::why x86-fetch-decode-execute-opener) +;; (acl2::why get-prefixes-opener-lemma-no-prefix-byte) +;; (acl2::why rb-in-terms-of-nth-and-pos-in-system-level-non-marking-mode) + +(defthm program-effects-1 + (implies (preconditions x86) + (equal (x86-run 1 x86) + (!rip (+ 1 (rip x86)) (!flgi *cf* 0 x86)))) + :hints (("Goal" :in-theory (e/d* (x86-cmc/clc/stc/cld/std + pos + member-p + subset-p) + (create-canonical-address-list + (create-canonical-address-list)))))) + + +(defthm program-effects-2 + (implies (preconditions x86) + (equal (x86-run 2 x86) + (!rip (+ 2 (xr :rip 0 x86)) (!flgi *cf* 1 x86)))) + :hints (("Goal" :in-theory (e/d* (x86-cmc/clc/stc/cld/std + pos + member-p + subset-p) + (create-canonical-address-list + (create-canonical-address-list)))))) + +;; ====================================================================== diff --git a/books/projects/x86isa/proofs/top.lisp b/books/projects/x86isa/proofs/top.lisp index a2a141e4f84..dfe6f9471ca 100644 --- a/books/projects/x86isa/proofs/top.lisp +++ b/books/projects/x86isa/proofs/top.lisp @@ -67,3 +67,22 @@ (local (include-book "zeroCopy/marking-mode/zeroCopy" :ttags :all)))) ;; ====================================================================== + +;; The following books present small examples that Shilpi presents in +;; her PhD dissertation to illustrate how symbolic simulation is +;; controlled in all modes of operation of the x86 model. + +(local + (encapsulate + () + (local (include-book "dissertation-examples/clc-stc-programmer-mode" :ttags :all)))) +(local + (encapsulate + () + (local (include-book "dissertation-examples/clc-stc-system-level-marking-mode" :ttags :all)))) +(local + (encapsulate + () + (local (include-book "dissertation-examples/clc-stc-system-level-non-marking-mode" :ttags :all)))) + +;; ====================================================================== diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp index a925d65c448..cb21de4445f 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-top.lisp @@ -151,6 +151,9 @@ (if (and (page-structure-marking-mode x86) (not (programmer-level-mode x86)) (canonical-address-p start-rip) + ;; In the following two conditions below, if we're being + ;; really precise, cnt should really be + ;; (1+ (prefixes-slice :num-prefixes prefixes)). (disjoint-p (mv-nth 1 (las-to-pas (create-canonical-address-list cnt start-rip) @@ -298,29 +301,61 @@ ;; Opener lemmas: + ;; (defthm get-prefixes-alt-opener-lemma-zero-cnt + ;; (implies (and (zp cnt) + ;; (disjoint-p + ;; (mv-nth 1 (las-to-pas + ;; (create-canonical-address-list cnt start-rip) + ;; :x (cpl x86) (double-rewrite x86))) + ;; (open-qword-paddr-list + ;; (gather-all-paging-structure-qword-addresses (double-rewrite x86)))) + ;; (not + ;; (mv-nth + ;; 0 + ;; (las-to-pas (create-canonical-address-list cnt start-rip) + ;; :x (cpl x86) + ;; (double-rewrite x86)))) + ;; (page-structure-marking-mode x86) + ;; (not (programmer-level-mode x86)) + ;; (canonical-address-p start-rip)) + ;; (equal (get-prefixes-alt start-rip prefixes cnt x86) + ;; (mv t prefixes x86))) + ;; :hints (("Goal" + ;; :use ((:instance get-prefixes-opener-lemma-zero-cnt)) + ;; :in-theory (e/d () (get-prefixes-opener-lemma-zero-cnt + ;; force (force)))))) + (defthm get-prefixes-alt-opener-lemma-zero-cnt - (implies (and (zp cnt) - (disjoint-p - (mv-nth 1 (las-to-pas - (create-canonical-address-list cnt start-rip) - :x (cpl x86) (double-rewrite x86))) - (open-qword-paddr-list - (gather-all-paging-structure-qword-addresses (double-rewrite x86)))) - (not - (mv-nth - 0 - (las-to-pas (create-canonical-address-list cnt start-rip) - :x (cpl x86) - (double-rewrite x86)))) - (page-structure-marking-mode x86) + (implies (and (page-structure-marking-mode x86) (not (programmer-level-mode x86)) (canonical-address-p start-rip)) - (equal (get-prefixes-alt start-rip prefixes cnt x86) + (equal (get-prefixes-alt start-rip prefixes 0 x86) (mv t prefixes x86))) - :hints (("Goal" - :use ((:instance get-prefixes-opener-lemma-zero-cnt)) - :in-theory (e/d () (get-prefixes-opener-lemma-zero-cnt - force (force)))))) + :hints + (("Goal" + :use ((:instance get-prefixes-opener-lemma-zero-cnt (cnt 0))) + :in-theory (e/d () + (get-prefixes-opener-lemma-zero-cnt force (force)))))) + + ;; (defthmd get-prefixes-alt-opener-lemma-no-prefix-byte-helper + ;; (implies (and + ;; (let* + ;; ((flg (mv-nth 0 (rm08 start-rip :x x86))) + ;; (prefix-byte-group-code + ;; (get-one-byte-prefix-array-code (mv-nth 1 (rm08 start-rip :x x86))))) + ;; (and (not flg) + ;; (zp prefix-byte-group-code))) + ;; (not (zp cnt))) + ;; (equal (mv-nth 0 (get-prefixes-alt start-rip prefixes cnt x86)) + ;; nil)) + ;; :hints (("Goal" + ;; :use ((:instance get-prefixes-opener-lemma-no-prefix-byte + ;; (cnt 1)) + ;; (:instance get-prefixes-opener-lemma-no-prefix-byte + ;; (cnt cnt))) + ;; :in-theory (e/d* (get-prefixes-alt) + ;; (rewrite-get-prefixes-to-get-prefixes-alt + ;; get-prefixes-opener-lemma-no-prefix-byte))))) (defthm get-prefixes-alt-opener-lemma-no-prefix-byte (implies (and (let* @@ -333,6 +368,14 @@ (page-structure-marking-mode x86) (not (programmer-level-mode x86)) (canonical-address-p start-rip) + ;; We read only one byte inside get-prefixes-alt -- + ;; there's really no need for us to know that the + ;; translation of (create-canonical-address-list cnt + ;; start-rip) is non-erroneous or that that range is + ;; disjoint from the paging structures. But, + ;; unfortunately, because of the definition of + ;; get-prefixes-alt, we need to know the following two + ;; things in terms of a general cnt instead of cnt == 1. (not (mv-nth 0 @@ -1662,7 +1705,7 @@ (n prog-addr bytes)) (program-at-alt (create-canonical-address-list n prog-addr) - bytes x86) + bytes (double-rewrite x86)) (syntaxp (quotep n)) (member-p lin-addr (create-canonical-address-list n prog-addr)) (not (mv-nth 0 From 1af91041e677042c701f0172f74f95823909a59e Mon Sep 17 00:00:00 2001 From: Shilpi Goel Date: Fri, 29 Jul 2016 02:07:56 -0500 Subject: [PATCH 46/70] x86isa: Fixed the num-imm-bytes argument of x86-operand-from-modr/m-and-sib-bytes in some instruction semantic functions - Thanks to Dmitry Nadezhin for pointing out that the num-imm-bytes argument of x86-operand-from-modr/m-and-sib-bytes was not being given the correct value in some instruction semantic functions. I also made similar fixes for the same argument of the function x86-effective-addr. This argument is only relevant when there is an immediate operand in an instruction along with another operand that is fetched using RIP-relative addressing. - Another fix, again pointed out by Dmitry, is that rm-size and wm-size now report an OR of the flags of partial reads/writes (for 6 and 10 byte operations), instead of an AND. - Added some new test cases under tools/execution/examples/documenting-edge-cases. --- .../fp/x86-fp-arithmetic-instructions.lisp | 604 ++++++------ .../fp/x86-fp-bitscan-instructions.lisp | 4 +- .../fp/x86-fp-convert-instructions.lisp | 22 +- .../fp/x86-fp-logical-instructions.lisp | 608 ++++++------ .../fp/x86-fp-mov-instructions.lisp | 44 +- .../fp/x86-fp-mxcsr-instructions.lisp | 4 +- ...86-fp-shuffle-and-unpack-instructions.lisp | 24 +- .../fp/x86-fp-simd-integer-instructions.lisp | 298 +++--- .../x86-arith-and-logic-instructions.lisp | 864 +++++++++--------- .../instructions/x86-bit-instructions.lisp | 8 +- .../x86-conditional-instructions.lisp | 16 +- .../instructions/x86-divide-instructions.lisp | 10 +- .../x86-exchange-instructions.lisp | 16 +- .../x86-jump-and-loop-instructions.lisp | 11 +- .../instructions/x86-move-instructions.lisp | 33 +- .../x86-multiply-instructions.lisp | 18 +- .../x86-push-and-pop-instructions.lisp | 10 +- .../x86-rotate-and-shift-instructions.lisp | 9 +- .../x86-segmentation-instructions.lisp | 18 +- .../x86-subroutine-instructions.lisp | 6 +- .../machine/x86-decoding-and-spec-utils.lisp | 6 +- .../x86isa/machine/x86-top-level-memory.lisp | 8 +- .../examples/documenting-edge-cases/README | 6 + .../acl2-customization.lsp | 7 + .../examples/documenting-edge-cases/cert.acl2 | 9 + .../disp-immed-fault.lsp | 106 +++ .../imm-bytes-for-rip-relative-addressing.lsp | 92 ++ .../redundant-prefixes.lsp | 109 +++ 28 files changed, 1722 insertions(+), 1248 deletions(-) create mode 100644 books/projects/x86isa/tools/execution/examples/documenting-edge-cases/README create mode 100644 books/projects/x86isa/tools/execution/examples/documenting-edge-cases/acl2-customization.lsp create mode 100644 books/projects/x86isa/tools/execution/examples/documenting-edge-cases/cert.acl2 create mode 100644 books/projects/x86isa/tools/execution/examples/documenting-edge-cases/disp-immed-fault.lsp create mode 100644 books/projects/x86isa/tools/execution/examples/documenting-edge-cases/imm-bytes-for-rip-relative-addressing.lsp create mode 100644 books/projects/x86isa/tools/execution/examples/documenting-edge-cases/redundant-prefixes.lsp diff --git a/books/projects/x86isa/machine/instructions/fp/x86-fp-arithmetic-instructions.lisp b/books/projects/x86isa/machine/instructions/fp/x86-fp-arithmetic-instructions.lisp index 3905b496a74..2d316b0a1e5 100644 --- a/books/projects/x86isa/machine/instructions/fp/x86-fp-arithmetic-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/fp/x86-fp-arithmetic-instructions.lisp @@ -6,11 +6,11 @@ ;; ====================================================================== (include-book "../../x86-decoding-and-spec-utils" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (include-book "fp-arith-base" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (include-book "fp-sqrt-base" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (include-book "centaur/bitops/merge" :dir :system) (local (include-book "centaur/bitops/ihs-extensions" :dir :system)) @@ -54,52 +54,54 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (integer 4 8) operand-size) - (if (equal sp/dp #.*OP-DP*) 8 4)) + (if (equal sp/dp #.*OP-DP*) 8 4)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) (xmm (xmmi-size operand-size xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) (inst-ac? - ;; Exceptions Type 3 - t) + ;; Exceptions Type 3 + t) ((mv flg0 xmm/mem (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ((mv flg1 result (the (unsigned-byte 32) mxcsr)) - (if (equal sp/dp #.*OP-DP*) - (dp-sse-add/sub/mul/div/max/min operation xmm xmm/mem (mxcsr x86)) - (sp-sse-add/sub/mul/div/max/min operation xmm xmm/mem (mxcsr x86)))) + (if (equal sp/dp #.*OP-DP*) + (dp-sse-add/sub/mul/div/max/min operation xmm xmm/mem (mxcsr x86)) + (sp-sse-add/sub/mul/div/max/min operation xmm xmm/mem (mxcsr x86)))) ((when flg1) - (if (equal sp/dp #.*OP-DP*) - (!!ms-fresh :dp-sse-add/sub/mul/div/max/min flg1) - (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg1))) + (if (equal sp/dp #.*OP-DP*) + (!!ms-fresh :dp-sse-add/sub/mul/div/max/min flg1) + (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg1))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -112,43 +114,43 @@ :implemented (progn (add-to-implemented-opcodes-table 'ADDSS #x0F58 - '(:misc - (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc + (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'MULSS #x0F59 - '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'SUBSS #x0F5C - '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'MINSS #x0F5D - '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'DIVSS #x0F5E - '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'MAXSS #x0F5F - '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'ADDSD #x0F58 - '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'MULSD #x0F59 - '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'SUBSD #x0F5C - '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'MINSD #x0F5D - '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'DIVSD #x0F5E - '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) + '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM) (add-to-implemented-opcodes-table 'MAXSD #x0F5F - '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM))) + '(:misc (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-adds?/subs?/muls?/divs?/maxs?/mins?-Op/En-RM))) (def-inst x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM @@ -176,113 +178,115 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) ((the (unsigned-byte 128) xmm) - (xmmi-size 16 xmm-index x86)) + (xmmi-size 16 xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) (inst-ac? - ;; Exceptions Type 2 - nil) + ;; Exceptions Type 2 + nil) ((mv flg0 - (the (unsigned-byte 128) xmm/mem) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (unsigned-byte 128) xmm/mem) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Raise an error if v-addr is not 16-byte aligned. ;; In case the second operand is an XMM register, v-addr = 0. ((when (not (eql (mod v-addr 16) 0))) - (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) + (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) (xmm0 (mbe :logic (part-select xmm :low 0 :high 31) - :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF xmm)))) + :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF xmm)))) (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 31) - :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF xmm/mem)))) + :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF xmm/mem)))) (xmm1 (mbe :logic (part-select xmm :low 32 :high 63) - :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm -32))))) + :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm -32))))) (xmm/mem1 (mbe :logic (part-select xmm/mem :low 32 :high 63) - :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm/mem -32))))) + :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm/mem -32))))) (xmm2 (mbe :logic (part-select xmm :low 64 :high 95) - :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm -64))))) + :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm -64))))) (xmm/mem2 (mbe :logic (part-select xmm/mem :low 64 :high 95) - :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm/mem -64))))) + :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm/mem -64))))) (xmm3 (mbe :logic (part-select xmm :low 96 :high 127) - :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm -96))))) + :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm -96))))) (xmm/mem3 (mbe :logic (part-select xmm/mem :low 96 :high 127) - :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm/mem -96))))) + :exec (the (unsigned-byte 32) (logand #uxFFFF_FFFF (ash xmm/mem -96))))) (mxcsr (the (unsigned-byte 32) (mxcsr x86))) ((mv flg1 - (the (unsigned-byte 32) result0) - (the (unsigned-byte 32) mxcsr0)) - (sp-sse-add/sub/mul/div/max/min operation xmm0 xmm/mem0 mxcsr)) + (the (unsigned-byte 32) result0) + (the (unsigned-byte 32) mxcsr0)) + (sp-sse-add/sub/mul/div/max/min operation xmm0 xmm/mem0 mxcsr)) ((when flg1) - (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg1)) + (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg1)) ((mv flg2 - (the (unsigned-byte 32) result1) - (the (unsigned-byte 32) mxcsr1)) - (sp-sse-add/sub/mul/div/max/min operation xmm1 xmm/mem1 mxcsr)) + (the (unsigned-byte 32) result1) + (the (unsigned-byte 32) mxcsr1)) + (sp-sse-add/sub/mul/div/max/min operation xmm1 xmm/mem1 mxcsr)) ((when flg2) - (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg2)) + (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg2)) ((mv flg3 - (the (unsigned-byte 32) result2) - (the (unsigned-byte 32) mxcsr2)) - (sp-sse-add/sub/mul/div/max/min operation xmm2 xmm/mem2 mxcsr)) + (the (unsigned-byte 32) result2) + (the (unsigned-byte 32) mxcsr2)) + (sp-sse-add/sub/mul/div/max/min operation xmm2 xmm/mem2 mxcsr)) ((when flg3) - (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg3)) + (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg3)) ((mv flg4 - (the (unsigned-byte 32) result3) - (the (unsigned-byte 32) mxcsr3)) - (sp-sse-add/sub/mul/div/max/min operation xmm3 xmm/mem3 mxcsr)) + (the (unsigned-byte 32) result3) + (the (unsigned-byte 32) mxcsr3)) + (sp-sse-add/sub/mul/div/max/min operation xmm3 xmm/mem3 mxcsr)) ((when flg4) - (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg4)) + (!!ms-fresh :sp-sse-add/sub/mul/div/max/min flg4)) (result (merge-4-u32s result3 result2 result1 result0)) (mxcsr (the (unsigned-byte 32) - (logior mxcsr0 mxcsr1 mxcsr2 mxcsr3))) + (logior mxcsr0 mxcsr1 mxcsr2 mxcsr3))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -295,23 +299,23 @@ :implemented (progn (add-to-implemented-opcodes-table 'ADDPS #x0F58 - '(:nil nil) - 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) + '(:nil nil) + 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) (add-to-implemented-opcodes-table 'MULPS #x0F59 - '(:nil nil) - 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) + '(:nil nil) + 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) (add-to-implemented-opcodes-table 'SUBPS #x0F5C - '(:nil nil) - 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) + '(:nil nil) + 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) (add-to-implemented-opcodes-table 'MINPS #x0F5D - '(:nil nil) - 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) + '(:nil nil) + 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) (add-to-implemented-opcodes-table 'DIVPS #x0F5E - '(:nil nil) - 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) + '(:nil nil) + 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM) (add-to-implemented-opcodes-table 'MAXPS #x0F5F - '(:nil nil) - 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM))) + '(:nil nil) + 'x86-addps/subps/mulps/divps/maxps/minps-Op/En-RM))) (def-inst x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM @@ -339,91 +343,93 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) ((the (unsigned-byte 128) xmm) - (xmmi-size 16 xmm-index x86)) + (xmmi-size 16 xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) (inst-ac? - ;; Exceptions Type 2 - nil) + ;; Exceptions Type 2 + nil) ((mv flg0 - (the (unsigned-byte 128) xmm/mem) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (unsigned-byte 128) xmm/mem) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Raise an error if v-addr is not 16-byte aligned. ;; In case the second operand is an XMM register, v-addr = 0. ((when (not (eql (mod v-addr 16) 0))) - (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) + (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) (xmm0 (mbe :logic (part-select xmm :low 0 :high 63) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF xmm)))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF xmm)))) (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 63) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF xmm/mem)))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF xmm/mem)))) (xmm1 (mbe :logic (part-select xmm :low 64 :high 127) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm -64))))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm -64))))) (xmm/mem1 (mbe :logic (part-select xmm/mem :low 64 :high 127) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm/mem -64))))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm/mem -64))))) (mxcsr (the (unsigned-byte 32) (mxcsr x86))) ((mv flg1 - (the (unsigned-byte 64) result0) - (the (unsigned-byte 32) mxcsr0)) - (dp-sse-add/sub/mul/div/max/min operation xmm0 xmm/mem0 mxcsr)) + (the (unsigned-byte 64) result0) + (the (unsigned-byte 32) mxcsr0)) + (dp-sse-add/sub/mul/div/max/min operation xmm0 xmm/mem0 mxcsr)) ((when flg1) - (!!ms-fresh :dp-sse-add/sub/mul/div/max/min flg1)) + (!!ms-fresh :dp-sse-add/sub/mul/div/max/min flg1)) ((mv flg2 - (the (unsigned-byte 64) result1) - (the (unsigned-byte 32) mxcsr1)) - (dp-sse-add/sub/mul/div/max/min operation xmm1 xmm/mem1 mxcsr)) + (the (unsigned-byte 64) result1) + (the (unsigned-byte 32) mxcsr1)) + (dp-sse-add/sub/mul/div/max/min operation xmm1 xmm/mem1 mxcsr)) ((when flg2) - (!!ms-fresh :dp-sse-add/sub/mul/div/max/min flg2)) + (!!ms-fresh :dp-sse-add/sub/mul/div/max/min flg2)) (result (merge-2-u64s result1 result0)) (mxcsr (the (unsigned-byte 32) - (logior mxcsr0 mxcsr1))) + (logior mxcsr0 mxcsr1))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -436,29 +442,29 @@ :implemented (progn (add-to-implemented-opcodes-table 'ADDPD #x0F58 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) (add-to-implemented-opcodes-table 'SUBPD #x0F5C - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) (add-to-implemented-opcodes-table 'MULPD #x0F59 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) (add-to-implemented-opcodes-table 'DIVPD #x0F5E - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) (add-to-implemented-opcodes-table 'MAXPD #x0F5F - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM) (add-to-implemented-opcodes-table 'MINPD #x0F5D - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM))) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-addpd/subpd/mulpd/divpd/maxpd/minpd-Op/En-RM))) ;; ====================================================================== @@ -484,56 +490,58 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (integer 4 8) operand-size) - (if (equal sp/dp #.*OP-DP*) 8 4)) + (if (equal sp/dp #.*OP-DP*) 8 4)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) (inst-ac? - ;; Exceptions Type 3 - t) + ;; Exceptions Type 3 + t) ((mv flg0 xmm/mem (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ((mv flg1 result (the (unsigned-byte 32) mxcsr)) - (if (equal sp/dp #.*OP-DP*) - (dp-sse-sqrt xmm/mem (mxcsr x86)) - (sp-sse-sqrt xmm/mem (mxcsr x86)))) + (if (equal sp/dp #.*OP-DP*) + (dp-sse-sqrt xmm/mem (mxcsr x86)) + (sp-sse-sqrt xmm/mem (mxcsr x86)))) ((when flg1) - (if (equal sp/dp #.*OP-DP*) - (!!ms-fresh :dp-sse-sqrt flg1) - (!!ms-fresh :sp-sse-sqrt flg1))) + (if (equal sp/dp #.*OP-DP*) + (!!ms-fresh :dp-sse-sqrt flg1) + (!!ms-fresh :sp-sse-sqrt flg1))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -546,13 +554,13 @@ :implemented (progn (add-to-implemented-opcodes-table 'SQRTSS #x0F51 - '(:misc - (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-sqrts?-Op/En-RM) + '(:misc + (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-sqrts?-Op/En-RM) (add-to-implemented-opcodes-table 'SQRTSD #x0F51 - '(:misc - (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-sqrts?-Op/En-RM))) + '(:misc + (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-sqrts?-Op/En-RM))) (def-inst x86-sqrtps-Op/En-RM @@ -573,106 +581,108 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) (inst-ac? - ;; Exceptions Type 2 - nil) + ;; Exceptions Type 2 + nil) ((mv flg0 - (the (unsigned-byte 128) xmm/mem) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (unsigned-byte 128) xmm/mem) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Raise an error if v-addr is not 16-byte aligned. ;; In case the second operand is an XMM register, v-addr = 0. ((when (not (eql (mod v-addr 16) 0))) - (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) + (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 31) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF xmm/mem)))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF xmm/mem)))) (xmm/mem1 (mbe :logic (part-select xmm/mem :low 32 :high 63) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -32))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -32))))) (xmm/mem2 (mbe :logic (part-select xmm/mem :low 64 :high 95) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -64))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -64))))) (xmm/mem3 (mbe :logic (part-select xmm/mem :low 96 :high 127) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -96))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -96))))) (mxcsr (the (unsigned-byte 32) (mxcsr x86))) ((mv flg1 - (the (unsigned-byte 32) result0) - (the (unsigned-byte 32) mxcsr0)) - (sp-sse-sqrt xmm/mem0 mxcsr)) + (the (unsigned-byte 32) result0) + (the (unsigned-byte 32) mxcsr0)) + (sp-sse-sqrt xmm/mem0 mxcsr)) ((when flg1) - (!!ms-fresh :sp-sse-sqrt flg1)) + (!!ms-fresh :sp-sse-sqrt flg1)) ((mv flg2 - (the (unsigned-byte 32) result1) - (the (unsigned-byte 32) mxcsr1)) - (sp-sse-sqrt xmm/mem1 mxcsr)) + (the (unsigned-byte 32) result1) + (the (unsigned-byte 32) mxcsr1)) + (sp-sse-sqrt xmm/mem1 mxcsr)) ((when flg2) - (!!ms-fresh :sp-sse-sqrt flg2)) + (!!ms-fresh :sp-sse-sqrt flg2)) ((mv flg3 - (the (unsigned-byte 32) result2) - (the (unsigned-byte 32) mxcsr2)) - (sp-sse-sqrt xmm/mem2 mxcsr)) + (the (unsigned-byte 32) result2) + (the (unsigned-byte 32) mxcsr2)) + (sp-sse-sqrt xmm/mem2 mxcsr)) ((when flg3) - (!!ms-fresh :sp-sse-sqrt flg3)) + (!!ms-fresh :sp-sse-sqrt flg3)) ((mv flg4 - (the (unsigned-byte 32) result3) - (the (unsigned-byte 32) mxcsr3)) - (sp-sse-sqrt xmm/mem3 mxcsr)) + (the (unsigned-byte 32) result3) + (the (unsigned-byte 32) mxcsr3)) + (sp-sse-sqrt xmm/mem3 mxcsr)) ((when flg4) - (!!ms-fresh :sp-sse-sqrt flg4)) + (!!ms-fresh :sp-sse-sqrt flg4)) (result (merge-4-u32s result3 result2 result1 result0)) (mxcsr (the (unsigned-byte 32) - (logior mxcsr0 mxcsr1 mxcsr2 mxcsr3))) + (logior mxcsr0 mxcsr1 mxcsr2 mxcsr3))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -684,8 +694,8 @@ :implemented (add-to-implemented-opcodes-table 'SQRTPS #x0F51 - '(:nil nil) - 'x86-sqrtps-Op/En-RM)) + '(:nil nil) + 'x86-sqrtps-Op/En-RM)) (def-inst x86-sqrtpd-Op/En-RM @@ -706,81 +716,83 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) (inst-ac? - ;; Exceptions Type 2 - nil) + ;; Exceptions Type 2 + nil) ((mv flg0 - (the (unsigned-byte 128) xmm/mem) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (unsigned-byte 128) xmm/mem) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Raise an error if v-addr is not 16-byte aligned. ;; In case the second operand is an XMM register, v-addr = 0. ((when (not (eql (mod v-addr 16) 0))) - (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) + (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 63) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF xmm/mem)))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF xmm/mem)))) (xmm/mem1 (mbe :logic (part-select xmm/mem :low 64 :high 127) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm/mem -64))))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm/mem -64))))) (mxcsr (the (unsigned-byte 32) (mxcsr x86))) ((mv flg1 - (the (unsigned-byte 64) result0) - (the (unsigned-byte 32) mxcsr0)) - (dp-sse-sqrt xmm/mem0 mxcsr)) + (the (unsigned-byte 64) result0) + (the (unsigned-byte 32) mxcsr0)) + (dp-sse-sqrt xmm/mem0 mxcsr)) ((when flg1) - (!!ms-fresh :dp-sse-sqrt flg1)) + (!!ms-fresh :dp-sse-sqrt flg1)) ((mv flg2 - (the (unsigned-byte 64) result1) - (the (unsigned-byte 32) mxcsr1)) - (dp-sse-sqrt xmm/mem1 mxcsr)) + (the (unsigned-byte 64) result1) + (the (unsigned-byte 32) mxcsr1)) + (dp-sse-sqrt xmm/mem1 mxcsr)) ((when flg2) - (!!ms-fresh :dp-sse-sqrt flg2)) + (!!ms-fresh :dp-sse-sqrt flg2)) (result (merge-2-u64s result1 result0)) (mxcsr (the (unsigned-byte 32) - (logior mxcsr0 mxcsr1))) + (logior mxcsr0 mxcsr1))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -788,12 +800,12 @@ (x86 (!xmmi-size 16 xmm-index result x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (add-to-implemented-opcodes-table 'SQRTPD #x0F51 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-sqrtpd-Op/En-RM)) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-sqrtpd-Op/En-RM)) ;; ====================================================================== diff --git a/books/projects/x86isa/machine/instructions/fp/x86-fp-bitscan-instructions.lisp b/books/projects/x86isa/machine/instructions/fp/x86-fp-bitscan-instructions.lisp index 74dac0bd61e..c15ebca9618 100644 --- a/books/projects/x86isa/machine/instructions/fp/x86-fp-bitscan-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/fp/x86-fp-bitscan-instructions.lisp @@ -104,7 +104,9 @@ (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* operand-size inst-acc? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* operand-size inst-acc? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) diff --git a/books/projects/x86isa/machine/instructions/fp/x86-fp-convert-instructions.lisp b/books/projects/x86isa/machine/instructions/fp/x86-fp-convert-instructions.lisp index af28dae4cec..ecc4c3e2be4 100644 --- a/books/projects/x86isa/machine/instructions/fp/x86-fp-convert-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/fp/x86-fp-convert-instructions.lisp @@ -72,7 +72,9 @@ t) ((mv flg0 xmm/mem (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* xmm/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* xmm/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -199,7 +201,9 @@ t) ((mv flg0 reg/mem (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -312,7 +316,9 @@ t) ((mv flg0 xmm/mem (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* xmm/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* xmm/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -406,7 +412,9 @@ (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -467,7 +475,7 @@ (x86 (!xmmi-size 16 xmm-index result x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (add-to-implemented-opcodes-table 'CVTPS2PD #x0F5A '(:nil nil) @@ -513,7 +521,9 @@ (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) diff --git a/books/projects/x86isa/machine/instructions/fp/x86-fp-logical-instructions.lisp b/books/projects/x86isa/machine/instructions/fp/x86-fp-logical-instructions.lisp index 139d661f241..4a013b5ede1 100644 --- a/books/projects/x86isa/machine/instructions/fp/x86-fp-logical-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/fp/x86-fp-logical-instructions.lisp @@ -6,9 +6,9 @@ ;; ====================================================================== (include-book "../../x86-decoding-and-spec-utils" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (include-book "fp-cmp-base" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (include-book "centaur/bitops/merge" :dir :system) (local (include-book "centaur/bitops/ihs-extensions" :dir :system)) @@ -16,13 +16,13 @@ (local (defthm lemma-1 (implies (and (unsigned-byte-p 128 x) - (unsigned-byte-p 128 y)) - (< (logxor x y) - (expt 2 128))) + (unsigned-byte-p 128 y)) + (< (logxor x y) + (expt 2 128))) :hints (("Goal" - :in-theory (disable unsigned-byte-p-of-logxor) - :use (:instance unsigned-byte-p-of-logxor - (n 128)))) + :in-theory (disable unsigned-byte-p-of-logxor) + :use (:instance unsigned-byte-p-of-logxor + (n 128)))) :rule-classes :linear)) ; ============================================================================= @@ -61,117 +61,119 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) ((the (unsigned-byte 128) xmm) - (xmmi-size 16 xmm-index x86)) + (xmmi-size 16 xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (inst-ac? ;; Exceptions Type 4 - nil) + nil) ((mv flg0 - (the (unsigned-byte 128) xmm/mem) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (unsigned-byte 128) xmm/mem) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Raise an error if v-addr is not 16-byte aligned. ;; In case the second operand is an XMM register, v-addr = 0. ((when (not (eql (mod v-addr 16) 0))) - (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) + (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) (result (case operation - (#.*OP-AND* (logand xmm xmm/mem)) - (#.*OP-ANDN* (logand (lognot xmm) xmm/mem)) - (#.*OP-OR* (logior xmm xmm/mem)) - (#.*OP-XOR* (logxor xmm xmm/mem)) - ;; Should not reach here. - (otherwise 0))) + (#.*OP-AND* (logand xmm xmm/mem)) + (#.*OP-ANDN* (logand (lognot xmm) xmm/mem)) + (#.*OP-OR* (logior xmm xmm/mem)) + (#.*OP-XOR* (logxor xmm xmm/mem)) + ;; Should not reach here. + (otherwise 0))) ;; Update the x86 state: (x86 (!xmmi-size 16 xmm-index result x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (progn (add-to-implemented-opcodes-table 'ANDPS #x0F54 - '(:nil nil) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:nil nil) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'ANDNPS #x0F55 - '(:nil nil) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:nil nil) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'ORPS #x0F56 - '(:nil nil) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:nil nil) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'XORPS #x0F57 - '(:nil nil) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:nil nil) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'ANDPD #x0F54 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'ANDNPD #x0F55 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'ORPD #x0F56 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'XORPD #x0F57 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'PAND #x0FDB - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'PANDN #x0FDF - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'POR #x0FEB - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM) (add-to-implemented-opcodes-table 'PXOR #x0FEF - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM))) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-andp?/andnp?/orp?/xorp?/pand/pandn/por/pxor-Op/En-RM))) ;; ====================================================================== ;; INSTRUCTION: SSE/SSE2 Comparison Instructions @@ -199,72 +201,74 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (integer 4 8) operand-size) - (if (equal sp/dp #.*OP-DP*) 8 4)) + (if (equal sp/dp #.*OP-DP*) 8 4)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) (xmm (xmmi-size operand-size xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (inst-ac? ;; Exceptions Type 3 - t) + t) ((mv flg0 xmm/mem (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 1 x86)) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 1 ;; One-byte immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((mv flg1 (the (unsigned-byte 8) imm) x86) - (rm-size 1 (the (signed-byte #.*max-linear-address-size*) temp-rip) :x x86)) + (rm-size 1 (the (signed-byte #.*max-linear-address-size*) temp-rip) :x x86)) ((when flg1) - (!!ms-fresh :rm-size-error flg1)) + (!!ms-fresh :rm-size-error flg1)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (1+ temp-rip)) + (1+ temp-rip)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ((mv flg2 result (the (unsigned-byte 32) mxcsr)) - (if (equal sp/dp #.*OP-DP*) - (dp-sse-cmp (n02 imm) xmm xmm/mem (mxcsr x86)) - (sp-sse-cmp (n02 imm) xmm xmm/mem (mxcsr x86)))) + (if (equal sp/dp #.*OP-DP*) + (dp-sse-cmp (n02 imm) xmm xmm/mem (mxcsr x86)) + (sp-sse-cmp (n02 imm) xmm xmm/mem (mxcsr x86)))) ((when flg2) - (if (equal sp/dp #.*OP-DP*) - (!!ms-fresh :dp-sse-cmp flg2) - (!!ms-fresh :sp-sse-cmp flg2))) + (if (equal sp/dp #.*OP-DP*) + (!!ms-fresh :dp-sse-cmp flg2) + (!!ms-fresh :sp-sse-cmp flg2))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -277,13 +281,13 @@ :implemented (progn (add-to-implemented-opcodes-table 'CMPSS #x0FC2 - '(:misc - (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-cmpss/cmpsd-Op/En-RMI) + '(:misc + (eql #.*mandatory-f3h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-cmpss/cmpsd-Op/En-RMI) (add-to-implemented-opcodes-table 'CMPSD #x0FC2 - '(:misc - (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) - 'x86-cmpss/cmpsd-Op/En-RMI))) + '(:misc + (eql #.*mandatory-f2h* (prefixes-slice :group-1-prefix prefixes))) + 'x86-cmpss/cmpsd-Op/En-RMI))) (def-inst x86-cmpps-Op/En-RMI @@ -304,137 +308,139 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) ((the (unsigned-byte 128) xmm) - (xmmi-size 16 xmm-index x86)) + (xmmi-size 16 xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (inst-ac? ;; Exceptions Type 2 - nil) + nil) ((mv flg0 - (the (unsigned-byte 128) xmm/mem) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 1 x86)) + (the (unsigned-byte 128) xmm/mem) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 1 ;; One-byte immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((mv flg1 (the (unsigned-byte 8) imm) x86) - (rm-size 1 (the (signed-byte #.*max-linear-address-size*) - temp-rip) :x x86)) + (rm-size 1 (the (signed-byte #.*max-linear-address-size*) + temp-rip) :x x86)) ((when flg1) - (!!ms-fresh :rm-size-error flg1)) + (!!ms-fresh :rm-size-error flg1)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (1+ temp-rip)) + (1+ temp-rip)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Raise an error if v-addr is not 16-byte aligned. ;; In case the second operand is an XMM register, v-addr = 0. ((when (not (eql (mod v-addr 16) 0))) - (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) + (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) (xmm0 (mbe :logic (part-select xmm :low 0 :high 31) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF xmm)))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF xmm)))) (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 31) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF xmm/mem)))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF xmm/mem)))) (xmm1 (mbe :logic (part-select xmm :low 32 :high 63) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm -32))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm -32))))) (xmm/mem1 (mbe :logic (part-select xmm/mem :low 32 :high 63) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -32))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -32))))) (xmm2 (mbe :logic (part-select xmm :low 64 :high 95) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm -64))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm -64))))) (xmm/mem2 (mbe :logic (part-select xmm/mem :low 64 :high 95) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -64))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -64))))) (xmm3 (mbe :logic (part-select xmm :low 96 :high 127) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm -96))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm -96))))) (xmm/mem3 (mbe :logic (part-select xmm/mem :low 96 :high 127) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -96))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -96))))) (mxcsr (the (unsigned-byte 32) (mxcsr x86))) (operation (the (unsigned-byte 3) (n02 imm))) ((mv flg2 - (the (unsigned-byte 32) result0) - (the (unsigned-byte 32) mxcsr0)) - (sp-sse-cmp operation xmm0 xmm/mem0 mxcsr)) + (the (unsigned-byte 32) result0) + (the (unsigned-byte 32) mxcsr0)) + (sp-sse-cmp operation xmm0 xmm/mem0 mxcsr)) ((when flg2) - (!!ms-fresh :sp-sse-cmp flg2)) + (!!ms-fresh :sp-sse-cmp flg2)) ((mv flg3 - (the (unsigned-byte 32) result1) - (the (unsigned-byte 32) mxcsr1)) - (sp-sse-cmp operation xmm1 xmm/mem1 mxcsr)) + (the (unsigned-byte 32) result1) + (the (unsigned-byte 32) mxcsr1)) + (sp-sse-cmp operation xmm1 xmm/mem1 mxcsr)) ((when flg3) - (!!ms-fresh :sp-sse-cmp flg3)) + (!!ms-fresh :sp-sse-cmp flg3)) ((mv flg4 - (the (unsigned-byte 32) result2) - (the (unsigned-byte 32) mxcsr2)) - (sp-sse-cmp operation xmm2 xmm/mem2 mxcsr)) + (the (unsigned-byte 32) result2) + (the (unsigned-byte 32) mxcsr2)) + (sp-sse-cmp operation xmm2 xmm/mem2 mxcsr)) ((when flg4) - (!!ms-fresh :sp-sse-cmp flg4)) + (!!ms-fresh :sp-sse-cmp flg4)) ((mv flg5 - (the (unsigned-byte 32) result3) - (the (unsigned-byte 32) mxcsr3)) - (sp-sse-cmp operation xmm3 xmm/mem3 mxcsr)) + (the (unsigned-byte 32) result3) + (the (unsigned-byte 32) mxcsr3)) + (sp-sse-cmp operation xmm3 xmm/mem3 mxcsr)) ((when flg5) - (!!ms-fresh :sp-sse-cmp flg5)) + (!!ms-fresh :sp-sse-cmp flg5)) (result (merge-4-u32s result3 result2 result1 result0)) (mxcsr (the (unsigned-byte 32) - (logior mxcsr0 mxcsr1 mxcsr2 mxcsr3))) + (logior mxcsr0 mxcsr1 mxcsr2 mxcsr3))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -442,12 +448,12 @@ (x86 (!xmmi-size 16 xmm-index result x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (add-to-implemented-opcodes-table 'CMPPS #x0FC2 - '(:nil nil) - 'x86-cmpps-Op/En-RMI)) + '(:nil nil) + 'x86-cmpps-Op/En-RMI)) (def-inst x86-cmppd-Op/En-RMI @@ -468,106 +474,108 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) ((the (unsigned-byte 128) xmm) - (xmmi-size 16 xmm-index x86)) + (xmmi-size 16 xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) (inst-ac? ;; Exceptions Type 2 - nil) + nil) ((mv flg0 - (the (unsigned-byte 128) xmm/mem) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 1 x86)) + (the (unsigned-byte 128) xmm/mem) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 1 ;; One-byte immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((mv flg1 (the (unsigned-byte 8) imm) x86) - (rm-size 1 (the (signed-byte #.*max-linear-address-size*) - temp-rip) :x x86)) + (rm-size 1 (the (signed-byte #.*max-linear-address-size*) + temp-rip) :x x86)) ((when flg1) - (!!ms-fresh :rm-size-error flg1)) + (!!ms-fresh :rm-size-error flg1)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (1+ temp-rip)) + (1+ temp-rip)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Raise an error if v-addr is not 16-byte aligned. ;; In case the second operand is an XMM register, v-addr = 0. ((when (not (eql (mod v-addr 16) 0))) - (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) + (!!ms-fresh :memory-address-is-not-16-byte-aligned v-addr)) (xmm0 (mbe :logic (part-select xmm :low 0 :high 63) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF xmm)))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF xmm)))) (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 63) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF xmm/mem)))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF xmm/mem)))) (xmm1 (mbe :logic (part-select xmm :low 64 :high 127) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm -64))))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm -64))))) (xmm/mem1 (mbe :logic (part-select xmm/mem :low 64 :high 127) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm/mem -64))))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF (ash xmm/mem -64))))) (mxcsr (the (unsigned-byte 32) (mxcsr x86))) (operation (the (unsigned-byte 3) (n02 imm))) ((mv flg2 - (the (unsigned-byte 64) result0) - (the (unsigned-byte 32) mxcsr0)) - (dp-sse-cmp operation xmm0 xmm/mem0 mxcsr)) + (the (unsigned-byte 64) result0) + (the (unsigned-byte 32) mxcsr0)) + (dp-sse-cmp operation xmm0 xmm/mem0 mxcsr)) ((when flg2) - (!!ms-fresh :dp-sse-cmp flg2)) + (!!ms-fresh :dp-sse-cmp flg2)) ((mv flg3 - (the (unsigned-byte 64) result1) - (the (unsigned-byte 32) mxcsr1)) - (dp-sse-cmp operation xmm1 xmm/mem1 mxcsr)) + (the (unsigned-byte 64) result1) + (the (unsigned-byte 32) mxcsr1)) + (dp-sse-cmp operation xmm1 xmm/mem1 mxcsr)) ((when flg3) - (!!ms-fresh :dp-sse-cmp flg3)) + (!!ms-fresh :dp-sse-cmp flg3)) (result (merge-2-u64s result1 result0)) (mxcsr (the (unsigned-byte 32) - (logior mxcsr0 mxcsr1))) + (logior mxcsr0 mxcsr1))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) @@ -579,9 +587,9 @@ :implemented (add-to-implemented-opcodes-table 'CMPPD #x0FC2 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-cmppd-Op/En-RMI)) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-cmppd-Op/En-RMI)) (def-inst x86-comis?/ucomis?-Op/En-RM @@ -611,112 +619,114 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (integer 4 8) operand-size) - (if (equal sp/dp #.*OP-DP*) 8 4)) + (if (equal sp/dp #.*OP-DP*) 8 4)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) (xmm (xmmi-size operand-size xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (inst-ac? ;; Exceptions Type 3 - t) + t) ((mv flg0 xmm/mem (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ((mv flg1 result (the (unsigned-byte 32) mxcsr)) - (if (equal sp/dp #.*OP-DP*) - (dp-sse-cmp operation xmm xmm/mem (mxcsr x86)) - (sp-sse-cmp operation xmm xmm/mem (mxcsr x86)))) + (if (equal sp/dp #.*OP-DP*) + (dp-sse-cmp operation xmm xmm/mem (mxcsr x86)) + (sp-sse-cmp operation xmm xmm/mem (mxcsr x86)))) ((when flg1) - (if (equal sp/dp #.*OP-DP*) - (!!ms-fresh :dp-sse-cmp flg1) - (!!ms-fresh :sp-sse-cmp flg1))) + (if (equal sp/dp #.*OP-DP*) + (!!ms-fresh :dp-sse-cmp flg1) + (!!ms-fresh :sp-sse-cmp flg1))) ;; Update the x86 state: (x86 (!mxcsr mxcsr x86)) ;; Set ZF, PF, CF flags according to the comis?/ucomis? result. (x86 - (case result - (0 (let* ((x86 (!flgi #.*cf* 0 x86)) - (x86 (!flgi #.*pf* 0 x86)) - (x86 (!flgi #.*zf* 0 x86)) - (x86 (!flgi #.*af* 0 x86)) - (x86 (!flgi #.*sf* 0 x86)) - (x86 (!flgi #.*of* 0 x86))) - x86)) - (1 (let* ((x86 (!flgi #.*cf* 1 x86)) - (x86 (!flgi #.*pf* 0 x86)) - (x86 (!flgi #.*zf* 0 x86)) - (x86 (!flgi #.*af* 0 x86)) - (x86 (!flgi #.*sf* 0 x86)) - (x86 (!flgi #.*of* 0 x86))) - x86)) - (7 (let* ((x86 (!flgi #.*cf* 1 x86)) - (x86 (!flgi #.*pf* 1 x86)) - (x86 (!flgi #.*zf* 1 x86)) - (x86 (!flgi #.*af* 0 x86)) - (x86 (!flgi #.*sf* 0 x86)) - (x86 (!flgi #.*of* 0 x86))) - x86)) - (otherwise ;; Must only be 4. - (let* ((x86 (!flgi #.*cf* 0 x86)) - (x86 (!flgi #.*pf* 0 x86)) - (x86 (!flgi #.*zf* 1 x86)) - (x86 (!flgi #.*af* 0 x86)) - (x86 (!flgi #.*sf* 0 x86)) - (x86 (!flgi #.*of* 0 x86))) - x86)))) + (case result + (0 (let* ((x86 (!flgi #.*cf* 0 x86)) + (x86 (!flgi #.*pf* 0 x86)) + (x86 (!flgi #.*zf* 0 x86)) + (x86 (!flgi #.*af* 0 x86)) + (x86 (!flgi #.*sf* 0 x86)) + (x86 (!flgi #.*of* 0 x86))) + x86)) + (1 (let* ((x86 (!flgi #.*cf* 1 x86)) + (x86 (!flgi #.*pf* 0 x86)) + (x86 (!flgi #.*zf* 0 x86)) + (x86 (!flgi #.*af* 0 x86)) + (x86 (!flgi #.*sf* 0 x86)) + (x86 (!flgi #.*of* 0 x86))) + x86)) + (7 (let* ((x86 (!flgi #.*cf* 1 x86)) + (x86 (!flgi #.*pf* 1 x86)) + (x86 (!flgi #.*zf* 1 x86)) + (x86 (!flgi #.*af* 0 x86)) + (x86 (!flgi #.*sf* 0 x86)) + (x86 (!flgi #.*of* 0 x86))) + x86)) + (otherwise ;; Must only be 4. + (let* ((x86 (!flgi #.*cf* 0 x86)) + (x86 (!flgi #.*pf* 0 x86)) + (x86 (!flgi #.*zf* 1 x86)) + (x86 (!flgi #.*af* 0 x86)) + (x86 (!flgi #.*sf* 0 x86)) + (x86 (!flgi #.*of* 0 x86))) + x86)))) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (progn (add-to-implemented-opcodes-table 'COMISS #x0F2F - '(:nil nil) - 'x86-comis?/ucomis?-Op/En-RM) + '(:nil nil) + 'x86-comis?/ucomis?-Op/En-RM) (add-to-implemented-opcodes-table 'UCOMISS #x0F2E - '(:nil nil) - 'x86-comis?/ucomis?-Op/En-RM) + '(:nil nil) + 'x86-comis?/ucomis?-Op/En-RM) (add-to-implemented-opcodes-table 'COMISD #x0F2F - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-comis?/ucomis?-Op/En-RM) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-comis?/ucomis?-Op/En-RM) (add-to-implemented-opcodes-table 'UCOMISD #x0F2E - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-comis?/ucomis?-Op/En-RM))) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-comis?/ucomis?-Op/En-RM))) ;; ====================================================================== diff --git a/books/projects/x86isa/machine/instructions/fp/x86-fp-mov-instructions.lisp b/books/projects/x86isa/machine/instructions/fp/x86-fp-mov-instructions.lisp index 20825bd2c0d..b174c10ae4d 100644 --- a/books/projects/x86isa/machine/instructions/fp/x86-fp-mov-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/fp/x86-fp-mov-instructions.lisp @@ -53,7 +53,9 @@ ((mv flg0 xmm/mem (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -89,7 +91,7 @@ (x86 (!xmmi-size operand-size xmm-index xmm/mem x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (progn @@ -140,7 +142,9 @@ x86) (if (int= mod #b11) (mv nil 0 0 x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) @@ -225,7 +229,9 @@ (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -299,7 +305,9 @@ x86) (if (int= mod #b11) (mv nil 0 0 x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) @@ -392,7 +400,9 @@ (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -473,7 +483,9 @@ x86) (if (int= mod #b11) (mv nil 0 0 x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) @@ -565,7 +577,9 @@ (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -638,7 +652,9 @@ (the (signed-byte 64) v-addr) (the (unsigned-byte 3) increment-RIP-by) x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86)) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) ((when (not (canonical-address-p v-addr))) @@ -722,7 +738,9 @@ (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -752,7 +770,7 @@ (result (merge-2-u64s mem low-qword)) (x86 (!xmmi-size 16 xmm-index result x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (progn @@ -804,7 +822,9 @@ (the (signed-byte 64) v-addr) (the (unsigned-byte 3) increment-RIP-by) x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86)) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) ((when (not (canonical-address-p v-addr))) diff --git a/books/projects/x86isa/machine/instructions/fp/x86-fp-mxcsr-instructions.lisp b/books/projects/x86isa/machine/instructions/fp/x86-fp-mxcsr-instructions.lisp index 0e93dd3fcb7..bc9a58ba7a8 100644 --- a/books/projects/x86isa/machine/instructions/fp/x86-fp-mxcsr-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/fp/x86-fp-mxcsr-instructions.lisp @@ -49,7 +49,9 @@ (the (signed-byte 64) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* 4 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* 4 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) diff --git a/books/projects/x86isa/machine/instructions/fp/x86-fp-shuffle-and-unpack-instructions.lisp b/books/projects/x86isa/machine/instructions/fp/x86-fp-shuffle-and-unpack-instructions.lisp index 5d41e1e47f3..f469f41fa43 100644 --- a/books/projects/x86isa/machine/instructions/fp/x86-fp-shuffle-and-unpack-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/fp/x86-fp-shuffle-and-unpack-instructions.lisp @@ -91,7 +91,9 @@ (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 1 x86)) + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 1 ;; One-byte immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -194,14 +196,16 @@ ;; non 16-byte aligned addresses on a real machine. (inst-ac? ;; Exceptions Type 4 t) ;; This should be nil according to the Intel manuals, but - ;; see comment above. + ;; see comment above. ((mv flg0 (the (unsigned-byte 128) xmm/mem) (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 1 x86)) + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 1 ;; One-byte immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -253,7 +257,7 @@ (x86 (!xmmi-size 16 xmm-index result x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (add-to-implemented-opcodes-table 'SHUFPD #x0FC6 @@ -315,14 +319,16 @@ ;; non 16-byte aligned addresses on a real machine. (inst-ac? ;; Exceptions Type 4 t) ;; This should be nil according to the Intel manuals, but - ;; see comment above. + ;; see comment above. ((mv flg0 (the (unsigned-byte 128) xmm/mem) (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -384,7 +390,7 @@ (x86 (!xmmi-size 16 xmm-index result x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (progn (add-to-implemented-opcodes-table 'UNPCKLPS #x0F14 @@ -455,7 +461,9 @@ (the (integer 0 4) increment-RIP-by) (the (signed-byte 64) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) diff --git a/books/projects/x86isa/machine/instructions/fp/x86-fp-simd-integer-instructions.lisp b/books/projects/x86isa/machine/instructions/fp/x86-fp-simd-integer-instructions.lisp index c8d84d33cca..2350833b7a0 100644 --- a/books/projects/x86isa/machine/instructions/fp/x86-fp-simd-integer-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/fp/x86-fp-simd-integer-instructions.lisp @@ -6,9 +6,9 @@ ;; ====================================================================== (include-book "../../x86-decoding-and-spec-utils" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (include-book "fp-base" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (include-book "centaur/bitops/merge" :dir :system) (local (include-book "centaur/bitops/ihs-extensions" :dir :system)) @@ -32,47 +32,47 @@ :prepwork ((define pcmpeqb32 ((xmm n32p) - (xmm/mem n32p)) + (xmm/mem n32p)) :inline t (let* ((xmm0 (mbe :logic (part-select xmm :low 0 :high 7) - :exec (the (unsigned-byte 8) - (logand #xFF xmm)))) - (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 7) - :exec (the (unsigned-byte 8) - (logand #xFF xmm/mem)))) - - (xmm1 (mbe :logic (part-select xmm :low 8 :high 15) - :exec (the (unsigned-byte 8) - (logand #xFF (ash xmm -8))))) - (xmm/mem1 (mbe :logic (part-select xmm/mem :low 8 :high 15) - :exec (the (unsigned-byte 8) - (logand #xFF (ash xmm/mem -8))))) - - (xmm2 (mbe :logic (part-select xmm :low 16 :high 23) - :exec (the (unsigned-byte 8) - (logand #xFF (ash xmm -16))))) - (xmm/mem2 (mbe :logic (part-select xmm/mem :low 16 :high 23) - :exec (the (unsigned-byte 8) - (logand #xFF (ash xmm/mem -16))))) - - (xmm3 (mbe :logic (part-select xmm :low 24 :high 31) - :exec (the (unsigned-byte 8) - (logand #xFF (ash xmm -24))))) - (xmm/mem3 (mbe :logic (part-select xmm/mem :low 24 :high 31) - :exec (the (unsigned-byte 8) - (logand #xFF (ash xmm/mem -24))))) - - (byte0 (the (unsigned-byte 8) - (if (int= xmm0 xmm/mem0) #xFF 0))) - (byte1 (the (unsigned-byte 8) - (if (int= xmm1 xmm/mem1) #xFF 0))) - (byte2 (the (unsigned-byte 8) - (if (int= xmm2 xmm/mem2) #xFF 0))) - (byte3 (the (unsigned-byte 8) - (if (int= xmm3 xmm/mem3) #xFF 0))) - - (dword (merge-4-u8s byte3 byte2 byte1 byte0))) + :exec (the (unsigned-byte 8) + (logand #xFF xmm)))) + (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 7) + :exec (the (unsigned-byte 8) + (logand #xFF xmm/mem)))) + + (xmm1 (mbe :logic (part-select xmm :low 8 :high 15) + :exec (the (unsigned-byte 8) + (logand #xFF (ash xmm -8))))) + (xmm/mem1 (mbe :logic (part-select xmm/mem :low 8 :high 15) + :exec (the (unsigned-byte 8) + (logand #xFF (ash xmm/mem -8))))) + + (xmm2 (mbe :logic (part-select xmm :low 16 :high 23) + :exec (the (unsigned-byte 8) + (logand #xFF (ash xmm -16))))) + (xmm/mem2 (mbe :logic (part-select xmm/mem :low 16 :high 23) + :exec (the (unsigned-byte 8) + (logand #xFF (ash xmm/mem -16))))) + + (xmm3 (mbe :logic (part-select xmm :low 24 :high 31) + :exec (the (unsigned-byte 8) + (logand #xFF (ash xmm -24))))) + (xmm/mem3 (mbe :logic (part-select xmm/mem :low 24 :high 31) + :exec (the (unsigned-byte 8) + (logand #xFF (ash xmm/mem -24))))) + + (byte0 (the (unsigned-byte 8) + (if (int= xmm0 xmm/mem0) #xFF 0))) + (byte1 (the (unsigned-byte 8) + (if (int= xmm1 xmm/mem1) #xFF 0))) + (byte2 (the (unsigned-byte 8) + (if (int= xmm2 xmm/mem2) #xFF 0))) + (byte3 (the (unsigned-byte 8) + (if (int= xmm3 xmm/mem3) #xFF 0))) + + (dword (merge-4-u8s byte3 byte2 byte1 byte0))) dword) /// @@ -90,11 +90,11 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) xmm-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) ((the (unsigned-byte 128) xmm) - (xmmi-size 16 xmm-index x86)) + (xmmi-size 16 xmm-index x86)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) @@ -102,74 +102,76 @@ ;; Intel manual, I got a segmentation fault when trying with ;; non 16-byte aligned addresses on a real machine. (inst-ac? ;; Exceptions Type 4 - t) ;; This should be nil according to the Intel manuals, but - ;; see comment above. + t) ;; This should be nil according to the Intel manuals, but + ;; see comment above. ((mv flg0 - (the (unsigned-byte 128) xmm/mem) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (unsigned-byte 128) xmm/mem) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) (xmm0 (mbe :logic (part-select xmm :low 0 :high 31) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF xmm)))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF xmm)))) (xmm/mem0 (mbe :logic (part-select xmm/mem :low 0 :high 31) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF xmm/mem)))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF xmm/mem)))) (xmm1 (mbe :logic (part-select xmm :low 32 :high 63) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm -32))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm -32))))) (xmm/mem1 (mbe :logic (part-select xmm/mem :low 32 :high 63) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -32))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -32))))) (xmm2 (mbe :logic (part-select xmm :low 64 :high 95) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm -64))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm -64))))) (xmm/mem2 (mbe :logic (part-select xmm/mem :low 64 :high 95) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -64))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -64))))) (xmm3 (mbe :logic (part-select xmm :low 96 :high 127) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm -96))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm -96))))) (xmm/mem3 (mbe :logic (part-select xmm/mem :low 96 :high 127) - :exec (the (unsigned-byte 32) - (logand #uxFFFF_FFFF (ash xmm/mem -96))))) + :exec (the (unsigned-byte 32) + (logand #uxFFFF_FFFF (ash xmm/mem -96))))) (dword0 (the (unsigned-byte 32) - (pcmpeqb32 xmm0 xmm/mem0))) + (pcmpeqb32 xmm0 xmm/mem0))) (dword1 (the (unsigned-byte 32) - (pcmpeqb32 xmm1 xmm/mem1))) + (pcmpeqb32 xmm1 xmm/mem1))) (dword2 (the (unsigned-byte 32) - (pcmpeqb32 xmm2 xmm/mem2))) + (pcmpeqb32 xmm2 xmm/mem2))) (dword3 (the (unsigned-byte 32) - (pcmpeqb32 xmm3 xmm/mem3))) + (pcmpeqb32 xmm3 xmm/mem3))) (result (merge-4-u32s dword3 dword2 dword1 dword0)) @@ -181,9 +183,9 @@ :implemented (add-to-implemented-opcodes-table 'PCMPEQB #x0F74 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-pcmpeqb-Op/En-RM)) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-pcmpeqb-Op/En-RM)) (def-inst x86-pmovmskb-Op/En-RM @@ -205,37 +207,37 @@ :inline t (let* ((bit0 (logbit 7 xmm)) - (bit1 (logbit 15 xmm)) - (bit2 (logbit 23 xmm)) - (bit3 (logbit 31 xmm)) - (bit4 (logbit 39 xmm)) - (bit5 (logbit 47 xmm)) - (bit6 (logbit 55 xmm)) - (bit7 (logbit 63 xmm)) - - (two-bit0 (the (unsigned-byte 2) - (logior (the (unsigned-byte 2) (ash bit1 1)) - bit0))) - (two-bit1 (the (unsigned-byte 2) - (logior (the (unsigned-byte 2) (ash bit3 1)) - bit2))) - (two-bit2 (the (unsigned-byte 2) - (logior (the (unsigned-byte 2) (ash bit5 1)) - bit4))) - (two-bit3 (the (unsigned-byte 2) - (logior (the (unsigned-byte 2) (ash bit7 1)) - bit6))) - - (four-bit0 (the (unsigned-byte 4) - (logior (the (unsigned-byte 4) (ash two-bit1 2)) - two-bit0))) - (four-bit1 (the (unsigned-byte 4) - (logior (the (unsigned-byte 4) (ash two-bit3 2)) - two-bit2))) - - (byte (the (unsigned-byte 8) - (logior (the (unsigned-byte 8) (ash four-bit1 4)) - four-bit0)))) + (bit1 (logbit 15 xmm)) + (bit2 (logbit 23 xmm)) + (bit3 (logbit 31 xmm)) + (bit4 (logbit 39 xmm)) + (bit5 (logbit 47 xmm)) + (bit6 (logbit 55 xmm)) + (bit7 (logbit 63 xmm)) + + (two-bit0 (the (unsigned-byte 2) + (logior (the (unsigned-byte 2) (ash bit1 1)) + bit0))) + (two-bit1 (the (unsigned-byte 2) + (logior (the (unsigned-byte 2) (ash bit3 1)) + bit2))) + (two-bit2 (the (unsigned-byte 2) + (logior (the (unsigned-byte 2) (ash bit5 1)) + bit4))) + (two-bit3 (the (unsigned-byte 2) + (logior (the (unsigned-byte 2) (ash bit7 1)) + bit6))) + + (four-bit0 (the (unsigned-byte 4) + (logior (the (unsigned-byte 4) (ash two-bit1 2)) + two-bit0))) + (four-bit1 (the (unsigned-byte 4) + (logior (the (unsigned-byte 4) (ash two-bit3 2)) + two-bit2))) + + (byte (the (unsigned-byte 8) + (logior (the (unsigned-byte 8) (ash four-bit1 4)) + four-bit0)))) byte) /// @@ -253,52 +255,54 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* (prefixes-slice :group-1-prefix prefixes))) ((when lock) - (!!ms-fresh :lock-prefix prefixes)) + (!!ms-fresh :lock-prefix prefixes)) ((the (unsigned-byte 4) rgf-index) - (reg-index reg rex-byte #.*r*)) + (reg-index reg rex-byte #.*r*)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes))) (inst-ac? ;; Exceptions Type 7 - nil) + nil) ((mv flg0 - (the (unsigned-byte 128) xmm) - (the (integer 0 4) increment-RIP-by) - (the (signed-byte 64) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (unsigned-byte 128) xmm) + (the (integer 0 4) increment-RIP-by) + (the (signed-byte 64) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*xmm-access* 16 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) (xmm0 (mbe :logic (part-select xmm :low 0 :high 63) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF xmm)))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF xmm)))) (xmm1 (mbe :logic (part-select xmm :low 64 :high 127) - :exec (the (unsigned-byte 64) - (logand #uxFFFF_FFFF_FFFF_FFFF - (ash xmm -64))))) + :exec (the (unsigned-byte 64) + (logand #uxFFFF_FFFF_FFFF_FFFF + (ash xmm -64))))) (byte0 (the (unsigned-byte 8) (pmovmskb8 xmm0))) (byte1 (the (unsigned-byte 8) (pmovmskb8 xmm1))) @@ -309,12 +313,12 @@ (x86 (!rgfi-size 8 rgf-index result rex-byte x86)) (x86 (!rip temp-rip x86))) - x86) + x86) :implemented (add-to-implemented-opcodes-table 'PMOVMSKB #x0FD7 - '(:misc - (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) - 'x86-pmovmskb-Op/En-RM)) + '(:misc + (eql #.*mandatory-66h* (prefixes-slice :group-3-prefix prefixes))) + 'x86-pmovmskb-Op/En-RM)) ;; ====================================================================== diff --git a/books/projects/x86isa/machine/instructions/x86-arith-and-logic-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-arith-and-logic-instructions.lisp index fc370559a1d..6f61746bc95 100644 --- a/books/projects/x86isa/machine/instructions/x86-arith-and-logic-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-arith-and-logic-instructions.lisp @@ -6,9 +6,9 @@ ;; ====================================================================== (include-book "arith-and-logic" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (include-book "../x86-decoding-and-spec-utils" - :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) + :ttags (:include-raw :syscall-exec :other-non-det :undef-flg)) (local (include-book "centaur/bitops/ihs-extensions" :dir :system)) (local (include-book "centaur/bitops/signed-byte-p" :dir :system)) @@ -20,95 +20,95 @@ (local (defthm signed-byte-p-49-thm-1 (implies (and (signed-byte-p 48 (+ a b)) - (signed-byte-p 48 c) - (integerp a) - (integerp b)) - (signed-byte-p 49 (+ (- c) a b))))) + (signed-byte-p 48 c) + (integerp a) + (integerp b)) + (signed-byte-p 49 (+ (- c) a b))))) (local (defthm signed-byte-p-48-thm-1 (implies (and (signed-byte-p 48 x) - (< (+ x y) *2^47*) - (natp y)) - (signed-byte-p 48 (+ x y))))) + (< (+ x y) *2^47*) + (natp y)) + (signed-byte-p 48 (+ x y))))) (local (defthm signed-byte-p-49-thm-2 (implies (and (signed-byte-p 48 (+ a b)) - (signed-byte-p 48 c) - (< (+ z a b) *2^47*) - (integerp a) - (integerp b) - (natp z)) - (signed-byte-p 49 (+ z (- c) a b))) + (signed-byte-p 48 c) + (< (+ z a b) *2^47*) + (integerp a) + (integerp b) + (natp z)) + (signed-byte-p 49 (+ z (- c) a b))) :hints (("Goal" :in-theory (e/d* (signed-byte-p) ()))))) (local (defthm signed-byte-p-48-thm-2 (implies (and (signed-byte-p 48 x) - (< (+ z x y) *2^47*) - (natp y) - (natp z)) - (signed-byte-p 48 (+ z x y))))) + (< (+ z x y) *2^47*) + (natp y) + (natp z)) + (signed-byte-p 48 (+ z x y))))) (local (defthm signed-byte-p-49-thm-3 (implies (and (signed-byte-p 48 x) - (natp y) - (<= y 4)) - (signed-byte-p 49 (+ x y))) + (natp y) + (<= y 4)) + (signed-byte-p 49 (+ x y))) :hints (("Goal" :in-theory (e/d* (signed-byte-p unsigned-byte-p) - ()))))) + ()))))) (local (defthm signed-byte-p-48-thm-3 (implies (and (not (signed-byte-p 48 (+ x y))) - (signed-byte-p 48 x) - (natp y)) - (<= *2^47* (+ x y))))) + (signed-byte-p 48 x) + (natp y)) + (<= *2^47* (+ x y))))) (local (defthm signed-byte-p-49-thm-4 (implies (and (signed-byte-p 48 y) - (signed-byte-p 48 z) - (< (+ x y) *2^47*) - (natp x)) - (signed-byte-p 49 (+ x y (- z)))) + (signed-byte-p 48 z) + (< (+ x y) *2^47*) + (natp x)) + (signed-byte-p 49 (+ x y (- z)))) :hints (("Goal" :in-theory (e/d* (signed-byte-p unsigned-byte-p) - ()))))) + ()))))) (local (defthm unsigned-byte-p-32-of-rm08 (implies (and (signed-byte-p *max-linear-address-size* lin-addr) - (x86p x86)) - (unsigned-byte-p 32 (mv-nth 1 (rm08 lin-addr r-w-x x86)))) + (x86p x86)) + (unsigned-byte-p 32 (mv-nth 1 (rm08 lin-addr r-w-x x86)))) :hints (("Goal" :in-theory (e/d* (unsigned-byte-p member-equal) (ash)))))) (local (defthm unsigned-byte-p-32-of-rm16 (implies (and (signed-byte-p *max-linear-address-size* lin-addr) - (x86p x86)) - (unsigned-byte-p 32 (mv-nth 1 (rm16 lin-addr r-w-x x86)))) + (x86p x86)) + (unsigned-byte-p 32 (mv-nth 1 (rm16 lin-addr r-w-x x86)))) :hints (("Goal" :in-theory (e/d* (unsigned-byte-p member-equal) (ash)))))) (local (defthm unsigned-byte-p-64-of-rm08 (implies (and (signed-byte-p *max-linear-address-size* lin-addr) - (x86p x86)) - (unsigned-byte-p 64 (mv-nth 1 (rm08 lin-addr r-w-x x86)))) + (x86p x86)) + (unsigned-byte-p 64 (mv-nth 1 (rm08 lin-addr r-w-x x86)))) :hints (("Goal" :in-theory (e/d* (unsigned-byte-p member-equal) (ash)))))) (local (defthm member-equal-and-integers (implies (and (<= operation 8) - (<= 0 operation) - (integerp operation)) - (member-equal operation '(0 2 4 6 8 1 3 5 7))))) + (<= 0 operation) + (integerp operation)) + (member-equal operation '(0 2 4 6 8 1 3 5 7))))) (local (in-theory (e/d* () - (member-equal - signed-byte-p - unsigned-byte-p)))) + (member-equal + signed-byte-p + unsigned-byte-p)))) ;; ====================================================================== ;; INSTRUCTIONS: (one-byte opcode map) @@ -143,11 +143,11 @@ :operation t :guard (and (natp operation) - (<= operation 8)) + (<= operation 8)) :returns (x86 x86p :hyp (x86p x86) - :hints (("Goal" :in-theory (e/d* () - (unsigned-byte-p - signed-byte-p))))) + :hints (("Goal" :in-theory (e/d* () + (unsigned-byte-p + signed-byte-p))))) :body @@ -156,50 +156,52 @@ (mod (the (unsigned-byte 2) (mrm-mod modr/m))) (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock? (eql #.*lock* - (prefixes-slice :group-1-prefix prefixes))) + (prefixes-slice :group-1-prefix prefixes))) ((when (and lock? (eql operation #.*OP-CMP*))) - ;; CMP does not allow a LOCK prefix. - (!!ms-fresh :lock-prefix prefixes)) + ;; CMP does not allow a LOCK prefix. + (!!ms-fresh :lock-prefix prefixes)) (p2 (prefixes-slice :group-2-prefix prefixes)) (byte-operand? (eql 0 (the (unsigned-byte 1) - (logand 1 opcode)))) + (logand 1 opcode)))) ((the (integer 1 8) operand-size) - (select-operand-size byte-operand? rex-byte nil prefixes)) + (select-operand-size byte-operand? rex-byte nil prefixes)) (G (rgfi-size operand-size - (the (unsigned-byte 4) - (reg-index reg rex-byte #.*r*)) - rex-byte x86)) + (the (unsigned-byte 4) + (reg-index reg rex-byte #.*r*)) + rex-byte x86)) (p4? (eql #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (inst-ac? t) ((mv flg0 E (the (unsigned-byte 3) increment-RIP-by) - (the (signed-byte #.*max-linear-address-size*) E-addr) - x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (signed-byte #.*max-linear-address-size*) E-addr) + x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Everything above this point is just further decoding the ;; instruction and fetching operands. @@ -209,22 +211,22 @@ ;; Computing the flags and the result: ((the (unsigned-byte 32) input-rflags) (rflags x86)) ((mv result - (the (unsigned-byte 32) output-rflags) - (the (unsigned-byte 32) undefined-flags)) - (gpr-arith/logic-spec operand-size operation E G input-rflags)) + (the (unsigned-byte 32) output-rflags) + (the (unsigned-byte 32) undefined-flags)) + (gpr-arith/logic-spec operand-size operation E G input-rflags)) ;; Updating the x86 state with the result and eflags. ((mv flg1 x86) - (if (or (eql operation #.*OP-CMP*) - (eql operation #.*OP-TEST*)) - ;; CMP and TEST modify just the flags. - (mv nil x86) - (x86-operand-to-reg/mem - operand-size inst-ac? result - (the (signed-byte #.*max-linear-address-size*) E-addr) - rex-byte r/m mod x86))) + (if (or (eql operation #.*OP-CMP*) + (eql operation #.*OP-TEST*)) + ;; CMP and TEST modify just the flags. + (mv nil x86) + (x86-operand-to-reg/mem + operand-size inst-ac? result + (the (signed-byte #.*max-linear-address-size*) E-addr) + rex-byte r/m mod x86))) ((when flg1) - (!!ms-fresh :x86-operand-to-reg/mem flg1)) + (!!ms-fresh :x86-operand-to-reg/mem flg1)) (x86 (write-user-rflags output-rflags undefined-flags x86)) (x86 (!rip temp-rip x86))) @@ -234,41 +236,41 @@ :implemented (progn (add-to-implemented-opcodes-table 'ADD #x00 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'ADD #x01 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'OR #x08 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'OR #x09 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'ADC #x10 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'ADC #x11 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'SBB #x18 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'SBB #x19 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'AND #x20 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'AND #x21 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'SUB #x28 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'SUB #x29 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'XOR #x30 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'XOR #x31 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'CMP #x38 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'CMP #x39 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'TEST #x84 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G) (add-to-implemented-opcodes-table 'TEST #x85 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G))) + 'x86-add/adc/sub/sbb/or/and/xor/cmp/test-E-G))) (def-inst x86-add/adc/sub/sbb/or/and/xor/cmp-G-E @@ -297,47 +299,47 @@ :operation t :guard (and (not (equal operation #.*OP-TEST*)) - (natp operation) - (<= operation 8)) + (natp operation) + (<= operation 8)) :returns (x86 x86p :hyp (x86p x86) - :hints (("Goal" :in-theory (e/d* () - (unsigned-byte-p - signed-byte-p))))) + :hints (("Goal" :in-theory (e/d* () + (unsigned-byte-p + signed-byte-p))))) :implemented (progn (add-to-implemented-opcodes-table 'ADD #x02 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'ADD #x03 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'OR #x0A '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'OR #x0B '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'ADC #x12 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'ADC #x13 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'SBB #x1A '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'SBB #x1B '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'AND #x22 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'AND #x23 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'SUB #x2A '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'SUB #x2B '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'XOR #x32 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'XOR #x33 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'CMP #x3A '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E) (add-to-implemented-opcodes-table 'CMP #x3B '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E)) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-G-E)) :body @@ -346,50 +348,52 @@ (mod (the (unsigned-byte 2) (mrm-mod modr/m))) (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (lock (eql #.*lock* - (prefixes-slice :group-1-prefix prefixes))) + (prefixes-slice :group-1-prefix prefixes))) ((when (and lock (eql operation #.*OP-CMP*))) - ;; CMP does not allow a LOCK prefix. - (!!ms-fresh :lock-prefix prefixes)) + ;; CMP does not allow a LOCK prefix. + (!!ms-fresh :lock-prefix prefixes)) (p2 (prefixes-slice :group-2-prefix prefixes)) (byte-operand? (eql 0 (the (unsigned-byte 1) - (logand 1 opcode)))) + (logand 1 opcode)))) ((the (integer 1 8) operand-size) - (select-operand-size byte-operand? rex-byte nil prefixes)) + (select-operand-size byte-operand? rex-byte nil prefixes)) (G (rgfi-size operand-size - (the (unsigned-byte 4) - (reg-index reg rex-byte #.*r*)) - rex-byte x86)) + (the (unsigned-byte 4) + (reg-index reg rex-byte #.*r*)) + rex-byte x86)) (p4? (eql #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (inst-ac? t) ((mv flg0 E (the (unsigned-byte 3) increment-RIP-by) - (the (signed-byte #.*max-linear-address-size*) E-addr) - x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (signed-byte #.*max-linear-address-size*) E-addr) + x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Everything above this point is just further decoding the ;; instruction and fetching operands. @@ -399,23 +403,23 @@ ;; Computing the flags and the result: ((the (unsigned-byte 32) input-rflags) (rflags x86)) ((mv result - (the (unsigned-byte 32) output-rflags) - (the (unsigned-byte 32) undefined-flags)) - (gpr-arith/logic-spec operand-size operation G E input-rflags)) + (the (unsigned-byte 32) output-rflags) + (the (unsigned-byte 32) undefined-flags)) + (gpr-arith/logic-spec operand-size operation G E input-rflags)) ;; Updating the x86 state with the result and eflags. (x86 - (if (eql operation #.*OP-CMP*) - ;; CMP modifies the flags only. - x86 - (!rgfi-size operand-size (reg-index reg rex-byte #.*r*) result - rex-byte x86))) + (if (eql operation #.*OP-CMP*) + ;; CMP modifies the flags only. + x86 + (!rgfi-size operand-size (reg-index reg rex-byte #.*r*) result + rex-byte x86))) (x86 (write-user-rflags output-rflags undefined-flags x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) (def-inst x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I @@ -447,105 +451,105 @@ :operation t :guard (and (natp operation) - (<= operation 8)) + (<= operation 8)) :guard-hints (("Goal" :in-theory (e/d (n08-to-i08 - n16-to-i16 - n32-to-i32 - n64-to-i64) - ()))) + n16-to-i16 + n32-to-i32 + n64-to-i64) + ()))) :returns (x86 x86p :hyp (x86p x86) - :hints (("Goal" :in-theory (e/d* () - (force - (force) - gpr-arith/logic-spec-8 - gpr-arith/logic-spec-4 - gpr-arith/logic-spec-2 - gpr-arith/logic-spec-1 - rm-size - select-operand-size - unsigned-byte-p - signed-byte-p))))) + :hints (("Goal" :in-theory (e/d* () + (force + (force) + gpr-arith/logic-spec-8 + gpr-arith/logic-spec-4 + gpr-arith/logic-spec-2 + gpr-arith/logic-spec-1 + rm-size + select-operand-size + unsigned-byte-p + signed-byte-p))))) :implemented (progn (add-to-implemented-opcodes-table 'ADD #x80 '(:reg 0) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'ADD #x81 '(:reg 0) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'ADD #x82 '(:reg 0) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'ADD #x83 '(:reg 0) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) ;; [Shilpi]: Thanks to Dmitry Nadezhin for spotting typos in the ;; :reg field for the OR opcode. (add-to-implemented-opcodes-table 'OR #x80 '(:reg 1) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'OR #x81 '(:reg 1) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'OR #x82 '(:reg 1) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'OR #x83 '(:reg 1) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'ADC #x80 '(:reg 2) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'ADC #x81 '(:reg 2) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'ADC #x82 '(:reg 2) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'ADC #x83 '(:reg 2) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'SBB #x80 '(:reg 3) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'SBB #x81 '(:reg 3) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'SBB #x82 '(:reg 3) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'SBB #x83 '(:reg 3) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'AND #x80 '(:reg 4) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'AND #x81 '(:reg 4) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'AND #x82 '(:reg 4) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'AND #x83 '(:reg 4) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'SUB #x80 '(:reg 5) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'SUB #x81 '(:reg 5) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'SUB #x82 '(:reg 5) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'SUB #x83 '(:reg 5) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'XOR #x80 '(:reg 6) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'XOR #x81 '(:reg 6) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'XOR #x82 '(:reg 6) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'XOR #x83 '(:reg 6) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'CMP #x80 '(:reg 7) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'CMP #x81 '(:reg 7) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'CMP #x82 '(:reg 7) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'CMP #x83 '(:reg 7) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'TEST #xF6 '(:reg 0) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I) (add-to-implemented-opcodes-table 'TEST #xF7 '(:reg 0) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I)) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I)) :body @@ -553,87 +557,89 @@ (r/m (the (unsigned-byte 3) (mrm-r/m modr/m))) (mod (the (unsigned-byte 2) (mrm-mod modr/m))) (lock? (eql #.*lock* - (prefixes-slice :group-1-prefix prefixes))) + (prefixes-slice :group-1-prefix prefixes))) ((when (and lock? (eql operation #.*OP-CMP*))) - ;; CMP does not allow a LOCK prefix. - (!!ms-fresh :lock-prefix prefixes)) + ;; CMP does not allow a LOCK prefix. + (!!ms-fresh :lock-prefix prefixes)) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (eql #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (E-byte-operand? (or (eql opcode #x80) - (eql opcode #xF6))) + (eql opcode #xF6))) ((the (integer 1 8) E-size) - (select-operand-size E-byte-operand? rex-byte nil - prefixes)) + (select-operand-size E-byte-operand? rex-byte nil + prefixes)) (imm-byte-operand? (or (eql opcode #x80) - (eql opcode #x83) - (eql opcode #xF6))) + (eql opcode #x83) + (eql opcode #xF6))) ((the (integer 1 4) imm-size) - (select-operand-size imm-byte-operand? rex-byte t prefixes)) + (select-operand-size imm-byte-operand? rex-byte t prefixes)) (inst-ac? t) ((mv flg0 E increment-RIP-by - (the (signed-byte #.*max-linear-address-size*) E-addr) - x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* E-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (signed-byte #.*max-linear-address-size*) E-addr) + x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*rgf-access* E-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + imm-size ;; imm-size bytes of immediate data + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((mv ?flg1 (the (unsigned-byte 32) imm) x86) - (rm-size imm-size temp-rip :x x86)) + (rm-size imm-size temp-rip :x x86)) ((when flg1) - (!!ms-fresh :rm-size-error flg1)) + (!!ms-fresh :rm-size-error flg1)) ;; Sign-extend imm: (imm - (mbe :logic (loghead (ash E-size 3) (logext (ash imm-size 3) imm)) - :exec (logand (case E-size - (1 #.*2^8-1*) - (2 #.*2^16-1*) - (4 #.*2^32-1*) - (8 #.*2^64-1*) - ;; Won't reach here. - (t 0)) - (case imm-size - (1 (the (signed-byte 8) - (n08-to-i08 - (the (unsigned-byte 8) imm)))) - (2 (the (signed-byte 16) - (n16-to-i16 - (the (unsigned-byte 16) imm)))) - (4 (the (signed-byte 32) - (n32-to-i32 - (the (unsigned-byte 32) imm)))) - ;; Won't reach here. - (t 0))))) + (mbe :logic (loghead (ash E-size 3) (logext (ash imm-size 3) imm)) + :exec (logand (case E-size + (1 #.*2^8-1*) + (2 #.*2^16-1*) + (4 #.*2^32-1*) + (8 #.*2^64-1*) + ;; Won't reach here. + (t 0)) + (case imm-size + (1 (the (signed-byte 8) + (n08-to-i08 + (the (unsigned-byte 8) imm)))) + (2 (the (signed-byte 16) + (n16-to-i16 + (the (unsigned-byte 16) imm)))) + (4 (the (signed-byte 32) + (n32-to-i32 + (the (unsigned-byte 32) imm)))) + ;; Won't reach here. + (t 0))))) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip imm-size)) + (+ temp-rip imm-size)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Everything above this point is just further decoding the ;; instruction and fetching operands. @@ -643,24 +649,24 @@ ;; Computing the flags and the result: ((the (unsigned-byte 32) input-rflags) (rflags x86)) ((mv result - (the (unsigned-byte 32) output-rflags) - (the (unsigned-byte 32) undefined-flags)) - (gpr-arith/logic-spec E-size operation E imm input-rflags)) + (the (unsigned-byte 32) output-rflags) + (the (unsigned-byte 32) undefined-flags)) + (gpr-arith/logic-spec E-size operation E imm input-rflags)) ;; Updating the x86 state with the result and eflags. ((mv flg1 x86) - (if (or (eql operation #.*OP-CMP*) - (eql operation #.*OP-TEST*)) - ;; CMP and TEST modify just the flags. - (mv nil x86) - (x86-operand-to-reg/mem - E-size inst-ac? result - (the (signed-byte #.*max-linear-address-size*) E-addr) - rex-byte r/m mod x86))) + (if (or (eql operation #.*OP-CMP*) + (eql operation #.*OP-TEST*)) + ;; CMP and TEST modify just the flags. + (mv nil x86) + (x86-operand-to-reg/mem + E-size inst-ac? result + (the (signed-byte #.*max-linear-address-size*) E-addr) + rex-byte r/m mod x86))) ;; Note: If flg1 is non-nil, we bail out without changing the ;; x86 state. ((when flg1) - (!!ms-fresh :x86-operand-to-reg/mem flg1)) + (!!ms-fresh :x86-operand-to-reg/mem flg1)) (x86 (write-user-rflags output-rflags undefined-flags x86)) (x86 (!rip temp-rip x86))) @@ -693,103 +699,103 @@ :operation t :guard (and (natp operation) - (<= operation 8)) + (<= operation 8)) :prepwork ((local (in-theory (e/d* () (commutativity-of-+))))) :returns (x86 x86p :hyp (x86p x86) - :hints (("Goal" :in-theory (e/d* () - (force (force) - gpr-arith/logic-spec-8 - gpr-arith/logic-spec-4 - gpr-arith/logic-spec-2 - gpr-arith/logic-spec-1 - unsigned-byte-p))))) + :hints (("Goal" :in-theory (e/d* () + (force (force) + gpr-arith/logic-spec-8 + gpr-arith/logic-spec-4 + gpr-arith/logic-spec-2 + gpr-arith/logic-spec-1 + unsigned-byte-p))))) :implemented (progn (add-to-implemented-opcodes-table 'ADD #x04 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'ADD #x05 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'OR #x0C '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'OR #x0D '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'ADC #x14 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'ADC #x15 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'SBB #x1C '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'SBB #x1D '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'AND #x24 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'AND #x25 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'SUB #x2C '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'SUB #x2D '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'XOR #x34 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'XOR #x35 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'CMP #x3C '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'CMP #x3D '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'TEST #xA8 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (add-to-implemented-opcodes-table 'TEST #xA9 '(:nil nil) - 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I)) + 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I)) :body (b* ((ctx 'x86-add/adc/sub/sbb/or/and/xor/cmp-test-rAX-I) (lock (eql #.*lock* - (prefixes-slice :group-1-prefix prefixes))) + (prefixes-slice :group-1-prefix prefixes))) ((when (and lock (eql operation #.*OP-CMP*))) - ;; CMP does not allow a LOCK prefix. - (!!ms-fresh :lock-prefix prefixes)) + ;; CMP does not allow a LOCK prefix. + (!!ms-fresh :lock-prefix prefixes)) (byte-operand? (equal 0 (logand 1 opcode))) ((the (integer 1 8) operand-size) - (select-operand-size byte-operand? rex-byte t prefixes)) + (select-operand-size byte-operand? rex-byte t prefixes)) (rAX-size (if (logbitp #.*w* rex-byte) - 8 - operand-size)) + 8 + operand-size)) (rAX (rgfi-size rAX-size *rax* rex-byte x86)) ((mv ?flg imm x86) - (rm-size operand-size temp-rip :x x86)) + (rm-size operand-size temp-rip :x x86)) ((when flg) - (!!ms-fresh :rm-size-error flg)) + (!!ms-fresh :rm-size-error flg)) ;; Sign-extend imm when required. (imm - (if (and (not byte-operand?) - (equal rAX-size 8)) - (the (unsigned-byte 64) - (n64 - (the (signed-byte 32) - (n32-to-i32 - (the (unsigned-byte 32) imm))))) - (the (unsigned-byte 32) imm))) + (if (and (not byte-operand?) + (equal rAX-size 8)) + (the (unsigned-byte 64) + (n64 + (the (signed-byte 32) + (n32-to-i32 + (the (unsigned-byte 32) imm))))) + (the (unsigned-byte 32) imm))) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip operand-size)) + (+ temp-rip operand-size)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :temp-rip-not-canonical temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :temp-rip-not-canonical temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Everything above this point is just further decoding the ;; instruction and fetching operands. @@ -799,17 +805,17 @@ ;; Computing the flags and the result: ((the (unsigned-byte 32) input-rflags) (rflags x86)) ((mv result - (the (unsigned-byte 32) output-rflags) - (the (unsigned-byte 32) undefined-flags)) - (gpr-arith/logic-spec rAX-size operation rAX imm input-rflags)) + (the (unsigned-byte 32) output-rflags) + (the (unsigned-byte 32) undefined-flags)) + (gpr-arith/logic-spec rAX-size operation rAX imm input-rflags)) ;; Updating the x86 state with the result and eflags. (x86 - (if (or (eql operation #.*OP-CMP*) - (eql operation #.*OP-TEST*)) - ;; CMP and TEST modify just the flags. - x86 - (!rgfi-size rAX-size *rax* result rex-byte x86))) + (if (or (eql operation #.*OP-CMP*) + (eql operation #.*OP-TEST*)) + ;; CMP and TEST modify just the flags. + x86 + (!rgfi-size rAX-size *rax* result rex-byte x86))) (x86 (write-user-rflags output-rflags undefined-flags x86)) (x86 (!rip temp-rip x86))) @@ -823,10 +829,10 @@ (local (defthm logsquash-and-logand-32 (implies (unsigned-byte-p 32 x) - (equal (bitops::logsquash 1 x) - (logand 4294967294 x))) + (equal (bitops::logsquash 1 x) + (logand 4294967294 x))) :hints (("Goal" :in-theory (e/d (bitops::logsquash) - (bitops::logand-with-negated-bitmask)))))) + (bitops::logand-with-negated-bitmask)))))) (def-inst x86-inc/dec-FE-FF @@ -836,17 +842,17 @@ :parents (one-byte-opcodes) :returns (x86 x86p :hyp (and (x86p x86) - (canonical-address-p temp-rip))) + (canonical-address-p temp-rip))) :implemented (progn (add-to-implemented-opcodes-table 'INC #xFE '(:reg 0) - 'x86-inc/dec-FE-FF) + 'x86-inc/dec-FE-FF) (add-to-implemented-opcodes-table 'DEC #xFE '(:reg 1) - 'x86-inc/dec-FE-FF) + 'x86-inc/dec-FE-FF) (add-to-implemented-opcodes-table 'INC #xFF '(:reg 0) - 'x86-inc/dec-FE-FF) + 'x86-inc/dec-FE-FF) (add-to-implemented-opcodes-table 'DEC #xFF '(:reg 1) - 'x86-inc/dec-FE-FF)) + 'x86-inc/dec-FE-FF)) :body @@ -856,67 +862,69 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (equal #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (select-byte-operand (equal 0 (logand 1 opcode))) ((the (integer 1 8) r/mem-size) - (select-operand-size - select-byte-operand rex-byte nil prefixes)) + (select-operand-size + select-byte-operand rex-byte nil prefixes)) (inst-ac? t) ((mv flg0 r/mem (the (unsigned-byte 3) increment-RIP-by) - (the (signed-byte #.*max-linear-address-size*) v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* r/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (signed-byte #.*max-linear-address-size*) v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*rgf-access* r/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :virtual-memory-error temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :virtual-memory-error temp-rip)) ;; If the instruction goes beyond 15 bytes, stop. Change to an ;; exception later. ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Computing the flags and the result: ((the (unsigned-byte 32) input-rflags) (rflags x86)) ((the (unsigned-byte 1) old-cf) - (rflags-slice :cf input-rflags)) + (rflags-slice :cf input-rflags)) ((mv result output-rflags undefined-flags) - (gpr-arith/logic-spec r/mem-size - (if (eql reg 0) - ;; INC - #.*OP-ADD* - ;; DEC - #.*OP-SUB*) - r/mem 1 input-rflags)) + (gpr-arith/logic-spec r/mem-size + (if (eql reg 0) + ;; INC + #.*OP-ADD* + ;; DEC + #.*OP-SUB*) + r/mem 1 input-rflags)) ;; Updating the x86 state: ;; CF is unchanged. (output-rflags (the (unsigned-byte 32) - (!rflags-slice :cf old-cf output-rflags))) + (!rflags-slice :cf old-cf output-rflags))) (x86 (write-user-rflags output-rflags undefined-flags x86)) ((mv flg1 x86) - (x86-operand-to-reg/mem - r/mem-size inst-ac? result - (the (signed-byte #.*max-linear-address-size*) v-addr) - rex-byte r/m mod x86)) + (x86-operand-to-reg/mem + r/mem-size inst-ac? result + (the (signed-byte #.*max-linear-address-size*) v-addr) + rex-byte r/m mod x86)) ((when flg1) - (!!ms-fresh :x86-operand-to-reg/mem flg1)) + (!!ms-fresh :x86-operand-to-reg/mem flg1)) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: NOT/NEG @@ -933,17 +941,17 @@ :parents (one-byte-opcodes) :returns (x86 x86p :hyp (and (x86p x86) - (canonical-address-p temp-rip))) + (canonical-address-p temp-rip))) :implemented (progn (add-to-implemented-opcodes-table 'NOT #xF6 '(:reg 2) - 'x86-not/neg-F6-F7) + 'x86-not/neg-F6-F7) (add-to-implemented-opcodes-table 'NOT #xF6 '(:reg 3) - 'x86-not/neg-F6-F7) + 'x86-not/neg-F6-F7) (add-to-implemented-opcodes-table 'NEG #xF7 '(:reg 2) - 'x86-not/neg-F6-F7) + 'x86-not/neg-F6-F7) (add-to-implemented-opcodes-table 'NEG #xF7 '(:reg 3) - 'x86-not/neg-F6-F7)) + 'x86-not/neg-F6-F7)) :body (b* ((ctx 'x86-not/neg-F6-F7) @@ -952,70 +960,72 @@ (reg (the (unsigned-byte 3) (mrm-reg modr/m))) (p2 (prefixes-slice :group-2-prefix prefixes)) (p4? (equal #.*addr-size-override* - (prefixes-slice :group-4-prefix prefixes))) + (prefixes-slice :group-4-prefix prefixes))) (select-byte-operand (equal 0 (logand 1 opcode))) ((the (integer 0 8) r/mem-size) - (select-operand-size select-byte-operand rex-byte nil - prefixes)) + (select-operand-size select-byte-operand rex-byte nil + prefixes)) (inst-ac? t) ((mv flg0 r/mem (the (unsigned-byte 3) increment-RIP-by) - (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) - (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* r/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) + (x86-operand-from-modr/m-and-sib-bytes + #.*rgf-access* r/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) - (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) + (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) temp-rip) - (+ temp-rip increment-RIP-by)) + (+ temp-rip increment-RIP-by)) ((when (mbe :logic (not (canonical-address-p temp-rip)) - :exec (<= #.*2^47* - (the (signed-byte - #.*max-linear-address-size+1*) - temp-rip)))) - (!!ms-fresh :virtual-memory-error temp-rip)) + :exec (<= #.*2^47* + (the (signed-byte + #.*max-linear-address-size+1*) + temp-rip)))) + (!!ms-fresh :virtual-memory-error temp-rip)) ((the (signed-byte #.*max-linear-address-size+1*) addr-diff) - (- - (the (signed-byte #.*max-linear-address-size*) - temp-rip) - (the (signed-byte #.*max-linear-address-size*) - start-rip))) + (- + (the (signed-byte #.*max-linear-address-size*) + temp-rip) + (the (signed-byte #.*max-linear-address-size*) + start-rip))) ((when (< 15 addr-diff)) - (!!ms-fresh :instruction-length addr-diff)) + (!!ms-fresh :instruction-length addr-diff)) ;; Computing the flags and the result: ((the (unsigned-byte 32) input-rflags) (rflags x86)) ((mv result - (the (unsigned-byte 32) output-rflags) - (the (unsigned-byte 32) undefined-flags)) - (case reg - (3 - ;; (NEG x) = (SUB 0 x) - (gpr-arith/logic-spec r/mem-size #.*OP-SUB* 0 r/mem input-rflags)) - (otherwise - ;; NOT (and some other instructions not specified yet) - (mv (trunc r/mem-size (lognot r/mem)) 0 0)))) + (the (unsigned-byte 32) output-rflags) + (the (unsigned-byte 32) undefined-flags)) + (case reg + (3 + ;; (NEG x) = (SUB 0 x) + (gpr-arith/logic-spec r/mem-size #.*OP-SUB* 0 r/mem input-rflags)) + (otherwise + ;; NOT (and some other instructions not specified yet) + (mv (trunc r/mem-size (lognot r/mem)) 0 0)))) ;; Updating the x86 state: (x86 - (if (eql reg 3) - (let* ( ;; CF is special for NEG. - (cf (the (unsigned-byte 1) (if (equal 0 r/mem) 0 1))) - (output-rflags - (the (unsigned-byte 32) - (!rflags-slice :cf cf output-rflags))) - (x86 (write-user-rflags output-rflags undefined-flags x86))) - x86) - x86)) + (if (eql reg 3) + (let* ( ;; CF is special for NEG. + (cf (the (unsigned-byte 1) (if (equal 0 r/mem) 0 1))) + (output-rflags + (the (unsigned-byte 32) + (!rflags-slice :cf cf output-rflags))) + (x86 (write-user-rflags output-rflags undefined-flags x86))) + x86) + x86)) ((mv flg1 x86) - (x86-operand-to-reg/mem - r/mem-size inst-ac? result (the (signed-byte #.*max-linear-address-size*) v-addr) - rex-byte r/m mod x86)) + (x86-operand-to-reg/mem + r/mem-size inst-ac? result (the (signed-byte #.*max-linear-address-size*) v-addr) + rex-byte r/m mod x86)) ((when flg1) - (!!ms-fresh :x86-operand-to-reg/mem flg1)) + (!!ms-fresh :x86-operand-to-reg/mem flg1)) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== diff --git a/books/projects/x86isa/machine/instructions/x86-bit-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-bit-instructions.lisp index 5d0debd48ba..f1516708b1c 100644 --- a/books/projects/x86isa/machine/instructions/x86-bit-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-bit-instructions.lisp @@ -52,7 +52,9 @@ ((mv flg0 bitBase (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 1 x86)) + #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 1 ;; One-byte immediate data + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -154,7 +156,9 @@ (mv nil 0 0 x86) (let ((p4? (equal #.*addr-size-override* (prefixes-slice :group-4-prefix prefixes)))) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86)))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)))) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) ((mv flg1 v-addr) diff --git a/books/projects/x86isa/machine/instructions/x86-conditional-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-conditional-instructions.lisp index 610ce713f6d..815ce1e475f 100644 --- a/books/projects/x86isa/machine/instructions/x86-conditional-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-conditional-instructions.lisp @@ -434,7 +434,7 @@ :guard-hints (("Goal" :in-theory (e/d (rim08 rim32) ()))) :returns (x86 x86p :hyp (and (x86p x86) - (canonical-address-p temp-rip))) + (canonical-address-p temp-rip))) :body ;; Note, opcode here denotes the second byte of the two-byte opcode. @@ -458,7 +458,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -491,7 +493,7 @@ x86)) (x86 (!rip temp-rip x86))) x86) - + :implemented (progn (add-to-implemented-opcodes-table 'CMOVO #x0F40 '(:nil nil) @@ -554,7 +556,7 @@ :guard-hints (("Goal" :in-theory (e/d (rim08 rim32) ()))) :returns (x86 x86p :hyp (and (x86p x86) - (canonical-address-p temp-rip))) + (canonical-address-p temp-rip))) :body @@ -573,7 +575,9 @@ ((mv flg0 (the (signed-byte 64) v-addr) (the (unsigned-byte 3) increment-RIP-by) x86) (if (equal mod #b11) (mv nil 0 0 x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) ((mv flg1 v-addr) @@ -635,7 +639,7 @@ (!!ms-fresh :x86-operand-to-reg/mem flg2)) (x86 (!rip temp-rip x86))) x86) - + :implemented (progn (add-to-implemented-opcodes-table 'SETO #x0F90 '(:nil nil) diff --git a/books/projects/x86isa/machine/instructions/x86-divide-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-divide-instructions.lisp index 412db49d56e..7f64d0b3fc3 100644 --- a/books/projects/x86isa/machine/instructions/x86-divide-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-divide-instructions.lisp @@ -79,7 +79,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -157,7 +159,7 @@ (x86 (!flgi-undefined #.*of* x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: IDIV @@ -211,7 +213,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) diff --git a/books/projects/x86isa/machine/instructions/x86-exchange-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-exchange-instructions.lisp index 76407486c33..c78f744adda 100644 --- a/books/projects/x86isa/machine/instructions/x86-exchange-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-exchange-instructions.lisp @@ -86,7 +86,9 @@ (if (equal (ash opcode -4) 9) ;; #x90+rw/rd (mv nil (rgfi-size reg/mem-size *rax* rex-byte x86) 0 0 x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86))) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((when (mbe :logic (not (canonical-address-p v-addr)) @@ -145,7 +147,7 @@ x86))) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: CMPXCHG @@ -195,7 +197,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -304,7 +308,9 @@ ((mv flg0 (the (signed-byte 64) ?v-addr) (the (unsigned-byte 3) increment-RIP-by) x86) (if (equal mod #b11) (mv nil 0 0 x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg0) (!!ms-fresh :x86-effective-addr flg0)) @@ -318,6 +324,6 @@ (!!ms-fresh :next-rip-invalid temp-rip)) ;; Update the x86 state: (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== diff --git a/books/projects/x86isa/machine/instructions/x86-jump-and-loop-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-jump-and-loop-instructions.lisp index 6cfce8c0be6..21dfe12b659 100644 --- a/books/projects/x86isa/machine/instructions/x86-jump-and-loop-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-jump-and-loop-instructions.lisp @@ -151,8 +151,9 @@ ((mv flg jmp-addr (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m - mod sib 0 x86)) + #.*rgf-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes-error flg)) @@ -265,6 +266,8 @@ indirectly with a memory location \(m16:16 or m16:32 or m16:64\).

      " ;; Offset size can be 2, 4, or 8 bytes. (select-operand-size nil rex-byte nil prefixes)) (inst-ac? t) + ;; TODO: I'm not sure that (+ 2 offset-size) below is correct. + ;; I need to check what "Mp" operands really mean. ((mv flg mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes @@ -273,7 +276,9 @@ indirectly with a memory location \(m16:16 or m16:32 or m16:64\).

      " ;; offset. We need two more bytes for the selector. (the (integer 2 10) (+ 2 offset-size)) inst-ac? - p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes-error flg)) diff --git a/books/projects/x86isa/machine/instructions/x86-move-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-move-instructions.lisp index 6f76d75ffe5..d17e6e117a4 100644 --- a/books/projects/x86isa/machine/instructions/x86-move-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-move-instructions.lisp @@ -68,7 +68,9 @@ ((mv flg0 (the (signed-byte 64) v-addr) (the (unsigned-byte 3) increment-RIP-by) x86) (if (equal mod #b11) (mv nil 0 0 x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) ((mv flg1 v-addr) @@ -179,7 +181,9 @@ (inst-ac? t) ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) ?v-addr x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* operand-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -509,7 +513,8 @@ (if (equal mod #b11) (mv nil 0 0 x86) (x86-effective-addr p4? temp-rip rex-byte r/m mod sib - operand-size x86))) + operand-size ;; bytes of immediate data + x86))) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) ((mv flg1 v-addr) @@ -632,7 +637,9 @@ (if (equal mod #b11) ;; See "M" in http://ref.x86asm.net/#Instruction-Operand-Codes (mv "Source operand is not a memory location" 0 0 x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg0) (!!ms-fresh :x86-effective-addr-error flg0)) @@ -685,7 +692,7 @@ (x86 (!rgfi-size register-size (reg-index reg rex-byte #.*r*) M rex-byte x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: MOVSXD/MOVSLQ @@ -730,7 +737,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -764,7 +773,7 @@ (x86 (!rgfi-size register-size (reg-index reg rex-byte #.*r*) reg/mem rex-byte x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) (def-inst x86-two-byte-movsxd @@ -811,7 +820,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -855,7 +866,7 @@ (x86 (!rgfi-size register-size (reg-index reg rex-byte #.*r*) reg/mem rex-byte x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: MOVZX @@ -902,7 +913,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) diff --git a/books/projects/x86isa/machine/instructions/x86-multiply-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-multiply-instructions.lisp index 9aad8a63612..988df4b5f94 100644 --- a/books/projects/x86isa/machine/instructions/x86-multiply-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-multiply-instructions.lisp @@ -64,7 +64,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -126,7 +128,7 @@ x86))) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: IMUL @@ -183,7 +185,9 @@ (inst-ac? t) ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) ?v-addr x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -276,7 +280,9 @@ ((mv flg0 reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -378,7 +384,9 @@ (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib imm-size x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + imm-size ;; imm-size bytes of immediate data + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) diff --git a/books/projects/x86isa/machine/instructions/x86-push-and-pop-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-push-and-pop-instructions.lisp index 1b709e74a63..a503cfa9800 100644 --- a/books/projects/x86isa/machine/instructions/x86-push-and-pop-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-push-and-pop-instructions.lisp @@ -151,7 +151,9 @@ extension (ModR/m.reg = 6).

      " (x86-operand-from-modr/m-and-sib-bytes ;; inst-ac? is nil here because we only need increment-RIP-by ;; from this function. - #.*rgf-access* operand-size nil p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* operand-size nil p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -185,7 +187,7 @@ extension (ModR/m.reg = 6).

      " (x86 (!rgfi *rsp* (the (signed-byte #.*max-linear-address-size*) new-rsp) x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) (def-inst x86-push-I @@ -506,7 +508,9 @@ extension (ModR/m.reg = 0).

      " ((mv flg1 (the (signed-byte 64) v-addr) (the (unsigned-byte 3) increment-RIP-by) x86) (if (equal mod #b11) (mv nil 0 0 x86) - (x86-effective-addr p4? temp-rip rex-byte r/m mod sib 0 x86))) + (x86-effective-addr p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86))) ((when flg1) ;; #SS exception? (!!ms-fresh :x86-effective-addr-error flg1)) diff --git a/books/projects/x86isa/machine/instructions/x86-rotate-and-shift-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-rotate-and-shift-instructions.lisp index f344b00fe50..caa6d1d89a9 100644 --- a/books/projects/x86isa/machine/instructions/x86-rotate-and-shift-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-rotate-and-shift-instructions.lisp @@ -197,7 +197,14 @@ ((mv flg0 ?reg/mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* reg/mem-size inst-ac? p2 p4 temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* reg/mem-size inst-ac? p2 p4 temp-rip rex-byte r/m mod sib + ;; Bytes of immediate data (only relevant when RIP-relative + ;; addressing is done to get ?reg/mem operand) + (if (or (equal opcode #xC0) + (equal opcode #xC1)) + 1 + 0) + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) diff --git a/books/projects/x86isa/machine/instructions/x86-segmentation-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-segmentation-instructions.lisp index bc3691e8248..d681fd4bb98 100644 --- a/books/projects/x86isa/machine/instructions/x86-segmentation-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-segmentation-instructions.lisp @@ -69,7 +69,9 @@ ((mv flg0 mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - 0 10 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + 0 10 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -95,7 +97,7 @@ ;; Update the x86 state: (x86 (!stri *gdtr* gdtr x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: LIDT @@ -154,7 +156,9 @@ ((mv flg0 mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - 0 10 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + 0 10 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -180,7 +184,7 @@ ;; Update the x86 state: (x86 (!stri *idtr* idtr x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: LLDT @@ -244,7 +248,9 @@ a non-canonical form, raise the SS exception.

      " ((mv flg0 selector (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - 0 2 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + 0 2 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) @@ -377,6 +383,6 @@ a non-canonical form, raise the SS exception.

      " (x86 (!ssr-hiddeni *ldtr* ldtr-hidden x86)) (x86 (!rip temp-rip x86))) - x86)) + x86)) ;; ====================================================================== diff --git a/books/projects/x86isa/machine/instructions/x86-subroutine-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-subroutine-instructions.lisp index 440a56adcb0..9a84de4f7fe 100644 --- a/books/projects/x86isa/machine/instructions/x86-subroutine-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-subroutine-instructions.lisp @@ -151,7 +151,9 @@ ((mv flg0 (the (unsigned-byte 64) call-rip) (the (unsigned-byte 3) increment-rip-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - #.*rgf-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 x86)) + #.*rgf-access* 8 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 ;; No immediate operand + x86)) ((when flg0) (!!ms-fresh :x86-operand-from-modr/m-and-sib-bytes flg0)) ((the (signed-byte #.*max-linear-address-size+1*) next-rip) @@ -190,7 +192,7 @@ (x86 (!rip call-rip x86)) ;; Decrement the stack pointer. (x86 (!rgfi *rsp* (the (signed-byte #.*max-linear-address-size*) new-rsp) x86))) - x86)) + x86)) ;; ====================================================================== ;; INSTRUCTION: RET diff --git a/books/projects/x86isa/machine/x86-decoding-and-spec-utils.lisp b/books/projects/x86isa/machine/x86-decoding-and-spec-utils.lisp index 1740749879b..d152896e28d 100644 --- a/books/projects/x86isa/machine/x86-decoding-and-spec-utils.lisp +++ b/books/projects/x86isa/machine/x86-decoding-and-spec-utils.lisp @@ -189,7 +189,11 @@ field conveying useful information.

      7. (mod :type (unsigned-byte 2) "mod field of ModR/M byte") (sib :type (unsigned-byte 8) "Sib byte") ;; num-imm-bytes is needed for computing the next RIP when - ;; RIP-relative addressing is done. + ;; RIP-relative addressing is done. Note that this argument is + ;; only relevant when the operand addressing mode is I, i.e., + ;; when the operand value is encoded in subsequent bytes of the + ;; instruction. For details, see *Z-addressing-method-info* in + ;; x86isa/utils/decoding-utilities.lisp. (num-imm-bytes :type (unsigned-byte 3) "Number of immediate bytes (0, 1, 2, or 4) that follow the sib (or displacement bytes, if any).") x86) diff --git a/books/projects/x86isa/machine/x86-top-level-memory.lisp b/books/projects/x86isa/machine/x86-top-level-memory.lisp index 9efdf062d54..5fa1a4df44e 100644 --- a/books/projects/x86isa/machine/x86-top-level-memory.lisp +++ b/books/projects/x86isa/machine/x86-top-level-memory.lisp @@ -3827,7 +3827,7 @@ memory.

      7. (logior (the (unsigned-byte 16) val15-0) (the (unsigned-byte 48) (ash (the (unsigned-byte 64) val48-16) 16)))))) - (mv (and flg0 flg1) val x86))) + (mv (or flg0 flg1) val x86))) (8 (rm64 addr r-w-x x86)) ;; Use case: The instructions LGDT and LIDT need to read 10 ;; bytes at once. @@ -3849,7 +3849,7 @@ memory. (logior (the (unsigned-byte 16) val15-0) (the (unsigned-byte 80) (ash (the (unsigned-byte 64) val79-16) 16)))))) - (mv (and flg0 flg1) val x86))) + (mv (or flg0 flg1) val x86))) (16 (rm128 addr r-w-x x86)) (otherwise (mv 'unsupported-nbytes nbytes x86))) @@ -3919,7 +3919,7 @@ memory. x86)) ((mv flg1 x86) (wm32 (+ 2 addr) (the (unsigned-byte 32) val48-16) x86))) - (mv (and flg0 flg1) x86))) + (mv (or flg0 flg1) x86))) (8 (wm64 addr val x86)) (10 ;; Use case: Instructions like SGDT and SIDT write 10 bytes to @@ -3948,7 +3948,7 @@ memory. x86)) ((mv flg1 x86) (wm64 (+ 2 addr) (the (unsigned-byte 64) val79-16) x86))) - (mv (and flg0 flg1) x86))) + (mv (or flg0 flg1) x86))) (16 (wm128 addr val x86)) (otherwise (mv 'unsupported-nbytes x86)))) diff --git a/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/README b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/README new file mode 100644 index 00000000000..334cc5a2449 --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/README @@ -0,0 +1,6 @@ +This directory contains test cases that document the differences +between the x86isa interpreter and a real x86 processor. Serious +differences are fixed (but test cases left here for reference) and +those resulting from intentional design decisions are logged for +documentation. An example of the latter is in the file +disp-immed-fault.lsp. \ No newline at end of file diff --git a/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/acl2-customization.lsp b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/acl2-customization.lsp new file mode 100644 index 00000000000..977a63070f1 --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/acl2-customization.lsp @@ -0,0 +1,7 @@ +;; Shilpi Goel + +(ld "~/acl2-customization.lsp" :ld-missing-input-ok t) +(set-deferred-ttag-notes t state) + +(ld "cert.acl2" :ld-missing-input-ok t) +(in-package "X86ISA") diff --git a/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/cert.acl2 b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/cert.acl2 new file mode 100644 index 00000000000..2ad3dbde7d5 --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/cert.acl2 @@ -0,0 +1,9 @@ +;; Shilpi Goel + +;; ====================================================================== + +(set-waterfall-parallelism t) +(include-book "../../../../portcullis/sharp-dot-constants") +;; cert-flags: ? t :ttags (:include-raw :syscall-exec :other-non-det :undef-flg :instrument) :skip-proofs-okp t + +;; ====================================================================== \ No newline at end of file diff --git a/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/disp-immed-fault.lsp b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/disp-immed-fault.lsp new file mode 100644 index 00000000000..8a984d78921 --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/disp-immed-fault.lsp @@ -0,0 +1,106 @@ +;; Original Author: Dmitry Nadezhin + +(in-package "X86ISA") +(include-book "std/util/defrule" :dir :system) +(include-book "projects/x86isa/proofs/utilities/programmer-level-mode/top" :dir :system) + +(include-book "tools/with-arith5-help" :dir :system) +(local (acl2::allow-arith5-help)) + +;; ====================================================================== + +; Local lemma + +(local + (acl2::with-arith5-help + (defrule n64-to-i64-as-logext + (equal (n64-to-i64 (n64 addr)) + (logext 64 addr))))) + +(local + (defrule logand-0 + (equal (logand x 0) 0) + :enable logand)) + +; This is an instruction which has both 1-byte displacement and 1-byte +; immediate. Suppose that 1-byte immediate is-not at canonical-address. +; Then model should raise an exception about immediate. +; Let's check it. + +(defconst *test_code* + '(#x80 #x45 #x02)) ; #x?? ; addb [rbp+2],?? + +(defun test-state (x86) + (declare (xargs :stobjs (x86))) + (let ((rip (rip x86))) + (and (x86p x86) + (equal (ms x86) nil) + (equal (fault x86) nil) + (programmer-level-mode x86) + (canonical-address-p rip) + (canonical-address-p (+ -1 rip (len *test_code*))) + (not (canonical-address-p (+ rip (len *test_code*)))) + (program-at (create-canonical-address-list + (len *test_code*) rip) + *test_code* + x86)))) + +(defun test-state-1 (x86) + (declare (xargs :stobjs (x86))) + (and (test-state x86) + (canonical-address-p (logext 64 (+ 2 (rgfi *rbp* x86)))))) + +(defun test-state-2 (x86) + (declare (xargs :stobjs (x86))) + (and (test-state x86) + (not (canonical-address-p (logext 64 (+ 2 (rgfi *rbp* x86))))))) + +; Suppose that [rbp+2] is a canonical-address-p. +; Model aborts with a message "temp-rip-not-canonical" as expected. + +(defrule test-1-thm + (b* ((start-rip (xr :rip 0 x86)) + (temp-rip (+ 3 start-rip)) + (x86-new (x86-fetch-decode-execute x86))) + (implies + (test-state-1 x86) + (equal + x86-new + (xw :ms 0 + `((X86-ADD/ADC/SUB/SBB/OR/AND/XOR/CMP-TEST-E-I + :rip ,start-rip + :temp-rip-not-canonical ,temp-rip)) + x86)))) + :enable (x86-fetch-decode-execute + x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I + x86-operand-from-modr/m-and-sib-bytes + x86-effective-addr) + :disable (n64 n64-to-i64 logext) + :rule-classes ()) + +; Suppose that [rbp+2] is a not canonical-address-p. +; Model aborts with a message +; "x86-operand-from-modr/m-and-sib-bytes-non-canonical-address-encountered". +; I expect here the same message "temp-rip-not-canonical" as in previous theorem. + +(defrule test-2-thm + (b* ((start-rip (xr :rip 0 x86)) + (x86-new (x86-fetch-decode-execute x86))) + (implies + (test-state-2 x86) + (equal + x86-new + (xw :ms 0 + `((x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I + :rip ,start-rip + :x86-operand-from-modr/m-and-sib-bytes + x86-operand-from-modr/m-and-sib-bytes-non-canonical-address-encountered)) + x86)))) + :enable (x86-fetch-decode-execute + x86-add/adc/sub/sbb/or/and/xor/cmp-test-E-I + x86-operand-from-modr/m-and-sib-bytes + x86-effective-addr) + :disable (n64 n64-to-i64 logext) + :rule-classes ()) + +;; ====================================================================== diff --git a/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/imm-bytes-for-rip-relative-addressing.lsp b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/imm-bytes-for-rip-relative-addressing.lsp new file mode 100644 index 00000000000..7d6d008cd65 --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/imm-bytes-for-rip-relative-addressing.lsp @@ -0,0 +1,92 @@ +;; Original Author: Shilpi Goel +;; Thanks to Dmitry Nadezhin for bringing this case to my attention! + +(in-package "X86ISA") +(include-book "projects/x86isa/proofs/utilities/programmer-level-mode/top" :dir :system) + +(local (include-book "centaur/bitops/ihs-extensions" :dir :system)) +(local (include-book "centaur/bitops/signed-byte-p" :dir :system)) + +;; ====================================================================== + +(defconst *mov_test_code* + ;; MOV r/m8, imm8 + ;; RIP-relative addressing + ;; Destination = memory location[next rip + sign-extended(#xdd0000fd)] + ;; ModR/M = #x05 (mod=0, r/m=5, reg=0) + ;; immediate data=#x01 + '(#xc6 #x05 #xfd #x00 #x00 #xdd #x01)) + +(trace$ wm08) + +(b* + ;; wm08 should write #x01 to memory location #xdd001078, which is + ;; the next-rip (#x100000f7b) plus sign-extended value of + ;; #xdd0000fd (#x-22ffff03). + ((start-rip #x100000f74) + (x86 (!ms nil x86)) + (x86 (!fault nil x86)) + (x86 (!programmer-level-mode t x86)) + (x86 (!rip start-rip x86)) + ((mv flg0 x86) + (wm64 start-rip (combine-bytes *mov_test_code*) x86)) + ((when flg0) x86) + (x86 (x86-fetch-decode-execute x86)) + (- (cw "~% rip: ~x0 ms: ~x1~%" (rip x86) (ms x86)))) + x86) + +(defconst *add_test_code* + ;; ADD r/m8, imm8 + ;; RIP-relative addressing + ;; Destination = memory location[next rip + sign-extended(#000000xFF)] + ;; Immediate data = #x20 + '(#x80 #x05 #xFF #x0 #x0 #x0 #x20)) + +(b* + ;; wm08 should add #x20 to memory location #xdd001078, which + ;; already contains 1 from the previous test. + ((start-rip #x100000f74) + (x86 (!ms nil x86)) + (x86 (!fault nil x86)) + (x86 (!programmer-level-mode t x86)) + (x86 (!rip start-rip x86)) + ((mv flg0 x86) + (wm64 start-rip (combine-bytes *add_test_code*) x86)) + ((when flg0) x86) + (x86 (x86-fetch-decode-execute x86)) + (- (cw "~% rip: ~x0 ms: ~x1~%" (rip x86) (ms x86)))) + x86) + +;; ====================================================================== + +#|| + +// This program tests RIP-relative addressing. +// gcc rip-relative-addressing.c -o rip-relative-addressing.o +// I just need to see the objdump of the executable and not really run +// the code. + +#include +#include + +void test(void) { + + __asm__ volatile + ( + "movb $0x01, 0xdd0000fe(%%rip)\n\t" + + : // output list + + : // input list + + : "cc", "memory"); + +} +int main () { + + test(); + return 0; + +} + +||# diff --git a/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/redundant-prefixes.lsp b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/redundant-prefixes.lsp new file mode 100644 index 00000000000..85e6b720c9d --- /dev/null +++ b/books/projects/x86isa/tools/execution/examples/documenting-edge-cases/redundant-prefixes.lsp @@ -0,0 +1,109 @@ +;; Original Author: Dmitry Nadezhin +;; Some edits by Shilpi Goel + +(in-package "X86ISA") +(include-book "std/util/defrule" :dir :system) +(include-book "projects/x86isa/proofs/utilities/programmer-level-mode/top" :dir :system) + +;; ====================================================================== + +(defconst *test_code* + '(#xf0 #xf0 #xf0 #xf0 #xf0 #x00 #x00)) + +(defrule get-prefixes-opener-lemma-group-1-prefix-redundant + (implies (and (programmer-level-mode x86) + (let* ((flg (mv-nth 0 (rm08 start-rip :x x86))) + (prefix-byte-group-code + (get-one-byte-prefix-array-code + (mv-nth 1 (rm08 start-rip :x x86))))) + (and (not flg) ;; No error in reading a byte + (equal prefix-byte-group-code 1))) + (equal (prefixes-slice :group-1-prefix prefixes) + (mv-nth 1 (rm08 start-rip :x x86))) + (not (zp cnt)) + (canonical-address-p (1+ start-rip))) + (equal (get-prefixes start-rip prefixes cnt x86) + (get-prefixes (1+ start-rip) + (!prefixes-slice :group-1-prefix + (mv-nth 1 (rm08 start-rip :x x86)) + prefixes) + (1- cnt) x86))) + :in-theory (e/d (rb) ()) + :expand (get-prefixes start-rip prefixes cnt x86)) + +(defrule test-thm + (implies + (and (x86p x86) + (equal (ms x86) nil) + (equal (fault x86) nil) + (programmer-level-mode x86) + (canonical-address-p (rip x86)) + (canonical-address-p (+ (rip x86) (len *test_code*))) + (program-at (create-canonical-address-list + (len *test_code*) (rip x86)) + *test_code* + x86)) + (equal (x86-fetch-decode-execute x86) + (X86-ADD/ADC/SUB/SBB/OR/AND/XOR/CMP/TEST-E-G 0 (XR :RIP 0 X86) + (+ 7 (XR :RIP 0 X86)) + 3845 0 0 0 0 X86))) + :enable (x86-fetch-decode-execute) + :rule-classes ()) + +;; ====================================================================== + +;; Concrete execution examples: + +(b* + ;; Poised to execute: #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #x00 #x00 + ;; (legal instruction with 13 redundant lock prefixes, #x00 modr/m byte, and #x00 opcode) + ((start-rip 0) + (x86 (!ms nil x86)) + (x86 (!fault nil x86)) + (x86 (!programmer-level-mode t x86)) + (x86 (!rip start-rip x86)) + ((mv flg0 x86) + (wm64 start-rip (combine-bytes '(#xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0)) x86)) + ((mv flg1 x86) + (wm64 (+ 8 start-rip) (combine-bytes '(#xF0 #xF0 #xF0 #xF0 #xF0 )) x86)) + ((when (or flg0 flg1)) x86) + (x86 (x86-fetch-decode-execute x86)) + (- (cw "~% rip: ~x0 ms: ~x1~%" (rip x86) (ms x86)))) + x86) +;; Prints: rip: 15 ms: NIL + +(b* + ;; Poised to execute: #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #x00 #x00 + ;; (illegal instruction with 14 redundant lock prefixes) + ((start-rip 0) + (x86 (!ms nil x86)) + (x86 (!fault nil x86)) + (x86 (!programmer-level-mode t x86)) + (x86 (!rip start-rip x86)) + ((mv flg0 x86) + (wm64 start-rip (combine-bytes '(#xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0)) x86)) + ((mv flg1 x86) + (wm64 (+ 8 start-rip) (combine-bytes '(#xF0 #xF0 #xF0 #xF0 #xF0 #xF0 )) x86)) + ((when (or flg0 flg1)) x86) + (x86 (x86-fetch-decode-execute x86)) + (- (cw "~% rip: ~x0 ms: ~x1~%" (rip x86) (ms x86)))) + x86) +;; Prints: rip: 0 ms: ((X86-ADD/ADC/SUB/SBB/OR/AND/XOR/CMP/TEST-E-G :RIP 0 :INSTRUCTION-LENGTH 16)) + +(b* + ;; Poised to execute: #xF0 #xF3 #x00 #x00 + ;; (instruction with two group 1 prefixes --- the x86 model doesn't handle these kinds of situations) + ((start-rip 0) + (x86 (!ms nil x86)) + (x86 (!fault nil x86)) + (x86 (!programmer-level-mode t x86)) + (x86 (!rip start-rip x86)) + ((mv flg0 x86) + (wm64 start-rip (combine-bytes '(#xF0 #xF3)) x86)) + ((when flg0) x86) + (x86 (x86-fetch-decode-execute x86)) + (- (cw "~% rip: ~x0 ms: ~x1~%" (rip x86) (ms x86)))) + x86) +;; Prints: rip: 0 ms: ((X86-FETCH-DECODE-EXECUTE :RIP 0 :ERROR-IN-READING-PREFIXES T)) + +;; ====================================================================== From 61603599d4c6e4c42db2fb24bfa4ce3c3dbbc4f5 Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Fri, 29 Jul 2016 08:17:10 -0500 Subject: [PATCH 47/70] Added a book for dealing with filenames that are not valid ACL2 strings, and in support of that, improved how ACL2 deals with strings that come from outside ACL2. Quoting :doc note-7-3: The utility [getenv$] now causes an error if the value it would otherwise return is not an ACL2 string, for example because it contains a character whose [char-code] exceeds 255. Many other changes, less visible to the user, have been made in how ACL2 deals with strings that come from outside ACL2, in particular, file names (see the related item just above). The new book, books/kestrel/utilities/non-ascii-pathnames.lisp, has some documentation at the top in the form of Lisp comments. Xdoc documentation may come later. --- acl2-fns.lisp | 79 +++--- acl2-init.lisp | 10 +- axioms.lisp | 137 +++++----- basis-a.lisp | 14 +- .../utilities/non-ascii-pathnames-raw.lsp | 255 ++++++++++++++++++ .../utilities/non-ascii-pathnames.acl2 | 1 + .../utilities/non-ascii-pathnames.lisp | 72 +++++ books/kestrel/utilities/top.lisp | 2 + books/system/doc/acl2-doc.lisp | 27 +- interface-raw.lisp | 188 +++++++------ other-events.lisp | 207 +++++++------- 11 files changed, 709 insertions(+), 283 deletions(-) create mode 100644 books/kestrel/utilities/non-ascii-pathnames-raw.lsp create mode 100644 books/kestrel/utilities/non-ascii-pathnames.acl2 create mode 100644 books/kestrel/utilities/non-ascii-pathnames.lisp diff --git a/acl2-fns.lisp b/acl2-fns.lisp index 3e6be7cc3c2..5b004ff7380 100644 --- a/acl2-fns.lisp +++ b/acl2-fns.lisp @@ -1549,26 +1549,38 @@ notation causes an error and (b) the use of ,. is not permitted." ; The following either returns the value of the given environment variable or ; returns nil (in lisps where we do not yet know how to get that value). +; Except, it causes an error if the computed value is an illegal ACL2 string. ; WARNING: Keep this in sync with the #-acl2-loop-only definition of setenv$. - #+cmu - (cond (*cmucl-unix-getenv-fn* - (funcall *cmucl-unix-getenv-fn* string)) - ((boundp 'ext::*environment-list*) - (cdr (assoc (intern string :keyword) - ext::*environment-list* - :test #'eq)))) - #+(or gcl allegro lispworks ccl sbcl clisp) - (let ((fn - #+gcl 'si::getenv - #+allegro 'sys::getenv - #+lispworks 'hcl::getenv - #+ccl 'ccl::getenv - #+sbcl 'sb-ext::posix-getenv - #+clisp 'ext:getenv)) - (and (fboundp fn) - (funcall fn string)))) + (let* ((val + #+cmu + (cond (*cmucl-unix-getenv-fn* + (funcall *cmucl-unix-getenv-fn* string)) + ((boundp 'ext::*environment-list*) + (cdr (assoc (intern string :keyword) + ext::*environment-list* + :test #'eq)))) + #+(or gcl allegro lispworks ccl sbcl clisp) + (let ((fn + #+gcl 'si::getenv + #+allegro 'sys::getenv + #+lispworks 'hcl::getenv + #+ccl 'ccl::getenv + #+sbcl 'sb-ext::posix-getenv + #+clisp 'ext:getenv)) + (and (fboundp fn) + (funcall fn string)))) + (msg (and val + (fboundp 'bad-lisp-stringp) ; false early in boot-strap + (qfuncall bad-lisp-stringp val)))) + (cond (msg ; It's not clear that this case is possible, at least in CCL. + (qfuncall + interface-er + "The value of environment variable ~x0 is ~x1, which is not a ~ + legal ACL2 string.~%~@2" + string val msg)) + (t val)))) #+sbcl (defmacro define-our-sbcl-putenv () @@ -1615,9 +1627,11 @@ notation causes an error and (b) the use of ,. is not permitted." (defun our-truename (filename &optional namestringp) -; For now, assume that namestringp is nil (or not supplied). - ; Filename can be a pathname, in which case we treat it as its namestring. +; Both filename and the result of this function are OS filenames, which might +; have characters that disqualify them from being ACL2 strings. + +; For now, assume that namestringp is nil (or not supplied). ; This function is intended to return nil if filename does not exist. We thus ; rely on the CL HyperSpec, where it says of truename that "An error of type @@ -1671,9 +1685,6 @@ notation causes an error and (b) the use of ,. is not permitted." (ignore-errors (truename filename))))) (namestring (and truename (namestring truename)))) - (when (and namestring - *check-namestring*) ; always true unless a ttag is used - (qfuncall chk-bad-lisp-stringp namestring filename)) (cond ((null namestringp) truename) ((null truename) @@ -1691,21 +1702,14 @@ notation causes an error and (b) the use of ,. is not permitted." ""))))) (t namestring)))) -(defun our-pwd () - -; Warning: Do not be tempted to use (getenv$-raw "PWD"). The PWD environment -; variable is not necessarily maintained, for example in Solaris/SunOS as one -; make invokes another make in a different directory. - - (qfuncall pathname-os-to-unix - (our-truename "" "Note: Calling OUR-TRUENAME from OUR-PWD.") - (get-os) - *the-live-state*)) - (defun unix-full-pathname (name &optional extension) -; We formerly used Common Lisp function merge-pathnames. But in CCL, -; merge-pathnames can insert an extra backslash (\), as follows: +; Unlike truename and our-truename, unix-full-pathname does not assume that any +; particular file exists. + +; We formerly used Common Lisp function merge-pathnames. But with CCL +; (probably quite an old version), merge-pathnames has inserted an extra +; backslash (\), as follows: ; ? (MERGE-PATHNAMES "foo.xxx.lx86cl64" "/u/kaufmann/temp/") ; #P"/u/kaufmann/temp/foo\\.xxx.lx86cl64" @@ -1714,7 +1718,8 @@ notation causes an error and (b) the use of ,. is not permitted." ; Gary Byers has explained that while this behavior may not be ideal, it is ; legal for Common Lisp. So we avoid merge-pathnames here. - (let* ((os (get-os)) + (let* ((*check-namestring* t) + (os (get-os)) (state *the-live-state*) (name (qfuncall pathname-os-to-unix (if extension @@ -1729,7 +1734,7 @@ notation causes an error and (b) the use of ,. is not permitted." (cond ((qfuncall absolute-pathname-string-p name nil os) name) (t - (concatenate 'string (our-pwd) name)))))) + (concatenate 'string (qfuncall our-pwd) name)))))) (defun our-user-homedir-pathname () diff --git a/acl2-init.lisp b/acl2-init.lisp index f411f7e6b90..8f3c17b8f88 100644 --- a/acl2-init.lisp +++ b/acl2-init.lisp @@ -1893,7 +1893,10 @@ implementations.") Allegro 5.0 or later."))) (sysout-dxl (unix-full-pathname sysout-name "dxl"))) - (write-acl2rc (our-pwd)) + (write-acl2rc + (our-truename ; our-pwd, without converting to ACL2/Unix pathname + "" + "NOTE: Calling OUR-TRUENAME from save-acl2-in-allegro-aux")) (with-open-file ; write to nsaved_acl2 (str sysout-name :direction :output) (write-exec-file @@ -1967,7 +1970,10 @@ implementations.") #+clisp (defun save-acl2-in-clisp-aux (sysout-name mem-name host-lisp-args inert-args) - (let ((save-dir (our-pwd)) + (let ((save-dir + (our-truename ; our-pwd, without converting to ACL2/Unix pathname + "" + "NOTE: Calling OUR-TRUENAME from save-acl2-in-clisp-aux")) (eventual-sysout-mem (unix-full-pathname mem-name "mem")) (sysout-mem diff --git a/axioms.lisp b/axioms.lisp index 24370345701..1797267a2d6 100644 --- a/axioms.lisp +++ b/axioms.lisp @@ -16607,20 +16607,21 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step #-acl2-loop-only (defvar *read-file-alist* -; This alist associates each filename key with both a file-clock and its -; file-write-date. Recall that the keys into the readable-files component of -; the ACL2 state are of the form (list file-name typ file-clock); see -; open-input-channel. In order to preserve our logical story about file IO, we -; must avoid logically associating such a key with two different character -; lists. That could happen if read-file-into-string is called twice on the -; same filename, say "F", in the case that there is an intervening write not -; performed by ACL2. We avoid that problem by associating "F" with its current -; file-write-date, FWD, in the global *read-file-alist* just before opening a -; character input channel to "F". That global is cleared whenever the -; file-clock of the state is updated, except when under read-file-into-string -; (or any with-local-state actually). Now suppose we later attempt to open a -; (new) character input channel to "F" when the file-clock of the state is as -; before. Then we cause an error if the file-write-date is later than FWD. +; This alist associates each key, an ACL2 filename (see the Essay on +; Pathnames), with both a file-clock and its file-write-date. Recall that the +; keys into the readable-files component of the ACL2 state are of the form +; (list file-name typ file-clock); see open-input-channel. In order to +; preserve our logical story about file IO, we must avoid logically associating +; such a key with two different character lists. That could happen if +; read-file-into-string is called twice on the same filename, say "F", in the +; case that there is an intervening write not performed by ACL2. We avoid that +; problem by associating "F" with its current file-write-date, FWD, in the +; global *read-file-alist* just before opening a character input channel to +; "F". That global is cleared whenever the file-clock of the state is updated, +; except when under read-file-into-string (or any with-local-state actually). +; Now suppose we later attempt to open a (new) character input channel to "F" +; when the file-clock of the state is as before. Then we cause an error if the +; file-write-date is later than FWD. ; But consider the following situation: when we close an input channel on ; behalf of read-file-into-string, the file-write-date of "F" is not FWD. In @@ -16651,7 +16652,8 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step (defun check-against-read-file-alist (filename &optional (fwd (our-ignore-errors - (file-write-date filename)))) + (file-write-date$ filename + *the-live-state*)))) ; See *read-file-alist* for relevant background. @@ -18306,34 +18308,44 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step nil)))))) "")) +#-acl2-loop-only (defun pathname-os-to-unix (str os state) -; This function takes a pathname string in the host OS syntax and converts it -; to Unix syntax. +; Warning: Keep this in sync with the corresponding redefinition in file +; non-ascii-pathnames-raw.lsp, under books/kestrel/. + +; This function takes an OS pathname and converts it to an ACL2 pathname; see +; the Essay on Pathnames. - (declare (xargs :mode :program)) (if (equal str "") str - (case os - (:unix str) - (:mswindows - (let* ((sep #\\) - (str0 (substitute *directory-separator* sep str))) - (cond - ((and (eq os :mswindows) - (eql (char str0 0) *directory-separator*)) + (let ((result + (case os + (:unix str) + (:mswindows + (let* ((sep #\\) + (str0 (substitute *directory-separator* sep str))) + (cond + ((and (eq os :mswindows) + (eql (char str0 0) *directory-separator*)) ; Warning: Do not append the drive if there is already a drive present. We -; rely on this in LP, where we initialize state global 'system-books-dir -; using unix-full-pathname (which calls pathname-os-to-unix) based on -; environment variable ACL2_SYSTEM_BOOKS, which might already have a drive that -; differs from that of the user. +; rely on this in LP, where we initialize state global 'system-books-dir based +; on environment variable ACL2_SYSTEM_BOOKS, which might already have a drive +; that differs from that of the user. - (string-append (mswindows-drive nil state) - str0)) - (t - str0)))) - (otherwise (os-er os 'pathname-os-to-unix))))) + (string-append (mswindows-drive nil state) + str0)) + (t + str0)))) + (otherwise (os-er os 'pathname-os-to-unix))))) + (let ((msg (and result + *check-namestring* ; always true unless a ttag is used + (bad-lisp-stringp result)))) + (cond (msg (interface-er + "Illegal ACL2 pathname, ~x0:~%~@1" + result msg)) + (t result)))))) #+(and (not acl2-loop-only) ccl) (defun ccl-at-least-1-3-p () @@ -18343,14 +18355,17 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step (> (symbol-value 'ccl::*openmcl-minor-version*) 2) (> (symbol-value 'ccl::*openmcl-major-version*) 1)))) +#-acl2-loop-only (defun pathname-unix-to-os (str state) -; This function takes a Unix-style pathname string and converts it to a -; filename in the host OS. In the case of :mswindows, the "Unix-style" -; filename may or may not start with the drive, but the result definitely does. +; Warning: Keep this in sync with the corresponding redefinition in file +; non-ascii-pathnames-raw.lsp, under books/kestrel/. - (declare (xargs :mode :program)) - #+(and (not acl2-loop-only) ccl mswindows) +; This function takes an ACL2 pathname and converts it to an OS pathname; see +; the Essay on Pathnames. In the case of :mswindows, the ACL2 filename may or +; may not start with the drive, but the result definitely does. + + #+(and ccl mswindows) ; We believe that CCL 1.2 traffics in Unix-style pathnames, so it would be a ; mistake to convert them to use #\\, because then (for example) probe-file may @@ -18879,13 +18894,8 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step #-acl2-loop-only (when (live-state-p state) (return-from getenv$ - (let ((val (and (stringp str) (getenv$-raw str)))) - (value (and (not (bad-lisp-stringp val)) - -; It isn't clear that it is possible to get a bad string from getenv$-raw, but -; we check above and return nil if we happen to obtain such a string. - - val))))) + (value (and (stringp str) ; guard check, for robustness + (getenv$-raw str))))) (read-acl2-oracle state)) (defun setenv$ (str val) @@ -20357,14 +20367,6 @@ evaluated. See :DOC certify-book, in particular, the discussion about ``Step (list (cons #\0 (format nil "~s" x))))))) ) -#-acl2-loop-only -(defun chk-bad-lisp-stringp (namestring filename) - (let ((msg (bad-lisp-stringp namestring))) - (cond (msg (interface-er - "Illegal absolute pathname computed for ~x0:~%~@1" - filename msg)) - (t nil)))) - #-acl2-loop-only (defun-one-output chk-bad-lisp-object (x) @@ -25478,14 +25480,19 @@ Lisp definition." (read-acl2-oracle state)) (defun file-write-date$ (file state) + +; File is an ACL2 filename; see the Essay on Pathnames. + (declare (xargs :guard (stringp file) - :stobjs state)) - #+acl2-loop-only - (declare (ignore file)) + :stobjs state) + (ignorable file)) #+(not acl2-loop-only) (when (live-state-p state) - (return-from file-write-date$ - (mv (our-ignore-errors (file-write-date file)) state))) + (return-from + file-write-date$ + (mv (our-ignore-errors + (file-write-date (pathname-unix-to-os file state))) + state))) (mv-let (erp val state) (read-acl2-oracle state) (mv (and (null erp) @@ -25495,6 +25502,8 @@ Lisp definition." (defun delete-file$ (file state) +; File is an ACL2 pathname; see the Essay on Pathnames. + ; It may seem a bit surprising that this function does not update the ; file-clock of the state. To see why that isn't necessary, let us review the ; role of the file-clock (also see :DOC state). When open-input-channel opens @@ -25540,9 +25549,11 @@ Lisp definition." (declare (ignore file)) #-acl2-loop-only (when (live-state-p state) - (return-from delete-file$ - (mv (our-ignore-errors (delete-file file)) - state))) + (return-from + delete-file$ + (mv (our-ignore-errors + (delete-file (pathname-unix-to-os file state))) + state))) (mv-let (erp val state) (read-acl2-oracle state) (mv (and (null erp) diff --git a/basis-a.lisp b/basis-a.lisp index 7b1338c8c9a..dbdc32c2eb6 100644 --- a/basis-a.lisp +++ b/basis-a.lisp @@ -998,7 +998,7 @@ (cond ((eviscerate1p x alist evisc-table hiding-cars) (eviscerate1 x 0 -1 -1 alist evisc-table hiding-cars - + ; Since we are not eviscerating based on print-level or print-length, there is ; no involvement of iprinting, so we pass nil for the remaining arguments. @@ -6452,6 +6452,18 @@ ; implementation. That is important to avoid trivial soundness bugs based on ; variance of a defconst value from one underlying Lisp to another. +#-acl2-loop-only +(defun our-pwd () + +; Warning: Do not be tempted to use (getenv$-raw "PWD"). The PWD environment +; variable is not necessarily maintained, for example in Solaris/SunOS as one +; make invokes another make in a different directory. + + (pathname-os-to-unix + (our-truename "" "Note: Calling OUR-TRUENAME from OUR-PWD.") + (get-os) + *the-live-state*)) + #-acl2-loop-only (initialize-state-globals) diff --git a/books/kestrel/utilities/non-ascii-pathnames-raw.lsp b/books/kestrel/utilities/non-ascii-pathnames-raw.lsp new file mode 100644 index 00000000000..6f71d770a7b --- /dev/null +++ b/books/kestrel/utilities/non-ascii-pathnames-raw.lsp @@ -0,0 +1,255 @@ +; Copyright (C) 2016, Regents of the University of Texas +; Written by Matt Kaufmann +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +(in-package "ACL2") + +(or (eq (f-get-global 'host-lisp *the-live-state*) :ccl) + +; For now we implement this utility only for CCL. For SBCL +; it seems possible that acl2-string-to-filename, in place of the +; call of ccl::decode-string-from-octets, we could use: + +; (sb-ext::octets-to-string +; (coerce x '(vector (unsigned-byte 8))) +; :external-format :utf-8) + +; But there may be other issues for SBCL. For example, the following caused an +; error on a Mac: + +; touch $'\xe2\x82\xac' +; sbcl +; (directory "./*") + +; The error message said the following. + +; :ASCII c-string decoding error: the octet sequence #(226) cannot be decoded. + +; Presumably this is solvable, but let's put off solving this until it's +; needed. + + (error "Attempted to load non-ascii-pathnames-raw.lsp in other than CCL!")) + +(setq *check-namestring* + +; Set this back to t to recover original behavior. + + nil) + +(defun seven-bit-chars-stringp (s) + (loop for i from 0 to (1- (length s)) + do (when (> (char-code (char s i)) 127) + (return nil)) + finally (return t))) + +(defun acl2-string-to-filename (x &optional error-p) + + (assert (not (equal x ""))) + +; X is a string other than "", which is returned unchanged if it is a valid +; filename for the current filesystem. In particular, the return value is x if +; x has only characters with code at most 127. Otherwise, if the sequence of +; bytes (i.e., char-code values) in x encodes a filename string on the current +; platform, then that string is returned. If they don't, then nil is returned +; unless error-p is true, in which case an error is signalled. + +; Example: Suppose you create a file in bash as follows. + +; touch $'\xe2\x82\xac' + +; You might see the resulting filename as the euro sign if you list the current +; directory using "ls" on linux or a Mac. + +; We can form a Lisp string directly from those bytes as follows. + +; (coerce (list (code-char #xE2) (code-char #x82) (code-char #xAC)) 'string) + +; Regardless of the appearance of this string (perhaps as a euro sign), it is +; suitable input to the present function, whose output will be a filename for +; the given file, suitable for input to Common Lisp functions such as +; file-write-date. Here is an example to be evaluated after running the +; "touch" command above; we have checked that this CCL log looks the same in +; Linux as on the Mac. + +; ? (file-write-date +; (acl2-string-to-filename +; (coerce (list (code-char #xE2) (code-char #x82) (code-char #xAC)) 'string))) +; 3674228526 +; ? + +; If *check-namestring* is true (note that t is the default), or if every +; character code in x is at most 127, then we simply return x. The remaining +; comments below assume that *check-namestring* is nil. + + (when (or *check-namestring* + (seven-bit-chars-stringp x)) + (return-from acl2-string-to-filename x)) + + (let* ((octets ; X is an ACL2 string, so all its char-codes are under 256. + (loop for i from 0 to (1- (length x)) + collect (char-code (char x i)))) + (s0 (ignore-errors + (ccl::decode-string-from-octets + (coerce octets '(vector (unsigned-byte 8))) + :external-format (ccl::pathname-encoding-name)))) + (s (if (equal s0 "") nil s0))) + (or s + (and error-p + (error "For ~s, unable to decode octet sequence: ~s" + `(acl2-string-to-filename ,x) + octets))))) + +(defun filename-to-acl2-string (s &optional error-p) + +; This is an inverse of acl2-string-to-filename. Thus, the return value is an +; ACL2 string, but the string input s might have characters with codes +; exceeding 255. See the definition of acl2-string-to-filename for more +; comments. + + (when (or *check-namestring* + (seven-bit-chars-stringp s)) + (return-from filename-to-acl2-string s)) + +; Next, we check that for the presence of a character in s that has attributes, +; since that would make it impossible for acl2-string-to-filename to invert +; filename-to-acl2-string. We'll check that separately anyhow, but the +; following error gives more information. + + (loop for i from 0 to (1- (length s)) + when (let ((c (char s i))) + (not (eql c (code-char (char-code c))))) + do + (if error-p + (error "For ~s, encountered a character c with char-code ~s, ~ + namely c = ~s, such that (eql c (code-char (char-code ~ + c))) is false." + `(filename-to-acl2-string ,s) + (char-code c) + c) + (return-from filename-to-acl2-string nil))) + + (let* ((octets (ignore-errors (ccl::encode-string-to-octets + s + :external-format (ccl:pathname-encoding-name))))) + (cond + (octets + (let ((result (coerce (loop for i from 0 to (1- (length octets)) + collect (code-char (aref octets i))) + 'string))) + (cond + ((equal (acl2-string-to-filename result nil) s) + result) + (t (error "For ~s, unable to encode string to octets because the ~ + application of acl2-string-to-filename to the result does ~ + not produce the original string." + `(filename-to-acl2-string ,s)))))) + (t (and error-p + (error "For ~s, unable to encode string to octets: ~s" + `(filename-to-acl2-string ,s) + octets)))))) + +; A nice little test: +(assert + (let* ((acl2-string + (coerce (list (code-char #xE2) (code-char #x82) (code-char #xAC) ; euro + #\a #\b + (code-char #xE2) (code-char #x82) (code-char #xAC) ; euro + #\C) + 'string)) + (filename-string (acl2-string-to-filename acl2-string))) + (equal acl2-string (filename-to-acl2-string filename-string)))) + +#-acl2-loop-only +(defun pathname-unix-to-os (str state) + +; Here we modify the definition of the corresponding ACL2 source function by +; adding a call of acl2-string-to-filename. + +; This function takes an ACL2 pathname and converts it to an OS pathname; see +; the Essay on Pathnames. In the case of :mswindows, the ACL2 filename may or +; may not start with the drive, but the result definitely does. + + #+(and ccl mswindows) + +; We believe that CCL 1.2 traffics in Unix-style pathnames, so it would be a +; mistake to convert them to use #\\, because then (for example) probe-file may +; fail. However, we will allow Windows-style pathnames for CCL Versions 1.3 +; and beyond, based on the following quote from +; http://trac.clozure.com/ccl/wiki/WindowsNotes (4/30/09): + +; Windows pathnames can use either forward-slash or backward-slash characters +; as directory separators. As of the 1.3 release, CCL should handle +; namestrings which use either forward- or backward-slashes; some prereleases +; and release-candidates generally had difficulty with backslashes. + + (when (not (ccl-at-least-1-3-p)) + (return-from pathname-unix-to-os str)) + + (if (equal str "") + str + (let* ((os (os (w state))) + (str-orig str) + (str (acl2-string-to-filename str t))) + (case os + (:unix str) + (:mswindows + (let ((sep #\\)) + (if (position sep str) + (illegal 'pathname-unix-to-os + "Unable to convert pathname ~p0 for OS ~p1 because ~ + character ~p2 occurs in that pathname string at ~ + position ~p3." + (list (cons #\0 str-orig) + (cons #\1 os) + (cons #\2 sep) + (cons #\3 (position sep str)))) + (let* ((sep-is-first (eql (char str 0) *directory-separator*)) + (str0 (substitute sep *directory-separator* str))) + (if sep-is-first + (string-append (mswindows-drive nil state) + str0) + str0))))) + (otherwise (os-er os 'pathname-unix-to-os)))))) + +#-acl2-loop-only +(defun pathname-os-to-unix (str os state) + +; Warning: Keep this in sync with the corresponding redefinition in file +; non-ascii-pathnames-raw.lsp, under books/kestrel/. + +; This function takes an OS pathname and converts it to an ACL2 pathname; see +; the Essay on Pathnames. + + (if (equal str "") + str + (let ((result + (case os + (:unix str) + (:mswindows + (let* ((sep #\\) + (str0 (substitute *directory-separator* sep str))) + (cond + ((and (eq os :mswindows) + (eql (char str0 0) *directory-separator*)) + +; Warning: Do not append the drive if there is already a drive present. We +; rely on this in LP, where we initialize state global 'system-books-dir based +; on environment variable ACL2_SYSTEM_BOOKS, which might already have a drive +; that differs from that of the user. + + (string-append (mswindows-drive nil state) + str0)) + (t + str0)))) + (otherwise (os-er os 'pathname-os-to-unix))))) + (let ((msg (and result + *check-namestring* ; always true unless a ttag is used + (bad-lisp-stringp result)))) + (cond (msg (interface-er + "Illegal ACL2 pathname, ~x0:~%~@1" + result msg)) + (t (and result + (filename-to-acl2-string ; identity if *check-namestring* + result t)))))))) + + diff --git a/books/kestrel/utilities/non-ascii-pathnames.acl2 b/books/kestrel/utilities/non-ascii-pathnames.acl2 new file mode 100644 index 00000000000..b0aa56e760f --- /dev/null +++ b/books/kestrel/utilities/non-ascii-pathnames.acl2 @@ -0,0 +1 @@ +; cert-flags: ? t :ttags (:non-ascii-pathnames) diff --git a/books/kestrel/utilities/non-ascii-pathnames.lisp b/books/kestrel/utilities/non-ascii-pathnames.lisp new file mode 100644 index 00000000000..e6e5ceca903 --- /dev/null +++ b/books/kestrel/utilities/non-ascii-pathnames.lisp @@ -0,0 +1,72 @@ +; Copyright (C) 2016, Regents of the University of Texas +; Written by Matt Kaufmann +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +; NOTE: Although this book should certify regardless of the host Lisp, it only +; has the desired behavior in CCL. That could likely be extended as needed. + +; See non-ascii-pathnames-raw.lsp for comments that explain this utility. Once +; it's been used a bit, it would be good to document it with xdoc. For now, +; here is a brief explanation, followed by an example that illustrates what's +; going on. + +; ACL2 characters have char-codes not exceeding 255. However, filenames can +; have characters with larger char-codes. ACL2 "out of the box" cannot deal +; with such filenames, but this book provides such support. The key notions +; are those of "ACL2 pathname" and "OS pathname", as discussed in the Essay on +; Pathnames in ACL2 source file interface-raw.lisp. An OS pathname is a string +; that the underlying Lisp uses for a pathname. But ACL2's interface to the +; file system uses ACL2 pathnames, which are valid ACL2 strings. For ACL2 out +; of the box, the OS pathname and ACL2 pathname are the same when the OS +; pathname is a valid ACL2 pathname. After including this book, however, these +; are only guaranteed to be the same if moreover, all characters in the OS +; pathname are 7-bit characters. (As of this writing, it's not clear whether +; 8-bit characters would suffice; quite possibly that's the case, but we are +; being conservative.) Otherwise, the ACL2 pathname is a different string, +; which we think of -- and this might be true -- as the string of 8-bit +; characters whose char-codes are the bytes (in order) in the OS pathname. + +; In a nutshell: the way to deal with an OS pathname that is not a valid ACL2 +; string is to include this book, translate it to an ACL2 pathname (for +; example, in raw Lisp as shown below), and then use that ACL2 pathname within +; ACL2. + +#|| EXAMPLE: + +# It may be best to start in a fresh directory. +# It's OK to skip the bash command if you are already running bash. +bash +# Create a file whose name probably looks like a Euro sign. +touch $'\xe2\x82\xac' +# Start ACL2 here, based on CCL. Then: +(include-book "kestrel/utilities/non-ascii-pathnames" :dir :system) +(set-raw-mode-on!) +# Next we use a new utility, which converts OS pathnames to ACL2 pathnames, +# to store the ACL2 pathname of the new file into a global. +(assign my-file ; Make an ACL2 pathname from the OS pathname of the new file. + (filename-to-acl2-string (pathname-name (car (directory "./*"))))) +(assert (equal (length (@ my-file)) 3)) ; should return nil, not an error +(set-raw-mode nil) +(mv-let + (channel state) + (open-input-channel (@ my-file) :object state) + (cond + ((null channel) (value :failed)) + (t (pprogn (close-input-channel channel state) + (value :ok))))) +||# + +(in-package "ACL2") + +(include-book "tools/include-raw" :dir :system) + +(defttag :non-ascii-pathnames) + +; (depends-on "non-ascii-pathnames-raw.lsp") +(make-event + (er-progn (if (eq (@ host-lisp) :ccl) + (include-raw "non-ascii-pathnames-raw.lsp") + (value (cw "Skipping include-raw for non-ascii-pathnames-raw.lsp ~ + (supported in CCL only)."))) + (value '(value-triple nil))) + :check-expansion t) diff --git a/books/kestrel/utilities/top.lisp b/books/kestrel/utilities/top.lisp index c2ef3d361d8..855fd82f8a8 100644 --- a/books/kestrel/utilities/top.lisp +++ b/books/kestrel/utilities/top.lisp @@ -24,6 +24,8 @@ (include-book "fresh-names") (include-book "install-not-norm-event") (include-book "minimize-ruler-extenders") +; Skipping the following, because it requires a trust tag: +; (include-book "non-ascii-pathnames" :ttags (:non-ascii-pathnames)) (include-book "numbered-names") (include-book "prove-interface") (include-book "terms") diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index 589a5f38b95..5e5d27db25a 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -32222,12 +32222,14 @@ current fast alists." :short "Read an environment variable" :long "

      @('(Getenv$ str state)'), where @('str') is a string, reads the value of environment variable @('str'), returning a value of @('nil') if none - is found or if the read fails. The logical story is that @('getenv$') reads - its value from the @('oracle') field of the ACL2 @(tsee state). The return - value is thus a triple of the form @('(mv erp val state)'), where @('erp') - will always be @('nil') in practice, and logically, @('val') is the top of the - acl2-oracle field of the state (see @(tsee read-acl2-oracle)) and the returned - state has the updated (popped) acl2-oracle.

      + is found or if the read fails. (Exception: if the value is not a legal ACL2 + string, say because it contains a character with @(tsee char-code) exceeding + 255, then an error is signalled.) The logical story is that @('getenv$') + reads its value from the @('oracle') field of the ACL2 @(tsee state). The + return value is thus a triple of the form @('(mv erp val state)'), where + @('erp') will always be @('nil') in practice, and logically, @('val') is the + top of the acl2-oracle field of the state (see @(tsee read-acl2-oracle)) and + the returned state has the updated (popped) acl2-oracle.

      @({ Example: @@ -42686,8 +42688,8 @@ tables in the current Hons Space."

      Note that @('open-output-channel') and @('open-output-channel!') will attempt to create directories as needed (but this is not the case for - @('open-input-channel'). For example, the following can succeed in writing to - the indicated file by creating subdirectory @('\"dir4\"') if that directory + @('open-input-channel')). For example, the following can succeed in writing + to the indicated file by creating subdirectory @('\"dir4\"') if that directory does not already exist.

      @({ @@ -74037,6 +74039,13 @@ it." :use ((:instance char-code-linear (x *c*)))))) }) +

      The utility @(tsee getenv$) now causes an error if the value it would + otherwise return is not an ACL2 string, for example because it contains a + character whose @(tsee char-code) exceeds 255. Many other changes, less + visible to the user, have been made in how ACL2 deals with strings that come + from outside ACL2, in particular, file names (see the related item just + above).

      +

      The handling of @(see meta)functions allowed an invariant to be violated, that conjectures in the prover are always 100% @(see logic) mode. An example is in a comment in the ACL2 source code under @('(deflabel note-7-3 ...)'). @@ -97979,7 +97988,7 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") submit the command @('meta-x tags-apropos') and reply @('pwd') at the prompt, you'll find a raw Lisp function @('our-pwd') that ACL2 defines as an analogue to the Linux @('pwd') command; and, with @('meta-x tags-search') applied to - @('(pwd'), you can see how ACL2 source code uses this utility.

      + @('(our-pwd'), you can see how ACL2 source code uses this utility.

      List of a few ACL2 system utilities:

      diff --git a/interface-raw.lisp b/interface-raw.lisp index f439c252bef..2f4c1e3d66e 100644 --- a/interface-raw.lisp +++ b/interface-raw.lisp @@ -4822,16 +4822,17 @@ (assert load-compiled-file) (mv-let - (cfile state) + (acl2-cfile state) (certificate-file file state) - (let* ((os-file (pathname-unix-to-os file state)) + (let* ((cfile (pathname-unix-to-os acl2-cfile state)) + (os-file (pathname-unix-to-os file state)) (cfile-date (and cfile (file-write-date cfile))) (ofile (convert-book-name-to-compiled-name os-file state)) (ofile-exists (probe-file ofile)) (ofile-date (and ofile-exists (file-write-date ofile))) (ofile-p (and ofile-date cfile-date (>= ofile-date cfile-date))) (efile (and (not (eq load-compiled-file t)) - (expansion-filename file t state))) + (expansion-filename os-file))) (efile-exists (and efile (probe-file efile))) (file-is-older-str "the file-write-date of ~x0 is less than that of ~x1")) @@ -4858,9 +4859,9 @@ ctx file (msg "~x0 is ~x1 (which is odd since file ~x2 exists)" - `(file-write-date ,cfile) + `(file-write-date$ ,acl2-cfile state) nil - cfile) + acl2-cfile) load-compiled-file state)) ((not (or ofile-p @@ -4879,7 +4880,9 @@ ctx file (msg "the compiled file does not exist and ~@0" - (msg file-is-older-str efile cfile)) + (msg file-is-older-str + (expansion-filename file) + acl2-cfile)) load-compiled-file state)))) ((and (not ofile-p) ; hence efile is suitable to load, except: @@ -4906,14 +4909,16 @@ ; include-book-fn, either that compilation will succeed or there will be an ; error -- either way, there is no need to warn here. - (warning$ ctx "Compiled file" - "Loading expansion file ~x0 in place of compiled file ~ - ~x1, because ~@2." - efile ofile - (cond (ofile-exists - (msg file-is-older-str ofile cfile)) - (t - (msg "the compiled file is missing"))))) + (let ((acl2-ofile (convert-book-name-to-compiled-name file state))) + (warning$ ctx "Compiled file" + "Loading expansion file ~x0 in place of compiled file ~ + ~x1, because ~@2." + (expansion-filename file) + acl2-ofile + (cond (ofile-exists + (msg file-is-older-str acl2-ofile acl2-cfile)) + (t + (msg "the compiled file is missing")))))) (catch 'missing-compiled-book ; bogus compiler warning in LispWorks 6.0.1, gone in LispWorks 6.1 (state-global-let* @@ -5044,7 +5049,9 @@ (cond ((let ((true-full-book-name (our-truename full-book-name :safe))) (and true-full-book-name - (assoc-equal true-full-book-name + (assoc-equal (pathname-os-to-unix true-full-book-name + (os (w state)) + state) (global-val 'include-book-alist (w state))))) ; In ACL2 Version_4.1 running on Allegro CL, we got an error when attempting to @@ -5091,8 +5098,8 @@ (ofile-date (and ofile-exists (file-write-date ofile)))) (cond ((not os-file-exists) (er hard ctx - "File ~x0 does not exist." - os-file)) + "The file named ~x0 does not exist." + full-book-name)) ((null load-compiled-file) (assert$ raw-mode-p ; otherwise we already returned above @@ -5114,8 +5121,7 @@ "The compiled file for ~x0 was not loaded ~ because ~@1." reason)) - (t (let* ((efile (expansion-filename - full-book-name t state)) + (t (let* ((efile (expansion-filename os-file)) (efile-date (and (probe-file efile) (file-write-date efile))) (efile-p (and book-date @@ -6938,17 +6944,24 @@ ; (needed by pathname-os-to-unix). (cond (system-books-dir - (let ((dir (unix-full-pathname - (cond - ((symbolp system-books-dir) - (symbol-name system-books-dir)) - ((stringp system-books-dir) - system-books-dir) - (t (er hard 'initialize-acl2 - "Unable to complete initialization, because the ~ - supplied system books directory, ~x0, is not a ~ - string." - system-books-dir)))))) + (let* ((dir (unix-full-pathname + (cond + ((symbolp system-books-dir) + (symbol-name system-books-dir)) + ((stringp system-books-dir) + system-books-dir) + (t (er hard 'initialize-acl2 + "Unable to complete initialization, because ~ + the supplied system books directory, ~x0, is ~ + not a string." + system-books-dir))))) + (msg (bad-lisp-stringp dir))) + (when msg + (interface-er + "The value of the system-books-dir argument of ~ + ENTER-BOOT-STRAP-MODE, which is ~x0, is not a legal ACL2 ~ + string.~%~@1" + dir msg)) (f-put-global 'system-books-dir (canonical-dirname! (maybe-add-separator dir) 'enter-boot-strap-mode @@ -8132,18 +8145,21 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): ; We use Unix-style pathnames everywhere in ACL2 except when interfacing with ; the operating system. Functions defined in this file, interface-raw.lisp, -; generally use real pathname strings for the host operating system. -; (Exceptions are clearly labeled, including compile-uncompiled-defuns and -; compile-uncompiled-*1*-defuns.) Functions defined outside this file -; (interface-raw.lisp) pass around ACL2 (Unix-style) pathname strings. Here -; are some functions that take pathnames whose form is based on (os (w state)) -; rather than on Unix. +; generally use real pathname strings for the host operating system, which we +; call "OS filenames". (Exceptions are clearly labeled, including +; compile-uncompiled-defuns and compile-uncompiled-*1*-defuns.) Functions +; defined outside this file (interface-raw.lisp) pass around what we call "ACL2 +; filenames", which are Unix-style pathname strings that consist solely of +; legal ACL2 characters, as checked by bad-lisp-stringp. + +; Here are some examples of functions that take OS pathnames. ; acl2-compile-file [but see comment there] ; compile-file -; convert-book-name-to-compiled-name [Unix pathname is OK too] +; convert-book-name-to-compiled-name [ACL2 pathname is OK too] ; delete-file ; delete-compiled-file +; expansion-filename [ACL2 pathname is OK too] ; load ; probe-file ; proclaim-file @@ -8247,7 +8263,11 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): (setq ccl::*break-hook* 'our-abort)) (defun initial-customization-filename () - (let* ((cfb00 (getenv$-raw "ACL2_CUSTOMIZATION")) + +; Every value returned by this function is either :none, nil, or a legal ACL2 +; string. + + (let* ((cfb00 (getenv$-raw "ACL2_CUSTOMIZATION")) ; nil or legal ACL2 string (cfb0 (if (equal cfb00 "NONE") :none (and cfb00 @@ -8475,19 +8495,24 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): (or (null s) ; default case (not (equal (string-upcase s) "NIL"))))) - (user-home-dir-path (our-user-homedir-pathname)) - (user-home-dir0 (and user-home-dir-path - (our-truename user-home-dir-path - "Note: Calling OUR-TRUENAME ~ + (os-user-home-dir-path (our-user-homedir-pathname)) + (os-user-home-dir0 (and os-user-home-dir-path + (our-truename os-user-home-dir-path + "Note: Calling OUR-TRUENAME ~ from LP."))) - (user-home-dir (and user-home-dir0 - (if (eql (char user-home-dir0 - (1- (length user-home-dir0))) - *directory-separator*) - (subseq user-home-dir0 - 0 - (1- (length user-home-dir0))) - user-home-dir0))) + (os-user-home-dir (and os-user-home-dir0 + (if (eql (char os-user-home-dir0 + (1- (length os-user-home-dir0))) + *directory-separator*) + (subseq os-user-home-dir0 + 0 + (1- (length os-user-home-dir0))) + os-user-home-dir0))) + (user-home-dir (and os-user-home-dir + (pathname-os-to-unix + os-user-home-dir + (os (w *the-live-state*)) + *the-live-state*))) (system-dir0 (let ((str (getenv$-raw "ACL2_SYSTEM_BOOKS"))) (and str (maybe-add-separator str))))) @@ -8498,17 +8523,18 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): (when user-home-dir (f-put-global 'user-home-dir user-home-dir *the-live-state*)) (when system-dir0 ; needs to wait for user-homedir-pathname - (f-put-global 'system-books-dir - (canonical-dirname! - (unix-full-pathname - (expand-tilde-to-user-home-dir - system-dir0 - (os (w *the-live-state*)) - 'lp - *the-live-state*)) - 'lp - *the-live-state*) - *the-live-state*))) + (f-put-global + 'system-books-dir + (canonical-dirname! + (unix-full-pathname + (expand-tilde-to-user-home-dir + system-dir0 ; from getenv$-raw, hence a legal ACL2 string + (os (w *the-live-state*)) + 'lp + *the-live-state*)) + 'lp + *the-live-state*) + *the-live-state*))) (set-gag-mode-fn :goals *the-live-state*) #-hons ; Hons users are presumably advanced enough to tolerate the lack of a @@ -8671,10 +8697,9 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): (defun acl2-compile-file (full-book-name os-expansion-filename) -; Full-book-name is a Unix-style pathname. Os-expansion-filename is a pathname -; for the current operating system of the file we want to compile. We compile -; os-expansion-filename but into the compiled filename corresponding to -; full-book-name. +; Full-book-name is an ACL2 pathname, while os-expansion-filename is an OS +; pathname; see the Essay on Pathnames. We compile os-expansion-filename but +; into the compiled filename corresponding to full-book-name. ; To compile os-expansion-filename, we need to make sure that uses in the file ; of backquote and comma conform in meaning to those that were in effect during @@ -8746,7 +8771,7 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): (defun-one-output delete-auxiliary-book-files (full-book-name) (let* ((file (pathname-unix-to-os full-book-name *the-live-state*)) (ofile (convert-book-name-to-compiled-name file *the-live-state*)) - (efile (expansion-filename file nil *the-live-state*)) + (efile (expansion-filename file)) (err-string "A file created for book ~x0, namely ~x1, exists and ~ cannot be deleted with Common Lisp's delete-file. We ~ do not know for sure whether this file was produced by ~ @@ -8776,12 +8801,18 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): err-string full-book-name efile)))))) -(defun delete-expansion-file (expansion-filename state) - (delete-file expansion-filename) +(defun delete-expansion-file (os-expansion-filename full-book-name state) + +; Os-expansion-filename is, as the name suggests, an OS filename; see the Essay +; on Pathnames. Since that pathname could contain characters that are not ACL2 +; characters, we print the message using the ACL2 string for the corresponding +; book, full-book-name. + + (delete-file os-expansion-filename) (io? event nil state - (expansion-filename) - (fms "Note: Deleting book expansion file,~%~s0.~|" - (list (cons #\0 expansion-filename)) + (full-book-name) + (fms "Note: Deleting expansion file for the book,~%~s0.~|" + (list (cons #\0 full-book-name)) (proofs-co state) state nil))) (defun compile-uncompiled-defuns (file &optional (fns :some) gcl-flg @@ -9208,11 +9239,13 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): (value nil)))) os-file)) -(defun compile-certified-file (expansion-filename full-book-name state) +(defun compile-certified-file (os-expansion-filename full-book-name state) -; Warning: File full-book-name should already have been included in order that -; macros have been defined. But more than that, expansion-filename must -; already have been written. +; Warning: full-book-name should be the full book name of a book that has +; already have been included, so that its macro definitions have been evaluated +; before we compile. Moreover, os-expansion-filename must already have been +; written. As the names suggest, os-expansion-filename is an OS pathname and +; full-book-name is an ACL2 pathname; see the Essay on Pathnames. (let* ((os-full-book-name (pathname-unix-to-os full-book-name state)) (os-full-book-name-compiled @@ -9222,7 +9255,7 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): (stack-access-defeat-hook-cert-ht))) (when (probe-file os-full-book-name-compiled) (delete-file os-full-book-name-compiled)) - (acl2-compile-file full-book-name expansion-filename) + (acl2-compile-file full-book-name os-expansion-filename) os-full-book-name-compiled)) (defun compile-for-include-book (full-book-name certified-p ctx state) @@ -9241,7 +9274,8 @@ Missing functions (use *check-built-in-constants-debug* = t for verbose report): full-book-name) (value nil))) (t - (let* ((efile (expansion-filename full-book-name t state)) + (let* ((efile (pathname-unix-to-os (expansion-filename full-book-name) + state)) (entry (and *hcomp-book-ht* (gethash full-book-name *hcomp-book-ht*))) (status (and entry diff --git a/other-events.lisp b/other-events.lisp index bfb9e19e8b0..4b8a549acb4 100644 --- a/other-events.lisp +++ b/other-events.lisp @@ -8935,6 +8935,9 @@ (defun canonical-unix-pathname (x dir-p state) +; This function returns either nil or a Unix filename, which is a valid ACL2 +; string. + ; Warning: Although it may be tempting to use pathname-device in this code, be ; careful if you do! Camm Maguire sent an example in which GCL on Windows ; returned ("Z:") as the value of (pathname-device (truename "")), and it @@ -8952,34 +8955,44 @@ ; that is not a directory, or if the "true" name cannot be determined, in which ; case return nil. - (let ((truename (our-truename x))) - (and truename - (let ((dir (pathname-directory truename)) - (name (pathname-name truename)) - (type (pathname-type truename))) - (and (implies dir-p - (not (or (stringp name) (stringp type)))) - (assert$ (and (true-listp dir) - (eq (car dir) - #+gcl :ROOT - #-gcl :ABSOLUTE)) - (let* ((mswindows-drive - (mswindows-drive (namestring truename) state)) - (tmp (if mswindows-drive - (concatenate 'string mswindows-drive "/") - "/"))) - (dolist (x dir) - (when (stringp x) - (setq tmp (concatenate 'string tmp x "/")))) - (when (stringp name) - (setq tmp (concatenate 'string tmp name))) - (when (stringp type) - (setq tmp (concatenate 'string tmp "." type))) - (let ((namestring-tmp (namestring (truename tmp))) - (namestring-truename (namestring truename))) - (cond ((equal namestring-truename namestring-tmp) - tmp) - ((and mswindows-drive + (let* ((truename (our-truename x)) + (result + (and truename + (let ((dir (pathname-directory truename)) + (name (pathname-name truename)) + (type (pathname-type truename))) + (and (implies dir-p + (not (or (stringp name) (stringp type)))) + (assert$ (and (true-listp dir) + (eq (car dir) + #+gcl :ROOT + #-gcl :ABSOLUTE)) + (let* ((mswindows-drive + (mswindows-drive (namestring truename) + state)) + (tmp (if mswindows-drive + (concatenate 'string + mswindows-drive + "/") + "/"))) + (dolist (x dir) + (when (stringp x) + (setq tmp + (concatenate 'string tmp x "/")))) + (when (stringp name) + (setq tmp (concatenate 'string tmp name))) + (when (stringp type) + (setq tmp + (concatenate 'string tmp "." type))) + (let ((namestring-tmp + (namestring (truename tmp))) + (namestring-truename + (namestring truename))) + (cond + ((equal namestring-truename + namestring-tmp) + tmp) + ((and mswindows-drive ; In Windows, it appears that the value returned by truename can start with ; (for example) "C:/" or "c:/" depending on whether "c" is capitalized in the @@ -8990,34 +9003,36 @@ ; whose pathnames are generally (as far as we know) considered to be ; case-insensitive. - (string-equal namestring-truename - namestring-tmp)) - tmp) - (t (case *canonical-unix-pathname-action* - (:warning - (let ((state *the-live-state*)) - (warning$ 'canonical-unix-pathname - "Pathname" - "Unable to compute ~ + (string-equal namestring-truename + namestring-tmp)) + tmp) + (t (case *canonical-unix-pathname-action* + (:warning + (let ((state *the-live-state*)) + (warning$ 'canonical-unix-pathname + "Pathname" + "Unable to compute ~ canonical-unix-pathname ~ for ~x0. (Debug info: ~ truename is ~x1 while ~ (truename tmp) is ~x2.)" - x - namestring-truename - namestring-tmp))) - (:error - (er hard 'canonical-unix-pathname - "Unable to compute ~ + x + namestring-truename + namestring-tmp))) + (:error + (er hard 'canonical-unix-pathname + "Unable to compute ~ canonical-unix-pathname for ~ ~x0. (Debug info: truename is ~ ~x1 while (truename tmp) is ~ ~x2.)" - x - namestring-truename - namestring-tmp))) - (and (not dir-p) ; indeterminate if dir-p - x))))))))))) + x + namestring-truename + namestring-tmp))) + (and (not dir-p) ; indeterminate if dir-p + x))))))))))) + (and result + (pathname-os-to-unix result (os (w state)) state)))) (defun unix-truename-pathname (x dir-p state) @@ -13980,18 +13995,21 @@ ; Note that guard-checking-on is bound to nil in pc-single-step-primitive. We ; no longer recall why, but we may as well preserve that binding. -(defun expansion-filename (full-book-name convert-to-os-p state) +(defun expansion-filename (file) ; We use a .lsp suffix instead of .lisp for benefit of the makefile system, ; which by default looks for .lisp files to certify. -; Full-book-name is expected to be a Unix-style filename. We return an OS -; filename. +; File can be either an ACL2 filename or an OS filename (see the Essay on +; Pathnames). We add the ".lisp" suffix either way. This could be problematic +; in the case that one adds the suffix to an ACL2 filename with this function, +; and then converts the result to an OS filename -- is that really the same as +; converting the ACL2 filename to an OS filename and then adding the suffix? +; We believe that yes, these are the same, since the conversion of a filename +; is presumably a matter of converting the individual bytes or characters, in +; order. - (let* ((file (if convert-to-os-p - (pathname-unix-to-os full-book-name state) - full-book-name)) - (len (length file))) + (let ((len (length file))) (assert$ (equal (subseq file (- len 5) len) ".lisp") (concatenate 'string (subseq file 0 (- len 5)) @@ -15093,9 +15111,7 @@ (compiled-file (convert-book-name-to-compiled-name full-book-name state)) (expansion-file - (expansion-filename full-book-name - nil ; don't convert to OS, since we didn't above - state))) + (expansion-filename full-book-name))) (er-let* ((post-alist (certificate-post-alist pcert1-file cert-file full-book-name ctx state)) @@ -16438,7 +16454,7 @@ cert-op ctx state)) - (compiled-file + (os-compiled-file (cond (compile-flg ; We only use the value of compile-flg when #-acl2-loop-only. @@ -16451,7 +16467,7 @@ declaim-list new-fns (expansion-filename - full-book-name nil state) + full-book-name) expansion-alist pkg-names ev-lst @@ -16459,10 +16475,11 @@ ctx state) #-acl2-loop-only (let* ((os-expansion-filename - (expansion-filename - full-book-name - t state)) - (compiled-file + (pathname-unix-to-os + (expansion-filename + full-book-name) + state)) + (os-compiled-file (compile-certified-file os-expansion-filename full-book-name @@ -16471,8 +16488,10 @@ 'save-expansion-file state)) (delete-expansion-file - os-expansion-filename state)) - (value compiled-file))))) + os-expansion-filename + full-book-name + state)) + (value os-compiled-file))))) (t #-acl2-loop-only (delete-auxiliary-book-files @@ -16496,9 +16515,9 @@ state))) (when (and - compiled-file + os-compiled-file -; Ensure that compiled-file is more recent than .cert file, since rename-file +; Ensure that os-compiled-file is more recent than .cert file, since rename-file ; is not guaranteed to preserve the write-date. We first check the ; file-write-date of the .cert file, since we have found that to be almost 3 ; orders of magnitude faster than touch? in CCL. @@ -16508,15 +16527,14 @@ with compile-date = (file-write-date - compiled-file) + os-compiled-file) thereis (< compile-date - (file-write-date - (pathname-unix-to-os - (cdr pair) - state))))) + (file-write-date$ + (cdr pair) + state)))) (touch? - compiled-file + os-compiled-file nil ctx state)) (value nil)) (pprogn @@ -28918,6 +28936,8 @@ (defun read-file-into-string2 (filename state) +; Filename is an ACL2 pathname; see the Essay on Pathnames. + ; Parallelism wart: avoid potential illegal behavior caused by this function. ; A simple but expensive solution is probably to add a lock. But with some ; thought one might provide for correct parallel evaluations of this function. @@ -28925,17 +28945,16 @@ (declare (xargs :stobjs state :guard (stringp filename))) #-acl2-loop-only - (declare (ignore state)) - #-acl2-loop-only - (with-open-file - (stream filename :direction :input :if-does-not-exist nil) - (and stream - (let ((len (file-length stream))) - (and (< len *read-file-into-string-bound*) - (let ((fwd (file-write-date filename))) - (or (check-against-read-file-alist filename fwd) - (push (cons filename fwd) - *read-file-alist*)) + (let ((os-filename (pathname-unix-to-os filename state))) + (with-open-file + (stream os-filename :direction :input :if-does-not-exist nil) + (and stream + (let ((len (file-length stream))) + (and (< len *read-file-into-string-bound*) + (let ((fwd (file-write-date os-filename))) + (or (check-against-read-file-alist filename fwd) + (push (cons filename fwd) + *read-file-alist*)) ; The following #-acl2-loop-only code, minus the WHEN clause, is based on code ; found at http://www.ymeme.com/slurping-a-file-common-lisp-83.html and was @@ -28945,15 +28964,15 @@ ; The URL above says ``You can do anything you like with the code.'' - (let ((seq (make-string len))) - (declare (type string seq)) - (read-sequence seq stream) - (when (not (eql fwd (file-write-date filename))) - (error "Illegal attempt to call ~s concurrently with ~ - some write to that file!~%See :DOC ~ - read-file-into-string." - 'read-file-into-string)) - seq)))))) + (let ((seq (make-string len))) + (declare (type string seq)) + (read-sequence seq stream) + (when (not (eql fwd (file-write-date os-filename))) + (error "Illegal attempt to call ~s concurrently with ~ + some write to that file!~%See :DOC ~ + read-file-into-string." + 'read-file-into-string)) + seq))))))) #+acl2-loop-only (let* ((st (coerce-state-to-object state))) (mv-let From 5bf2afd5c1baa852018754a68b2dd21ef9f81532 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Fri, 29 Jul 2016 15:56:08 -0700 Subject: [PATCH 48/70] Fix references to kestrel/system. This is now kestrel/utilities. --- books/system/doc/acl2-doc.lisp | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index 5e5d27db25a..18bf3041b1f 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -161,7 +161,7 @@ (STR::PRETTY-PRINTING "[books]/std/strings/pretty.lisp") (QUICKLISP "[books]/centaur/quicklisp/top.lisp") (REMOVABLE-RUNES "[books]/tools/removable-runes.lisp") - (RULER-EXTENDERS "[books]/kestrel/system/world-queries.lisp") + (RULER-EXTENDERS "[books]/kestrel/utilities/world-queries.lisp") (SATLINK::SAT-SOLVER-OPTIONS "[books]/centaur/satlink/top.lisp") (SATLINK "[books]/centaur/satlink/top.lisp") (XDOC::SAVE "[books]/xdoc/topics.lisp") @@ -49193,14 +49193,14 @@ it." (defxdoc measure ; This topic is appropriately redefined by (define measure ...) in -; books/kestrel/system/world-queries.lisp: +; books/kestrel/utilities/world-queries.lisp: :parents (xargs) :short "Declare a measure for a @(tsee defun)" :long "

      See @(see xargs) for discussion of how to use the @(':measure') keyword to specify a measure for a definition. A related utility, @('measure'), may be found in the @(see community-books), file - @('kestrel/system/world-queries.lisp').

      ") + @('kestrel/utilities/world-queries.lisp').

      ") (defxdoc measure-debug :parents (measure debugging) @@ -73477,7 +73477,7 @@ it." ; Renamed :doc topic well-founded-relation to well-founded-relation-rule, to ; accommodate the form (define well-founded-relation ...) in -; books/kestrel/system/world-queries.lisp. +; books/kestrel/utilities/world-queries.lisp. ; We added to :doc redundant-encapsulate to add discussion of redefinition. ; Also, we tweaked a redundancy message for encapsulate so that it says "might @@ -87882,7 +87882,7 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ")

      To see the ruler-extenders of an existing function symbol, @('fn'), in a logical @(see world), @('wrld'), evaluate @('(ruler-extenders 'fn wrld)') - after @('(include-book \"kestrel/system/world-queries\" :dir :system)'). For + after @('(include-book \"kestrel/utilities/world-queries\" :dir :system)'). For example, evaluation of @('(ruler-extenders 'fn (w state))') provides the ruler-extenders of @('fn') in the current logical world.

      @@ -109042,14 +109042,14 @@ introduction-to-the-tau-system) for more information about Tau. (defxdoc well-founded-relation ; This topic is appropriately redefined by (define well-founded-relation ...) -; in books/kestrel/system/world-queries.lisp. +; in books/kestrel/utilities/world-queries.lisp. :parents (rule-classes) :short "Show that a relation is well-founded on a set" :long "

      See @(see well-founded-relation-rule) for discussion of well-founded relations in ACL2. A related utility, @('well-founded-relation'), may be found in the @(see community-books), file - @('kestrel/system/world-queries.lisp').

      ") + @('kestrel/utilities/world-queries.lisp').

      ") (defxdoc well-founded-relation-rule :parents (rule-classes) From 9e5de11e6b999dc8f601bd5bb264f8c9772cc549 Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Fri, 29 Jul 2016 19:13:10 -0500 Subject: [PATCH 49/70] Fixed package of "strengthen" function for (defun-sk name ...) to be in the same package as name. Quoting :doc note-7-3: When [defun-sk] was supplied with keyword argument :strengthen t, the name of the generated theorem was always in the "ACL2" package. Now it is in the same package as the function symbol being defined. Thanks to Alessandro Coglio for suggesting this change. --- books/system/doc/acl2-doc.lisp | 11 +++++-- doc.lisp | 53 ++++++++++++++++++++++------------ other-events.lisp | 2 +- 3 files changed, 45 insertions(+), 21 deletions(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index 18bf3041b1f..decca9e0a1e 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -21487,8 +21487,10 @@ subtree of X with T, without duplication.

      should only be executed in @(see defun-mode) @(':')@(tsee logic); see @(see defun-mode) and see @(see defchoose). Advanced feature: If argument @(':strengthen t') is passed to @('defun-sk'), then @(':strengthen t') will - generate the extra constraint that that is generated for the corresponding - @('defchoose') event; see @(see defchoose). You can use the command + generate the extra constraint that is generated for the corresponding + @('defchoose') event; see @(see defchoose). (The name of that generated + theorem will be obtained by adding the suffix @('\"-STRENGTHEN\"') to the + function symbol being defined, in the same package). You can use the command @(':')@(tsee pcb!) to see the event generated by a call of the @('defun-sk') macro.

      @@ -73864,6 +73866,11 @@ it." @('(defxdoc note-7-3 ...)') in community book @('books/system/doc/acl2-doc.lisp').

      +

      When @(tsee defun-sk) was supplied with keyword argument @(':strengthen + t'), the name of the generated theorem was always in the @('\"ACL2\"') + package. Now it is in the same package as the function symbol being defined. + Thanks to Alessandro Coglio for suggesting this change.

      +

      New Features

      New optional arguments allow the @(tsee pso) utility to restrict output to diff --git a/doc.lisp b/doc.lisp index 90ae710d28b..22ca9728fe1 100644 --- a/doc.lisp +++ b/doc.lisp @@ -12701,7 +12701,7 @@ Subtopics (str::pretty-printing \"[books]/std/strings/pretty.lisp\") (quicklisp \"[books]/centaur/quicklisp/top.lisp\") (removable-runes \"[books]/tools/removable-runes.lisp\") - (ruler-extenders \"[books]/kestrel/system/world-queries.lisp\") + (ruler-extenders \"[books]/kestrel/utilities/world-queries.lisp\") (satlink::sat-solver-options \"[books]/centaur/satlink/top.lisp\") (satlink \"[books]/centaur/satlink/top.lisp\") (xdoc::save \"[books]/xdoc/topics.lisp\") @@ -24255,9 +24255,11 @@ Subtopics only be executed in [defun-mode] :[logic]; see [defun-mode] and see [defchoose]. Advanced feature: If argument :strengthen t is passed to defun-sk, then :strengthen t will generate the extra constraint - that that is generated for the corresponding defchoose event; see - [defchoose]. You can use the command :[pcb!] to see the event - generated by a call of the defun-sk macro. + that is generated for the corresponding defchoose event; see + [defchoose]. (The name of that generated theorem will be obtained + by adding the suffix \"-STRENGTHEN\" to the function symbol being + defined, in the same package). You can use the command :[pcb!] to + see the event generated by a call of the defun-sk macro. If you find that the rewrite rules introduced with a particular use of defun-sk are not ideal, even when using the :rewrite keyword @@ -30534,8 +30536,8 @@ Subtopics (defun file-write-date$ (file state) (declare (xargs :guard (stringp file) - :stobjs state)) - (declare (ignore file)) + :stobjs state) + (ignorable file)) (mv-let (erp val state) (read-acl2-oracle state) (mv (and (null erp) (posp val) val) @@ -35130,12 +35132,15 @@ Subtopics (Getenv$ str state), where str is a string, reads the value of environment variable str, returning a value of nil if none is found - or if the read fails. The logical story is that getenv$ reads its - value from the oracle field of the ACL2 [state]. The return value - is thus a triple of the form (mv erp val state), where erp will - always be nil in practice, and logically, val is the top of the - acl2-oracle field of the state (see [read-ACL2-oracle]) and the - returned state has the updated (popped) acl2-oracle. + or if the read fails. (Exception: if the value is not a legal ACL2 + string, say because it contains a character with [char-code] + exceeding 255, then an error is signalled.) The logical story is + that getenv$ reads its value from the oracle field of the ACL2 + [state]. The return value is thus a triple of the form (mv erp val + state), where erp will always be nil in practice, and logically, + val is the top of the acl2-oracle field of the state (see + [read-ACL2-oracle]) and the returned state has the updated (popped) + acl2-oracle. Example: (getenv$ \"PWD\" state) ==> (mv nil \"/u/joe/work\" state) @@ -45953,7 +45958,7 @@ Subtopics Note that open-output-channel and open-output-channel! will attempt to create directories as needed (but this is not the case for - open-input-channel. For example, the following can succeed in + open-input-channel). For example, the following can succeed in writing to the indicated file by creating subdirectory \"dir4\" if that directory does not already exist. @@ -52864,7 +52869,7 @@ Subtopics See [xargs] for discussion of how to use the :measure keyword to specify a measure for a definition. A related utility, measure, may be found in the [community-books], file - kestrel/system/world-queries.lisp. + kestrel/utilities/world-queries.lisp. Subtopics @@ -72598,6 +72603,11 @@ Changes to Existing Features ``hard-bounds and rollovers'' in (defxdoc note-7-3 ...) in community book books/system/doc/acl2-doc.lisp. + When [defun-sk] was supplied with keyword argument :strengthen t, the + name of the generated theorem was always in the \"ACL2\" package. Now + it is in the same package as the function symbol being defined. + Thanks to Alessandro Coglio for suggesting this change. + New Features @@ -72772,6 +72782,13 @@ Bug Fixes :in-theory (theory 'minimal-theory) :use ((:instance char-code-linear (x *c*)))))) + The utility [getenv$] now causes an error if the value it would + otherwise return is not an ACL2 string, for example because it + contains a character whose [char-code] exceeds 255. Many other + changes, less visible to the user, have been made in how ACL2 deals + with strings that come from outside ACL2, in particular, file names + (see the related item just above). + The handling of [meta]functions allowed an invariant to be violated, that conjectures in the prover are always 100% [logic] mode. An example is in a comment in the ACL2 source code under (deflabel @@ -89020,7 +89037,7 @@ Subtopics To see the ruler-extenders of an existing function symbol, fn, in a logical [world], wrld, evaluate (ruler-extenders 'fn wrld) after - (include-book \"kestrel/system/world-queries\" :dir :system). For + (include-book \"kestrel/utilities/world-queries\" :dir :system). For example, evaluation of (ruler-extenders 'fn (w state)) provides the ruler-extenders of fn in the current logical world. @@ -99056,7 +99073,7 @@ Subtopics example, if in Emacs you submit the command meta-x tags-apropos and reply pwd at the prompt, you'll find a raw Lisp function our-pwd that ACL2 defines as an analogue to the Linux pwd command; and, - with meta-x tags-search applied to (pwd, you can see how ACL2 + with meta-x tags-search applied to (our-pwd, you can see how ACL2 source code uses this utility. @@ -99084,7 +99101,7 @@ List of a few ACL2 system utilities: [world] w, return the number of its formal parameters. * (body fn normalp w): For a function symbol or lambda expression fn of [world] w, return its body ([normalize]d iff normalp is true). - NOTE: If normalp is true, then fn should be a :tsee logic-mode + NOTE: If normalp is true, then fn should be a :[logic]-mode function symbol of w. * (conjoin lst): The conjunction of the given list of terms. * (conjoin2 term1 term2): The conjunction of the given two terms. @@ -109812,7 +109829,7 @@ Subtopics See [well-founded-relation-rule] for discussion of well-founded relations in ACL2. A related utility, well-founded-relation, may be found in the [community-books], file - kestrel/system/world-queries.lisp.") + kestrel/utilities/world-queries.lisp.") (WELL-FOUNDED-RELATION-RULE (RULE-CLASSES) "Show that a relation is well-founded on a set diff --git a/other-events.lisp b/other-events.lisp index 4b8a549acb4..ab073c7543f 100644 --- a/other-events.lisp +++ b/other-events.lisp @@ -17069,7 +17069,7 @@ ,@(and strengthen '(:strengthen t)))) ,@(and strengthen - `((defthm ,(packn (list skolem-name '-strengthen)) + `((defthm ,(add-suffix skolem-name "-STRENGTHEN") ,(defchoose-constraint-extra skolem-name bound-vars args defchoose-body) :hints (("Goal" From bdfd5534d4b8bf337f409a2fb8df846060353563 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Fri, 29 Jul 2016 20:26:38 -0700 Subject: [PATCH 50/70] Adapt DEFUN-SK query utilities to change to DEFUN-SK. Now that DEFUN-SK uses ADD-SUFFIX instead of PACKN to construct the name of the strengthening theorem of DEFUN-SK, the code of the DEFUN-SK query utilities has been changed to do that too. --- books/kestrel/utilities/defun-sk-queries.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/books/kestrel/utilities/defun-sk-queries.lisp b/books/kestrel/utilities/defun-sk-queries.lisp index 4af7b874e55..537ed7adb2e 100644 --- a/books/kestrel/utilities/defun-sk-queries.lisp +++ b/books/kestrel/utilities/defun-sk-queries.lisp @@ -273,7 +273,7 @@

      " (equal strengthen-defthm - `(defthm ,(packn (list witness '-strengthen)) + `(defthm ,(add-suffix witness "-STRENGTHEN") ,(defchoose-constraint-extra witness bound-vars args witness-body) :hints (("Goal" :use ,witness From 033c27df5dda424769f33a859b68739cdd3fbf09 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sat, 30 Jul 2016 16:31:25 -0700 Subject: [PATCH 51/70] Add some miscellaneous theorems. --- .../kestrel/utilities/theorems/list-sets.lisp | 57 +++++++++++++++++++ books/kestrel/utilities/theorems/top.lisp | 24 ++++++++ .../utilities/theorems/true-list-listp.lisp | 35 ++++++++++++ books/kestrel/utilities/top.lisp | 1 + 4 files changed, 117 insertions(+) create mode 100644 books/kestrel/utilities/theorems/list-sets.lisp create mode 100644 books/kestrel/utilities/theorems/top.lisp create mode 100644 books/kestrel/utilities/theorems/true-list-listp.lisp diff --git a/books/kestrel/utilities/theorems/list-sets.lisp b/books/kestrel/utilities/theorems/list-sets.lisp new file mode 100644 index 00000000000..53a799cf19e --- /dev/null +++ b/books/kestrel/utilities/theorems/list-sets.lisp @@ -0,0 +1,57 @@ +; Theorems about Sets Represented as Lists +; +; Copyright (C) 2016 Kestrel Institute (http://www.kestrel.edu) +; +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. +; +; Author: Alessandro Coglio (coglio@kestrel.edu) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; This file provides some theorems about sets represented as lists. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(include-book "std/util/defrule" :dir :system) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defsection theorems-about-sets-represented-as-lists + + :parents (miscellaneous-theorems) + + :short "Some theorems about sets represented as lists." + + (defrule true-listp-of-add-to-set-equal + :parents (add-to-set) + (equal (true-listp (add-to-set-equal a x)) + (true-listp x))) + + (defrule true-listp-of-add-to-set-equal-type + :parents (add-to-set) + (implies (true-listp x) + (true-listp (add-to-set-equal a x))) + :rule-classes :type-prescription) + + (defrule true-listp-of-union-equal + :parents (union$) + (equal (true-listp (union-equal x y)) + (true-listp y))) + + (defrule true-listp-of-union-equal-type + :parents (union$) + (implies (true-listp y) + (true-listp (union-equal x y))) + :rule-classes :type-prescription) + + (defrule true-listp-of-intersection-equal + :parents (intersection$) + (true-listp (intersection-equal x y)) + :rule-classes (:rewrite :type-prescription)) + + (defrule true-listp-of-set-difference-equal + :parents (set-difference$) + (true-listp (set-difference-equal x y)) + :rule-classes (:rewrite :type-prescription))) diff --git a/books/kestrel/utilities/theorems/top.lisp b/books/kestrel/utilities/theorems/top.lisp new file mode 100644 index 00000000000..b4143ca4572 --- /dev/null +++ b/books/kestrel/utilities/theorems/top.lisp @@ -0,0 +1,24 @@ +; Miscellaneous Theorems +; +; Copyright (C) 2016 Kestrel Institute (http://www.kestrel.edu) +; +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. +; +; Author: Alessandro Coglio (coglio@kestrel.edu) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; This file provides some miscellaneous theorems. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(include-book "list-sets") +(include-book "true-list-listp") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defxdoc miscellaneous-theorems + :parents (kestrel-utilities) + :short "Some miscellaneous theorems.") diff --git a/books/kestrel/utilities/theorems/true-list-listp.lisp b/books/kestrel/utilities/theorems/true-list-listp.lisp new file mode 100644 index 00000000000..38036a6c127 --- /dev/null +++ b/books/kestrel/utilities/theorems/true-list-listp.lisp @@ -0,0 +1,35 @@ +; Theorems about NIL-Terminated Lists of NIL-Terminated Lists +; +; Copyright (C) 2016 Kestrel Institute (http://www.kestrel.edu) +; +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. +; +; Author: Alessandro Coglio (coglio@kestrel.edu) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; This file provides some theorems about +; NIL-terminated lists of NIL-terminated lists. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(include-book "std/lists/top" :dir :system) +(include-book "std/util/deflist" :dir :system) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defsection theorems-about-true-list-listp + + :parents (miscellaneous-theorems true-list-listp) + + :short + "Some theorems about @('nil')-terminated lists of @('nil')-terminated lists." + + (std::deflist true-list-listp (x) + (true-listp x) + :true-listp t + :elementp-of-nil t + :already-definedp t + :parents nil)) diff --git a/books/kestrel/utilities/top.lisp b/books/kestrel/utilities/top.lisp index 855fd82f8a8..c747c3f0a61 100644 --- a/books/kestrel/utilities/top.lisp +++ b/books/kestrel/utilities/top.lisp @@ -30,6 +30,7 @@ (include-book "prove-interface") (include-book "terms") (include-book "testing") +(include-book "theorems/top") (include-book "types") (include-book "ubi") (include-book "user-interface") From f1915ea0ec0b56bb4dafbbc1bd7d38a6fd06cfa9 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sat, 30 Jul 2016 17:49:26 -0700 Subject: [PATCH 52/70] Remove the TERM-LOGICP term utility. This turns out to be the same as the built-in LOGIC-FNSP. --- books/kestrel/utilities/terms-tests.lisp | 8 ------- books/kestrel/utilities/terms.lisp | 27 +----------------------- 2 files changed, 1 insertion(+), 34 deletions(-) diff --git a/books/kestrel/utilities/terms-tests.lisp b/books/kestrel/utilities/terms-tests.lisp index f105565d375..e09a34f94e8 100644 --- a/books/kestrel/utilities/terms-tests.lisp +++ b/books/kestrel/utilities/terms-tests.lisp @@ -85,14 +85,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (term-logicp '(len (cons x x)) (w state))) - -(must-succeed* - (defun f (x) (declare (xargs :mode :program)) x) - (assert-event (not (term-logicp '(cons (f x) '3) (w state))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (assert-event (lambda-expr-logicp '(lambda (x y) (len (cons x x))) (w state))) (must-succeed* diff --git a/books/kestrel/utilities/terms.lisp b/books/kestrel/utilities/terms.lisp index af8051a4c38..e96b5cbece0 100644 --- a/books/kestrel/utilities/terms.lisp +++ b/books/kestrel/utilities/terms.lisp @@ -113,38 +113,13 @@ (cons (apply-term* fn (car terms)) (apply-unary-to-terms fn (cdr terms))))) -(defines term/terms-logicp - :short "True iff term/terms is/are in logic mode." - - (define term-logicp ((term pseudo-termp) (wrld plist-worldp)) - :returns (yes/no booleanp) - :parents (term/terms-logicp) - :short - "True iff the term is in logic mode, - i.e. all its functions are in logic mode." - (or (variablep term) - (fquotep term) - (and (terms-logicp (fargs term) wrld) - (let ((fn (ffn-symb term))) - (if (symbolp fn) - (logicp fn wrld) - (term-logicp (lambda-body fn) wrld)))))) - - (define terms-logicp ((terms pseudo-term-listp) (wrld plist-worldp)) - :returns (yes/no booleanp) - :parents (term/terms-logicp) - :short "True iff all the terms are in logic mode." - (or (endp terms) - (and (term-logicp (car terms) wrld) - (terms-logicp (cdr terms) wrld))))) - (define lambda-expr-logicp ((lambd pseudo-lambda-expr-p) (wrld plist-worldp)) :returns (yes/no booleanp) :guard-hints (("Goal" :in-theory (enable pseudo-lambda-expr-p))) :short "True iff the lambda expression is in logic mode, i.e. its body is in logic mode." - (term-logicp (lambda-body lambd) wrld)) + (logic-fnsp (lambda-body lambd) wrld)) (defines term/terms-no-stobjs-p :prepwork ((program)) From c69b2e3b614b72abfe5c4bb979c73207fd5d56a3 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Sat, 30 Jul 2016 19:34:40 -0700 Subject: [PATCH 53/70] Rename some term utilities. Use shorter names (e.g. use LAMBDA instead of LAMBDA-EXPR inside some function names) and use a few names that are more consistent with existing system utilities. --- books/kestrel/utilities/terms-tests.lisp | 83 ++++++++++++------------ books/kestrel/utilities/terms.lisp | 50 +++++++------- 2 files changed, 66 insertions(+), 67 deletions(-) diff --git a/books/kestrel/utilities/terms-tests.lisp b/books/kestrel/utilities/terms-tests.lisp index e09a34f94e8..083d2563975 100644 --- a/books/kestrel/utilities/terms-tests.lisp +++ b/books/kestrel/utilities/terms-tests.lisp @@ -19,38 +19,38 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (not (pseudo-lambda-expr-p "abc"))) +(assert-event (not (pseudo-lambdap "abc"))) -(assert-event (not (pseudo-lambda-expr-p (cons 3 6)))) +(assert-event (not (pseudo-lambdap (cons 3 6)))) -(assert-event (not (pseudo-lambda-expr-p '(lambda (x) x extra)))) +(assert-event (not (pseudo-lambdap '(lambda (x) x extra)))) -(assert-event (not (pseudo-lambda-expr-p '(lambd (x) x)))) +(assert-event (not (pseudo-lambdap '(lambd (x) x)))) -(assert-event (not (pseudo-lambda-expr-p '(lambda (x 8) x)))) +(assert-event (not (pseudo-lambdap '(lambda (x 8) x)))) -(assert-event (not (pseudo-lambda-expr-p '(lambda (x y) #\a)))) +(assert-event (not (pseudo-lambdap '(lambda (x y) #\a)))) -(assert-event (pseudo-lambda-expr-p '(lambda (x) x))) +(assert-event (pseudo-lambdap '(lambda (x) x))) -(assert-event (pseudo-lambda-expr-p '(lambda (x y z) (+ x (* y z))))) +(assert-event (pseudo-lambdap '(lambda (x y z) (+ x (* y z))))) -(assert-event (pseudo-lambda-expr-p '(lambda (x y z) (+ x x)))) +(assert-event (pseudo-lambdap '(lambda (x y z) (+ x x)))) -(assert-event (pseudo-lambda-expr-p '(lambda (x y z) (+ a b)))) +(assert-event (pseudo-lambdap '(lambda (x y z) (+ a b)))) (must-succeed* (defconst *term* '((lambda (x) (1+ x)) y)) (assert-event (pseudo-termp *term*)) - (assert-event (pseudo-lambda-expr-p (ffn-symb *term*)))) + (assert-event (pseudo-lambdap (ffn-symb *term*)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (lambda-expr-closedp '(lambda (x) (* '2 x)))) +(assert-event (lambda-closedp '(lambda (x) (* '2 x)))) -(assert-event (lambda-expr-closedp '(lambda (x y) (- y x)))) +(assert-event (lambda-closedp '(lambda (x y) (- y x)))) -(assert-event (not (lambda-expr-closedp '(lambda (x) (cons x a))))) +(assert-event (not (lambda-closedp '(lambda (x) (cons x a))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -85,12 +85,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (lambda-expr-logicp '(lambda (x y) (len (cons x x))) (w state))) +(assert-event (lambda-logic-fnsp '(lambda (x y) (len (cons x x))) (w state))) (must-succeed* (defun f (x) (declare (xargs :mode :program)) x) (assert-event - (not (lambda-expr-logicp '(lambda (z) (cons (f x) '3)) (w state))))) + (not (lambda-logic-fnsp '(lambda (z) (cons (f x) '3)) (w state))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -103,31 +103,30 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (assert-event - (lambda-expr-no-stobjs-p '(lambda (x y) (binary-+ x (cons y '#\a))) (w state))) + (lambda-no-stobjs-p '(lambda (x y) (binary-+ x (cons y '#\a))) (w state))) (must-succeed* (defun f (state) (declare (xargs :stobjs state)) state) (assert-event - (not (lambda-expr-no-stobjs-p '(lambda (state) (list (f state))) (w state))))) + (not (lambda-no-stobjs-p '(lambda (state) (list (f state))) (w state))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (terms-fns-guard-verified-p '(cons (len a) '3) (w state))) +(assert-event (guard-verified-fnsp '(cons (len a) '3) (w state))) (must-succeed* (defun f (x) (declare (xargs :verify-guards nil)) x) - (assert-event (not (terms-fns-guard-verified-p '(zp (f '4)) (w state))))) + (assert-event (not (guard-verified-fns-listp '(zp (f '4)) (w state))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (assert-event - (lambda-expr-fns-guard-verified-p '(lambda (a) (cons (len a) '3)) (w state))) + (lambda-guard-verified-fnsp '(lambda (a) (cons (len a) '3)) (w state))) (must-succeed* (defun f (x) (declare (xargs :verify-guards nil)) x) (assert-event - (not (lambda-expr-fns-guard-verified-p '(lambda (x) (zp (f '4))) - (w state))))) + (not (lambda-guard-verified-fnsp '(lambda (x) (zp (f '4))) (w state))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -178,80 +177,80 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda "(lambda (x) x)" (w state)))))) -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda '(lambda (x) x . more) (w state)))))) -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda '(lambda (x) x y) (w state)))))) -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda '(lambda (x)) (w state)))))) -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda '(lambdaa (x) x) (w state)))))) -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda '(lambda "x" x) (w state)))))) -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda '(lambda (x x) x) (w state)))))) -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda '(lambda (x "y") x) (w state)))))) (assert-event - (equal (mv-list 2 (check-user-lambda-expr '(lambda (x) 3) (w state))) + (equal (mv-list 2 (check-user-lambda '(lambda (x) 3) (w state))) '((lambda (x) '3) (nil)))) (assert-event - (equal (mv-list 2 (check-user-lambda-expr '(lambda (x) x) (w state))) + (equal (mv-list 2 (check-user-lambda '(lambda (x) x) (w state))) '((lambda (x) x) (nil)))) (assert-event - (equal (mv-list 2 (check-user-lambda-expr '(lambda (y) (len x)) (w state))) + (equal (mv-list 2 (check-user-lambda '(lambda (y) (len x)) (w state))) '((lambda (y) (len x)) (nil)))) (assert-event - (equal (mv-list 2 (check-user-lambda-expr + (equal (mv-list 2 (check-user-lambda '(lambda (x y) (mv x y z)) (w state))) '((lambda (x y) (cons x (cons y (cons z 'nil)))) (nil nil nil)))) (assert-event - (equal (mv-list 2 (check-user-lambda-expr '(lambda (state) state) (w state))) + (equal (mv-list 2 (check-user-lambda '(lambda (state) state) (w state))) '((lambda (state) state) (state)))) (assert-event - (equal (mv-list 2 (check-user-lambda-expr + (equal (mv-list 2 (check-user-lambda '(lambda (state) (mv state 1)) (w state))) '((lambda (state) (cons state (cons '1 'nil))) (state nil)))) (must-succeed* (defstobj s) - (assert-event (equal (mv-list 2 (check-user-lambda-expr + (assert-event (equal (mv-list 2 (check-user-lambda '(lambda (state s) (mv s 0 state)) (w state))) '((lambda (state s) (cons s (cons '0 (cons state 'nil)))) (s nil state))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (mv-list 2 (check-user-lambda-expr + (value (equal (mv-list 2 (check-user-lambda '(lambda (x y) (+ x y)) (w state))) '((lambda (x y) (binary-+ x y)) (nil))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (mv-list 2 (check-user-lambda-expr + (value (equal (mv-list 2 (check-user-lambda '(lambda (z) (+ (len x) 55)) (w state))) '((lambda (z) (binary-+ (len x) '55)) (nil))))) (must-eval-to-t ; ASSERT-EVENT does not work here - (value (equal (mv-list 2 (check-user-lambda-expr + (value (equal (mv-list 2 (check-user-lambda '(lambda (u) (let ((x 4)) (+ x (len y)))) (w state))) '((lambda (u) ((lambda (x y) (binary-+ x (len y))) '4 y)) (nil))))) -(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda-expr +(assert-event (msgp (nth 0 (mv-list 2 (check-user-lambda '(lambda (x) (f x)) (w state)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/terms.lisp b/books/kestrel/utilities/terms.lisp index e96b5cbece0..9c5668db6b1 100644 --- a/books/kestrel/utilities/terms.lisp +++ b/books/kestrel/utilities/terms.lisp @@ -26,7 +26,7 @@ :parents (kestrel-utilities system-utilities) :short "Utilities related to @(see term)s.") -(define pseudo-lambda-expr-p (x) +(define pseudo-lambdap (x) :returns (yes/no booleanp) :short "True iff @('x') satisfies the conditions of lambda expressions @@ -45,7 +45,7 @@ (symbol-listp (second x)) (pseudo-termp (third x)))) -(define lambda-expr-closedp ((lambd pseudo-lambda-expr-p)) +(define lambda-closedp ((lambd pseudo-lambdap)) :returns (yes/no booleanp) :verify-guards nil :short @@ -61,13 +61,13 @@ :long "

      Check whether @('x') is a symbol or a - pseudo-lambda-expression. + pseudo-lambda-expression. These are the possible values of the first element of a pseudo-term that is not a variable or a quoted constant (i.e. a pseudo-term that is a function application).

      " (or (symbolp x) - (pseudo-lambda-expr-p x))) + (pseudo-lambdap x))) (define apply-term ((fn pseudo-functionp) (terms pseudo-term-listp)) :guard (or (symbolp fn) @@ -75,7 +75,7 @@ (len (lambda-formals fn)))) ;; :returns (term pseudo-termp) :guard-hints (("Goal" :in-theory (enable pseudo-functionp - pseudo-lambda-expr-p))) + pseudo-lambdap))) :short "Apply pseudo-function to list of pseudo-terms, @@ -113,9 +113,9 @@ (cons (apply-term* fn (car terms)) (apply-unary-to-terms fn (cdr terms))))) -(define lambda-expr-logicp ((lambd pseudo-lambda-expr-p) (wrld plist-worldp)) +(define lambda-logic-fnsp ((lambd pseudo-lambdap) (wrld plist-worldp)) :returns (yes/no booleanp) - :guard-hints (("Goal" :in-theory (enable pseudo-lambda-expr-p))) + :guard-hints (("Goal" :in-theory (enable pseudo-lambdap))) :short "True iff the lambda expression is in logic mode, i.e. its body is in logic mode." @@ -156,8 +156,8 @@ (and (term-no-stobjs-p (car terms) wrld) (terms-no-stobjs-p (cdr terms) wrld))))) -(define lambda-expr-no-stobjs-p - ((lambd pseudo-lambda-expr-p) (wrld plist-worldp)) +(define lambda-no-stobjs-p + ((lambd pseudo-lambdap) (wrld plist-worldp)) :returns (yes/no booleanp) :prepwork ((program)) :short @@ -165,13 +165,13 @@ i.e. its body has no stobjs." (term-no-stobjs-p (lambda-body lambd) wrld)) -(defines term/terms-fns-guard-verified-p +(defines term/terms-guard-verified-fns :short "True iff term/terms is/are guard-verified." :verify-guards nil - (define term-fns-guard-verified-p ((term pseudo-termp) (wrld plist-worldp)) + (define guard-verified-fnsp ((term pseudo-termp) (wrld plist-worldp)) :returns (yes/no booleanp) - :parents (term/terms-fns-guard-verified-p) + :parents (term/terms-guard-verified-fns) :short "True iff all the functions in the term are guard-verified." :long "

      @@ -183,28 +183,28 @@

      " (or (variablep term) (fquotep term) - (and (terms-fns-guard-verified-p (fargs term) wrld) + (and (guard-verified-fns-listp (fargs term) wrld) (let ((fn (ffn-symb term))) (if (symbolp fn) (guard-verified-p fn wrld) - (term-fns-guard-verified-p (lambda-body fn) wrld)))))) + (guard-verified-fnsp (lambda-body fn) wrld)))))) - (define terms-fns-guard-verified-p ((terms pseudo-term-listp) - (wrld plist-worldp)) + (define guard-verified-fns-listp ((terms pseudo-term-listp) + (wrld plist-worldp)) :returns (yes/no booleanp) - :parents (term/terms-fns-guard-verified-p) + :parents (term/terms-guard-verified-fns) :short "True iff all the functions in the terms are guard-verified." (or (endp terms) - (and (term-fns-guard-verified-p (car terms) wrld) - (terms-fns-guard-verified-p (cdr terms) wrld))))) + (and (guard-verified-fnsp (car terms) wrld) + (guard-verified-fns-listp (cdr terms) wrld))))) -(define lambda-expr-fns-guard-verified-p ((lambd pseudo-lambda-expr-p) - (wrld plist-worldp)) +(define lambda-guard-verified-fnsp ((lambd pseudo-lambdap) + (wrld plist-worldp)) :returns (yes/no booleanp) :verify-guards nil :short "True iff all the functions in the lambda expression is guard-verified." - (term-fns-guard-verified-p (lambda-body lambd) wrld)) + (guard-verified-fnsp (lambda-body lambd) wrld)) (define lambda-expr-p (x (wrld plist-worldp)) :returns (yes/no booleanp) @@ -294,8 +294,8 @@ (cdr (assoc :stobjs-out bindings))) (mv term/message nil)))) -(define check-user-lambda-expr (x (wrld plist-worldp)) - :returns (mv (lambd/message (or (pseudo-lambda-expr-p lambd/message) +(define check-user-lambda (x (wrld plist-worldp)) + :returns (mv (lambd/message (or (pseudo-lambdap lambd/message) (msgp lambd/message))) (stobjs-out symbol-listp)) :prepwork ((program)) @@ -322,7 +322,7 @@ along with @('nil') as output stobjs.

      - The @(tsee check-user-lambda-expr) function does not terminate + The @(tsee check-user-lambda) function does not terminate if @(tsee check-user-term) does not terminate.

      " (b* (((unless (true-listp x)) From 68ca8c22f6a4be811dbae22acb728b3b8b0dbd74 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Sun, 31 Jul 2016 03:45:18 -0700 Subject: [PATCH 54/70] Strengthen and verify to guards of term utilities. --- books/kestrel/utilities/terms.lisp | 83 ++++++++++++++++++++++++------ 1 file changed, 66 insertions(+), 17 deletions(-) diff --git a/books/kestrel/utilities/terms.lisp b/books/kestrel/utilities/terms.lisp index 9c5668db6b1..a80980e643a 100644 --- a/books/kestrel/utilities/terms.lisp +++ b/books/kestrel/utilities/terms.lisp @@ -45,9 +45,43 @@ (symbol-listp (second x)) (pseudo-termp (third x)))) +(make-flag all-vars1) + +(defthm-flag-all-vars1 + (defthm true-listp-of-all-vars1 + (equal (true-listp (all-vars1 term ans)) + (true-listp ans)) + :flag all-vars1) + (defthm true-listp-of-all-vars1-lst + (equal (true-listp (all-vars1-lst lst ans)) + (true-listp ans)) + :flag all-vars1-lst)) + +(defrule true-listp-of-all-vars1-type + (implies (true-listp ans) + (true-listp (all-vars1 term ans))) + :rule-classes :type-prescription) + +(defrule true-listp-of-all-vars1-lst-type + (implies (true-listp ans) + (true-listp (all-vars1-lst term ans))) + :rule-classes :type-prescription) + +(defthm-flag-all-vars1 + (defthm symbol-listp-of-all-vars1 + (implies (pseudo-termp term) + (equal (symbol-listp (all-vars1 term ans)) + (symbol-listp ans))) + :flag all-vars1) + (defthm symbol-listp-of-all-vars1-lst + (implies (pseudo-term-listp lst) + (equal (symbol-listp (all-vars1-lst lst ans)) + (symbol-listp ans))) + :flag all-vars1-lst)) + (define lambda-closedp ((lambd pseudo-lambdap)) :returns (yes/no booleanp) - :verify-guards nil + :guard-hints (("Goal" :in-theory (enable pseudo-lambdap))) :short "True iff the lambda expression is closed, i.e. it has no free variables." (subsetp-eq (all-vars (lambda-body lambd)) @@ -102,9 +136,13 @@ (defmacro apply-term* (fn &rest terms) `(apply-term ,fn (list ,@terms)))) -(define apply-unary-to-terms ((fn pseudo-functionp) (terms pseudo-term-listp)) +(define apply-unary-to-terms ((fn (and (pseudo-functionp fn) + (if (consp fn) + (eql 1 (len (cadr fn))) + t))) + (terms pseudo-term-listp)) + :guard-hints (("Goal" :in-theory (enable PSEUDO-FUNCTIONP pseudo-lambdap))) ;; :returns (applied-terms pseudo-term-listp) - :verify-guards nil :short "Apply @('fn'), as a unary function, to each of @('terms'), obtaining a list of corresponding terms." @@ -165,11 +203,23 @@ i.e. its body has no stobjs." (term-no-stobjs-p (lambda-body lambd) wrld)) +(defrule arity-when-not-function-namep + (implies (and (not (function-namep fn wrld)) + (symbolp fn)) + (not (arity fn wrld))) + :hints (("Goal" :in-theory (e/d (arity function-namep) (fgetprop)))) + :rule-classes ((:rewrite :backchain-limit-lst (0 nil)))) + +(defrule plist-worldp-when-plist-worldp-with-formals-cheap + (implies (plist-worldp-with-formals wrld) + (plist-worldp wrld)) + :rule-classes ((:rewrite :backchain-limit-lst (0)))) + (defines term/terms-guard-verified-fns :short "True iff term/terms is/are guard-verified." - :verify-guards nil - (define guard-verified-fnsp ((term pseudo-termp) (wrld plist-worldp)) + (define guard-verified-fnsp ((term (termp term wrld)) + (wrld plist-worldp-with-formals)) :returns (yes/no booleanp) :parents (term/terms-guard-verified-fns) :short "True iff all the functions in the term are guard-verified." @@ -189,8 +239,8 @@ (guard-verified-p fn wrld) (guard-verified-fnsp (lambda-body fn) wrld)))))) - (define guard-verified-fns-listp ((terms pseudo-term-listp) - (wrld plist-worldp)) + (define guard-verified-fns-listp ((terms (term-listp terms wrld)) + (wrld plist-worldp-with-formals)) :returns (yes/no booleanp) :parents (term/terms-guard-verified-fns) :short "True iff all the functions in the terms are guard-verified." @@ -198,17 +248,8 @@ (and (guard-verified-fnsp (car terms) wrld) (guard-verified-fns-listp (cdr terms) wrld))))) -(define lambda-guard-verified-fnsp ((lambd pseudo-lambdap) - (wrld plist-worldp)) - :returns (yes/no booleanp) - :verify-guards nil - :short - "True iff all the functions in the lambda expression is guard-verified." - (guard-verified-fnsp (lambda-body lambd) wrld)) - -(define lambda-expr-p (x (wrld plist-worldp)) +(define lambda-expr-p (x (wrld plist-worldp-with-formals)) :returns (yes/no booleanp) - :verify-guards nil :short "True iff @('x') is a valid translated lambda expression." :long @@ -227,6 +268,14 @@ (subsetp-eq (all-vars (third x)) (second x)))) +(define lambda-guard-verified-fnsp ((lambd (lambda-expr-p lambd wrld)) + (wrld plist-worldp-with-formals)) + :returns (yes/no booleanp) + :guard-hints (("Goal" :in-theory (enable LAMBDA-EXPR-P))) + :short + "True iff all the functions in the lambda expression is guard-verified." + (guard-verified-fnsp (lambda-body lambd) wrld)) + (define check-user-term (x (wrld plist-worldp)) :returns (mv (term/message (or (pseudo-termp term/message) (msgp term/message))) From ba15a3ff99f97aea1bc2600a04375bf95560758e Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Mon, 1 Aug 2016 16:02:21 -0700 Subject: [PATCH 55/70] Improve world query utility. Now the guard of DEFINEDP includes the fact that the function must be in logic mode. This avoids the potentially confusing situation with built-in program-mode functions, which do not have an UNNORMALIZED-BODY property and on which, therefore, DEFINEDP returns NIL. --- .../utilities/world-queries-tests.lisp | 4 ---- books/kestrel/utilities/world-queries.lisp | 21 +++++++------------ 2 files changed, 8 insertions(+), 17 deletions(-) diff --git a/books/kestrel/utilities/world-queries-tests.lisp b/books/kestrel/utilities/world-queries-tests.lisp index 2a40c4cfc97..6fca33e5e93 100644 --- a/books/kestrel/utilities/world-queries-tests.lisp +++ b/books/kestrel/utilities/world-queries-tests.lisp @@ -166,10 +166,6 @@ :witness-dcls ((declare (xargs :non-executable nil)))) (assert-event (eq (non-executablep 'h (w state)) nil))) -(must-succeed* - (defproxy p (* *) => *) - (assert-event (eq (non-executablep 'p (w state)) :program))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (must-succeed* diff --git a/books/kestrel/utilities/world-queries.lisp b/books/kestrel/utilities/world-queries.lisp index 10339af6111..4b47f736d79 100644 --- a/books/kestrel/utilities/world-queries.lisp +++ b/books/kestrel/utilities/world-queries.lisp @@ -77,21 +77,14 @@ (t (and (logical-namep (car names) wrld) (logical-name-listp (cdr names) wrld))))) -(define definedp ((fn (function-namep fn wrld)) (wrld plist-worldp)) +(define definedp ((fn (and (function-namep fn wrld) + (logicp fn wrld))) + (wrld plist-worldp)) :returns (yes/no booleanp) :guard-hints (("Goal" :in-theory (enable function-namep))) :short - "True iff the function @('fn') is defined, + "True iff the logic-mode function @('fn') is defined, i.e. it has an @('unnormalized-body') property." - :long - "

      - Note that built-in @(see program)-mode functions - do not have an @('unnormalized-body') property, - even though they have definitions. - Since their translated bodies are not stored, - they are not considered to be “defined” - from the perspective of the @(tsee definedp) system utility. -

      " (not (eq t (getpropc fn 'unnormalized-body t wrld)))) (define guard-verified-p ((fn/thm (or (function-namep fn/thm wrld) @@ -104,11 +97,13 @@ (eq (symbol-class fn/thm wrld) :common-lisp-compliant)) (define non-executablep ((fn (and (function-namep fn wrld) + (logicp fn wrld) (definedp fn wrld))) (wrld plist-worldp)) - ;; :returns (result (member result '(t nil :program))) + ;; :returns (result (member result '(t nil))) :guard-hints (("Goal" :in-theory (enable function-namep))) - :short "The @(tsee non-executable) status of the defined function @('fn')." + :short + "The @(tsee non-executable) status of the logic-mode, defined function @('fn')." (getpropc fn 'non-executablep nil wrld)) (define unwrapped-nonexec-body ((fn (and (function-namep fn wrld) From 49bc801f5cc85a0be04d6a0be8b917ec22354905 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Mon, 1 Aug 2016 16:10:05 -0700 Subject: [PATCH 56/70] Slightly improve documentation of world query utility. --- books/kestrel/utilities/world-queries.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/books/kestrel/utilities/world-queries.lisp b/books/kestrel/utilities/world-queries.lisp index 4b47f736d79..9c5de4dc06e 100644 --- a/books/kestrel/utilities/world-queries.lisp +++ b/books/kestrel/utilities/world-queries.lisp @@ -100,7 +100,7 @@ (logicp fn wrld) (definedp fn wrld))) (wrld plist-worldp)) - ;; :returns (result (member result '(t nil))) + ;; :returns (yes/no booleanp) :guard-hints (("Goal" :in-theory (enable function-namep))) :short "The @(tsee non-executable) status of the logic-mode, defined function @('fn')." From 9d7d4c7935a2441b732bd4f6b0b11656c6ed4f41 Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Mon, 1 Aug 2016 20:40:11 -0500 Subject: [PATCH 57/70] Misc. minor mods. Tweaked :doc for splitter and (in :doc hints) :expand, based on emails with Yan Peng. Tweaked an error message from verify-guards as per a suggestion from Eric Smith. --- books/system/doc/acl2-doc.lisp | 65 +++++++++++++++++----------------- defuns.lisp | 4 +-- 2 files changed, 34 insertions(+), 35 deletions(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index decca9e0a1e..53ea1f50b6a 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -36133,32 +36133,32 @@ current fast alists." Such a term is said to be ``expandable:'' it can be replaced by the result of substituting the @('ti')'s for the @('vi')'s in @('b'). The terms listed in the @(':expand') hint are expanded when they are encountered by the simplifier - while working on the specified goal or any of its subgoals. We permit - @('value') to be a single such term instead of a singleton list. - Remarks: (1) Allowed are ``terms'' of the form @('(:free (var1 var2 ... - varn) pattern)') where the indicated variables are distinct and @('pattern') - is a term. Such ``terms'' indicate that we consider the indicated variables - to be instantiatable, in the following sense: whenever the simplifier - encounters a term that can be obtained from @('pattern') by instantiating the - variables @('(var1 var2 ... varn)'), then it expands that term. (2) Also - allowed are ``terms'' of the form @('(:with name term)'), where @('name') is a - function symbol, a macro name that denotes a function symbol (see @(see - macro-aliases-table)), or a @(see rune). The corresponding rule of class - @(':rewrite'), which is often a @(see definition) rule but need not be, is - then used in place of the current body for the function symbol of @('term'); - see @(see show-bodies) and see @(see set-body). If the rule is of the form - @('(implies hyp (equiv lhs rhs))'), then after matching @('lhs') to the - current term in a context that is maintaining equivalence relation @('equiv'), - ACL2 will replace the current term with @('(if hyp rhs (hide term))'), or just - @('rhs') if the rule is just @('(equal lhs rhs)'). (3) A combination of both - @(':free') and @(':with'), as described above, is legal. (4) The term - @(':LAMBDAS') is treated specially. It denotes the list of all lambda - applications (i.e., @(tsee let) expressions) encountered during the proof. - Conceptually, this use of @(':LAMBDAS') tells ACL2 to treat lambda - applications as a notation for substitutions, rather than as function calls - whose opening is subject to the ACL2 rewriter's heuristics (specifically, not - allowing lambda applications to open when they introduce ``too many'' if - terms).

      + while working on the specified goal or any of its subgoals. (There is no + separate ``expand'' process.) We permit @('value') to be a single such term + instead of a singleton list. Remarks: (1) Allowed are ``terms'' of the + form @('(:free (var1 var2 ... varn) pattern)') where the indicated variables + are distinct and @('pattern') is a term. Such ``terms'' indicate that we + consider the indicated variables to be instantiatable, in the following sense: + whenever the simplifier encounters a term that can be obtained from + @('pattern') by instantiating the variables @('(var1 var2 ... varn)'), then + it expands that term. (2) Also allowed are ``terms'' of the form @('(:with + name term)'), where @('name') is a function symbol, a macro name that denotes + a function symbol (see @(see macro-aliases-table)), or a @(see rune). The + corresponding rule of class @(':rewrite'), which is often a @(see definition) + rule but need not be, is then used in place of the current body for the + function symbol of @('term'); see @(see show-bodies) and see @(see set-body). + If the rule is of the form @('(implies hyp (equiv lhs rhs))'), then after + matching @('lhs') to the current term in a context that is maintaining + equivalence relation @('equiv'), ACL2 will replace the current term with + @('(if hyp rhs (hide term))'), or just @('rhs') if the rule is just @('(equal + lhs rhs)'). (3) A combination of both @(':free') and @(':with'), as described + above, is legal. (4) The term @(':LAMBDAS') is treated specially. It denotes + the list of all lambda applications (i.e., @(tsee let) expressions) + encountered during the proof. Conceptually, this use of @(':LAMBDAS') tells + ACL2 to treat lambda applications as a notation for substitutions, rather than + as function calls whose opening is subject to the ACL2 rewriter's + heuristics (specifically, not allowing lambda applications to open when they + introduce ``too many'' if terms).

      @(':hands-off')

      @@ -94810,13 +94810,12 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") (defxdoc splitter :parents (debugging) :short "Reporting of rules whose application may have caused case splits" - :long "

      The application of a rule to a term may cause a goal to simplify to - more than one subgoal. A rule with such an application is called a - ``splitter''. Here, we explain the output produced for splitters when proof - output is enabled - (see @(see set-inhibit-output-lst)) and such reporting is turned on (as it is - by default) — that is, when the value of @('(')@(tsee - splitter-output)@(')') is true.

      + :long "

      When the ACL2 rewriter applies a rule to a term, a goal might + simplify to more than one subgoal. A rule with such an application is called + a ``splitter''. Here, we explain the output produced for splitters when proof + output is enabled (see @(see set-inhibit-output-lst)) and such reporting is + turned on (as it is by default) — that is, when the value of + @('(')@(tsee splitter-output)@(')') is true.

      See @(see set-splitter-output) for how to turn off, or on, the reporting of splitters. Also see @(see set-case-split-limitations) for information on how diff --git a/defuns.lisp b/defuns.lisp index b6b2a71f9e9..60e2db3abd8 100644 --- a/defuns.lisp +++ b/defuns.lisp @@ -4368,8 +4368,8 @@ (case symbol-class (:program (er-cmp ctx - "~x0 is :program. Only :logic functions can have their ~ - guards verified. See :DOC verify-guards." + "~x0 is in :program mode. Only :logic mode functions can ~ + have their guards verified. See :DOC verify-guards." name)) ((:ideal :common-lisp-compliant) (let* ((recp (getpropc name 'recursivep nil wrld)) From 19c8e87eb12a4845475ae352a7b936eb58241b70 Mon Sep 17 00:00:00 2001 From: Matt Kaufmann Date: Mon, 1 Aug 2016 20:47:33 -0500 Subject: [PATCH 58/70] Synched doc.lisp. --- doc.lisp | 73 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 37 insertions(+), 36 deletions(-) diff --git a/doc.lisp b/doc.lisp index 22ca9728fe1..fa0f6828a0d 100644 --- a/doc.lisp +++ b/doc.lisp @@ -39060,36 +39060,36 @@ Subtopics result of substituting the ti's for the vi's in b. The terms listed in the :expand hint are expanded when they are encountered by the simplifier while working on the specified - goal or any of its subgoals. We permit value to be a single - such term instead of a singleton list. Remarks: (1) Allowed - are ``terms'' of the form (:free (var1 var2 ... varn) - pattern) where the indicated variables are distinct and - pattern is a term. Such ``terms'' indicate that we consider - the indicated variables to be instantiatable, in the - following sense: whenever the simplifier encounters a term - that can be obtained from pattern by instantiating the - variables (var1 var2 ... varn), then it expands that term. - (2) Also allowed are ``terms'' of the form (:with name term), - where name is a function symbol, a macro name that denotes a - function symbol (see [macro-aliases-table]), or a [rune]. The - corresponding rule of class :rewrite, which is often a - [definition] rule but need not be, is then used in place of - the current body for the function symbol of term; see - [show-bodies] and see [set-body]. If the rule is of the form - (implies hyp (equiv lhs rhs)), then after matching lhs to the - current term in a context that is maintaining equivalence - relation equiv, ACL2 will replace the current term with (if - hyp rhs (hide term)), or just rhs if the rule is just (equal - lhs rhs). (3) A combination of both :free and :with, as - described above, is legal. (4) The term :LAMBDAS is treated - specially. It denotes the list of all lambda applications - (i.e., [let] expressions) encountered during the proof. - Conceptually, this use of :LAMBDAS tells ACL2 to treat lambda - applications as a notation for substitutions, rather than as - function calls whose opening is subject to the ACL2 - rewriter's heuristics (specifically, not allowing lambda - applications to open when they introduce ``too many'' if - terms). + goal or any of its subgoals. (There is no separate ``expand'' + process.) We permit value to be a single such term instead of + a singleton list. Remarks: (1) Allowed are ``terms'' of the + form (:free (var1 var2 ... varn) pattern) where the indicated + variables are distinct and pattern is a term. Such ``terms'' + indicate that we consider the indicated variables to be + instantiatable, in the following sense: whenever the + simplifier encounters a term that can be obtained from + pattern by instantiating the variables (var1 var2 ... varn), + then it expands that term. (2) Also allowed are ``terms'' of + the form (:with name term), where name is a function symbol, + a macro name that denotes a function symbol (see + [macro-aliases-table]), or a [rune]. The corresponding rule + of class :rewrite, which is often a [definition] rule but + need not be, is then used in place of the current body for + the function symbol of term; see [show-bodies] and see + [set-body]. If the rule is of the form (implies hyp (equiv + lhs rhs)), then after matching lhs to the current term in a + context that is maintaining equivalence relation equiv, ACL2 + will replace the current term with (if hyp rhs (hide term)), + or just rhs if the rule is just (equal lhs rhs). (3) A + combination of both :free and :with, as described above, is + legal. (4) The term :LAMBDAS is treated specially. It denotes + the list of all lambda applications (i.e., [let] expressions) + encountered during the proof. Conceptually, this use of + :LAMBDAS tells ACL2 to treat lambda applications as a + notation for substitutions, rather than as function calls + whose opening is subject to the ACL2 rewriter's heuristics + (specifically, not allowing lambda applications to open when + they introduce ``too many'' if terms). :hands-off @@ -95666,12 +95666,13 @@ Subtopics (DEBUGGING) "Reporting of rules whose application may have caused case splits - The application of a rule to a term may cause a goal to simplify to - more than one subgoal. A rule with such an application is called a - ``splitter''. Here, we explain the output produced for splitters - when proof output is enabled (see [set-inhibit-output-lst]) and - such reporting is turned on (as it is by default) --- that is, when - the value of ([splitter-output]) is true. + When the ACL2 rewriter applies a rule to a term, a goal might + simplify to more than one subgoal. A rule with such an application + is called a ``splitter''. Here, we explain the output produced for + splitters when proof output is enabled (see + [set-inhibit-output-lst]) and such reporting is turned on (as it is + by default) --- that is, when the value of ([splitter-output]) is + true. See [set-splitter-output] for how to turn off, or on, the reporting of splitters. Also see [set-case-split-limitations] for information From cd2b8499f9ad600870339a4fc2465e383beb8c59 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Mon, 1 Aug 2016 18:58:53 -0700 Subject: [PATCH 59/70] Keep function-namep enabled. --- books/kestrel/utilities/world-queries.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/books/kestrel/utilities/world-queries.lisp b/books/kestrel/utilities/world-queries.lisp index 9c5de4dc06e..35520b6ff3a 100644 --- a/books/kestrel/utilities/world-queries.lisp +++ b/books/kestrel/utilities/world-queries.lisp @@ -53,7 +53,8 @@ (define function-namep (x (wrld plist-worldp)) :returns (yes/no booleanp) :short "True iff @('x') is a symbol that names a function." - (and (symbolp x) (function-symbolp x wrld))) + (and (symbolp x) (function-symbolp x wrld)) + :enabled t) (define theorem-namep (x (wrld plist-worldp)) :returns (yes/no booleanp) From ff582f6d639e182d395ec3300ac52b46780b1c0b Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Mon, 1 Aug 2016 19:03:15 -0700 Subject: [PATCH 60/70] Add books of theorems about all-vars/all-vars1 and logical worlds, tweak some documentation. --- .../kestrel/utilities/theorems/all-vars.lisp | 59 +++++++++++++++++++ books/kestrel/utilities/theorems/top.lisp | 5 +- books/kestrel/utilities/theorems/world.lisp | 22 +++++++ 3 files changed, 85 insertions(+), 1 deletion(-) create mode 100644 books/kestrel/utilities/theorems/all-vars.lisp create mode 100644 books/kestrel/utilities/theorems/world.lisp diff --git a/books/kestrel/utilities/theorems/all-vars.lisp b/books/kestrel/utilities/theorems/all-vars.lisp new file mode 100644 index 00000000000..7e2c6f922f5 --- /dev/null +++ b/books/kestrel/utilities/theorems/all-vars.lisp @@ -0,0 +1,59 @@ +; Theorems about all-vars (and all-vars1) +; +; Copyright (C) 2016 Kestrel Institute (http://www.kestrel.edu) +; +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. +; +; Author: Eric Smith (eric.smith@kestrel.edu) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(include-book "tools/flag" :dir :system) + +;;; Theorems about all-vars1 + +(make-flag all-vars1) + +(defthm-flag-all-vars1 + (defthm true-listp-of-all-vars1 + (equal (true-listp (all-vars1 term ans)) + (true-listp ans)) + :flag all-vars1) + (defthm true-listp-of-all-vars1-lst + (equal (true-listp (all-vars1-lst lst ans)) + (true-listp ans)) + :flag all-vars1-lst)) + +(defthm true-listp-of-all-vars1-type + (implies (true-listp ans) + (true-listp (all-vars1 term ans))) + :rule-classes :type-prescription) + +(defthm true-listp-of-all-vars1-lst-type + (implies (true-listp ans) + (true-listp (all-vars1-lst term ans))) + :rule-classes :type-prescription) + +(defthm-flag-all-vars1 + (defthm symbol-listp-of-all-vars1 + (implies (pseudo-termp term) + (equal (symbol-listp (all-vars1 term ans)) + (symbol-listp ans))) + :flag all-vars1) + (defthm symbol-listp-of-all-vars1-lst + (implies (pseudo-term-listp lst) + (equal (symbol-listp (all-vars1-lst lst ans)) + (symbol-listp ans))) + :flag all-vars1-lst)) + +;;; Theorems about all-vars + +(defthm symbol-listp-of-all-vars + (implies (pseudo-termp term) + (symbol-listp (all-vars term)))) + +(defthm true-listp-of-all-vars + (true-listp (all-vars term)) + :rule-classes (:rewrite :type-prescription)) diff --git a/books/kestrel/utilities/theorems/top.lisp b/books/kestrel/utilities/theorems/top.lisp index b4143ca4572..739dba22ea7 100644 --- a/books/kestrel/utilities/theorems/top.lisp +++ b/books/kestrel/utilities/theorems/top.lisp @@ -16,9 +16,12 @@ (include-book "list-sets") (include-book "true-list-listp") +(include-book "all-vars") +(include-book "world") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defxdoc miscellaneous-theorems :parents (kestrel-utilities) - :short "Some miscellaneous theorems.") + :short "Some miscellaneous theorems about functions defined outside the + Kestrel Books:") diff --git a/books/kestrel/utilities/theorems/world.lisp b/books/kestrel/utilities/theorems/world.lisp new file mode 100644 index 00000000000..b2d363164a0 --- /dev/null +++ b/books/kestrel/utilities/theorems/world.lisp @@ -0,0 +1,22 @@ +; Theorems about world-related functions +; +; Copyright (C) 2016 Kestrel Institute (http://www.kestrel.edu) +; +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. +; +; Author: Eric Smith (eric.smith@kestrel.edu) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(defthm arity-iff + (iff (arity fn wrld) + (or (consp fn) + (function-symbolp fn wrld))) + :hints (("Goal" :in-theory (enable arity)))) + +(defthm plist-worldp-when-plist-worldp-with-formals-cheap + (implies (not (plist-worldp wrld)) + (not (plist-worldp-with-formals wrld))) + :rule-classes ((:rewrite :backchain-limit-lst (0)))) From 22c31a6e0040370ab78c94078573139fa696ab65 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Mon, 1 Aug 2016 19:04:41 -0700 Subject: [PATCH 61/70] Delete theorems that have been moved to separate files (some theorems were improved in the process). --- books/kestrel/utilities/terms.lisp | 48 ++---------------------------- 1 file changed, 2 insertions(+), 46 deletions(-) diff --git a/books/kestrel/utilities/terms.lisp b/books/kestrel/utilities/terms.lisp index a80980e643a..5a7fc9e4e47 100644 --- a/books/kestrel/utilities/terms.lisp +++ b/books/kestrel/utilities/terms.lisp @@ -17,6 +17,8 @@ (include-book "kestrel/utilities/world-queries" :dir :system) (include-book "std/util/defines" :dir :system) +(include-book "theorems/all-vars") +(include-book "theorems/world") (local (set-default-parents term-utilities)) @@ -45,40 +47,6 @@ (symbol-listp (second x)) (pseudo-termp (third x)))) -(make-flag all-vars1) - -(defthm-flag-all-vars1 - (defthm true-listp-of-all-vars1 - (equal (true-listp (all-vars1 term ans)) - (true-listp ans)) - :flag all-vars1) - (defthm true-listp-of-all-vars1-lst - (equal (true-listp (all-vars1-lst lst ans)) - (true-listp ans)) - :flag all-vars1-lst)) - -(defrule true-listp-of-all-vars1-type - (implies (true-listp ans) - (true-listp (all-vars1 term ans))) - :rule-classes :type-prescription) - -(defrule true-listp-of-all-vars1-lst-type - (implies (true-listp ans) - (true-listp (all-vars1-lst term ans))) - :rule-classes :type-prescription) - -(defthm-flag-all-vars1 - (defthm symbol-listp-of-all-vars1 - (implies (pseudo-termp term) - (equal (symbol-listp (all-vars1 term ans)) - (symbol-listp ans))) - :flag all-vars1) - (defthm symbol-listp-of-all-vars1-lst - (implies (pseudo-term-listp lst) - (equal (symbol-listp (all-vars1-lst lst ans)) - (symbol-listp ans))) - :flag all-vars1-lst)) - (define lambda-closedp ((lambd pseudo-lambdap)) :returns (yes/no booleanp) :guard-hints (("Goal" :in-theory (enable pseudo-lambdap))) @@ -203,18 +171,6 @@ i.e. its body has no stobjs." (term-no-stobjs-p (lambda-body lambd) wrld)) -(defrule arity-when-not-function-namep - (implies (and (not (function-namep fn wrld)) - (symbolp fn)) - (not (arity fn wrld))) - :hints (("Goal" :in-theory (e/d (arity function-namep) (fgetprop)))) - :rule-classes ((:rewrite :backchain-limit-lst (0 nil)))) - -(defrule plist-worldp-when-plist-worldp-with-formals-cheap - (implies (plist-worldp-with-formals wrld) - (plist-worldp wrld)) - :rule-classes ((:rewrite :backchain-limit-lst (0)))) - (defines term/terms-guard-verified-fns :short "True iff term/terms is/are guard-verified." From 5bae0c6efe80488ad6bdd7274c5b798fc2514907 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Tue, 2 Aug 2016 18:11:35 -0700 Subject: [PATCH 62/70] Put two more functions in logic mode. STOBJP and COMPUTE-STOBJ-FLAGS. --- books/system/kestrel.lisp | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/books/system/kestrel.lisp b/books/system/kestrel.lisp index 1436780b23b..3957f882750 100644 --- a/books/system/kestrel.lisp +++ b/books/system/kestrel.lisp @@ -103,3 +103,10 @@ (verify-termination throw-nonexec-error-p) ; and guards +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(verify-termination stobjp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(verify-termination compute-stobj-flags) From a436cc48b47c85238dc055b1d61afe037df7b74f Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Tue, 2 Aug 2016 18:23:22 -0700 Subject: [PATCH 63/70] Add co-author and make minor formatting edits. --- books/kestrel/utilities/terms.lisp | 330 ++++++++++++++--------------- 1 file changed, 161 insertions(+), 169 deletions(-) diff --git a/books/kestrel/utilities/terms.lisp b/books/kestrel/utilities/terms.lisp index 5a7fc9e4e47..825f723f8ac 100644 --- a/books/kestrel/utilities/terms.lisp +++ b/books/kestrel/utilities/terms.lisp @@ -4,7 +4,10 @@ ; ; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. ; -; Author: Alessandro Coglio (coglio@kestrel.edu) +; Authors: +; Alessandro Coglio (coglio@kestrel.edu) +; Eric Smith (eric.smith@kestrel.edu) +; ; Contributor: Matt Kaufmann (kaufmann@cs.utexas.edu) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -30,17 +33,16 @@ (define pseudo-lambdap (x) :returns (yes/no booleanp) - :short - "True iff @('x') satisfies the conditions of lambda expressions - in pseudo-terms." + :short "True iff @('x') satisfies the conditions of lambda expressions + in pseudo-terms." :long "

      - Check whether @('x') is - a @('nil')-terminated list of exactly three elements, - whose first element is the symbol @('lambda'), - whose second element is a list of symbols, and - whose third element is a pseudo-term. -

      " + Check whether @('x') is + a @('nil')-terminated list of exactly three elements, + whose first element is the symbol @('lambda'), + whose second element is a list of symbols, and + whose third element is a pseudo-term. +

      " (and (true-listp x) (eql (len x) 3) (eq (first x) 'lambda) @@ -50,24 +52,23 @@ (define lambda-closedp ((lambd pseudo-lambdap)) :returns (yes/no booleanp) :guard-hints (("Goal" :in-theory (enable pseudo-lambdap))) - :short - "True iff the lambda expression is closed, i.e. it has no free variables." + :short "True iff the lambda expression is closed, + i.e. it has no free variables." (subsetp-eq (all-vars (lambda-body lambd)) (lambda-formals lambd))) (define pseudo-functionp (x) :returns (yes/no booleanp) - :short - "True iff @('x') satisfies the conditions of functions - in pseudo-terms." + :short "True iff @('x') satisfies the conditions of functions + in pseudo-terms." :long "

      - Check whether @('x') is a symbol or a - pseudo-lambda-expression. - These are the possible values of the first element of - a pseudo-term that is not a variable or a quoted constant - (i.e. a pseudo-term that is a function application). -

      " + Check whether @('x') is a symbol or a + pseudo-lambda-expression. + These are the possible values of the first element of + a pseudo-term that is not a variable or a quoted constant + (i.e. a pseudo-term that is a function application). +

      " (or (symbolp x) (pseudo-lambdap x))) @@ -78,53 +79,48 @@ ;; :returns (term pseudo-termp) :guard-hints (("Goal" :in-theory (enable pseudo-functionp pseudo-lambdap))) - :short - "Apply pseudo-function - to list of pseudo-terms, - obtaining a pseudo-term." + :short "Apply a pseudo-function + to a list of pseudo-terms, + obtaining a pseudo-term." :long "

      - If the pseudo-function is a lambda expression, - a beta reduction is performed. -

      " + If the pseudo-function is a lambda expression, + a beta reduction is performed. +

      " (cond ((symbolp fn) (cons-term fn terms)) (t (subcor-var (lambda-formals fn) terms (lambda-body fn))))) (defsection apply-term* - :short - "Apply pseudo-function - to pseudo-terms, - obtaining a pseudo-term." + :short "Apply a pseudo-function + to pseudo-terms, + obtaining a pseudo-term." :long "

      - If the pseudo-function is a lambda expression, - a beta reduction is performed. -

      - @(def apply-term*)" + If the pseudo-function is a lambda expression, + a beta reduction is performed. +

      + @(def apply-term*)" (defmacro apply-term* (fn &rest terms) `(apply-term ,fn (list ,@terms)))) -(define apply-unary-to-terms ((fn (and (pseudo-functionp fn) - (if (consp fn) - (eql 1 (len (cadr fn))) - t))) +(define apply-unary-to-terms ((fn (and (pseudo-functionp fn))) (terms pseudo-term-listp)) - :guard-hints (("Goal" :in-theory (enable PSEUDO-FUNCTIONP pseudo-lambdap))) + :guard (or (symbolp fn) + (eql 1 (len (lambda-formals fn)))) ;; :returns (applied-terms pseudo-term-listp) - :short - "Apply @('fn'), as a unary function, to each of @('terms'), - obtaining a list of corresponding terms." + :short "Apply @('fn'), as a unary function, to each of @('terms'), + obtaining a list of corresponding terms." (if (endp terms) nil (cons (apply-term* fn (car terms)) - (apply-unary-to-terms fn (cdr terms))))) + (apply-unary-to-terms fn (cdr terms)))) + :guard-hints (("Goal" :in-theory (enable pseudo-functionp pseudo-lambdap)))) (define lambda-logic-fnsp ((lambd pseudo-lambdap) (wrld plist-worldp)) :returns (yes/no booleanp) :guard-hints (("Goal" :in-theory (enable pseudo-lambdap))) - :short - "True iff the lambda expression is in logic mode, - i.e. its body is in logic mode." + :short "True iff the lambda expression is in logic mode, + i.e. its body is in logic mode." (logic-fnsp (lambda-body lambd) wrld)) (defines term/terms-no-stobjs-p @@ -135,16 +131,15 @@ (define term-no-stobjs-p ((term pseudo-termp) (wrld plist-worldp)) :returns (yes/no booleanp) :parents (term/terms-no-stobjs-p) - :short - "True iff the term has no stobjs, - i.e. all its functions have no stobjs." + :short "True iff the term has no stobjs, + i.e. all its functions have no stobjs." :long "

      - A term containing functions in @('*stobjs-out-invalid*') - (on which @(tsee no-stobjs-p) would cause a guard violation), - is regarded as having no stobjs, - if all its other functions have no stobjs. -

      " + A term containing functions in @('*stobjs-out-invalid*') + (on which @(tsee no-stobjs-p) would cause a guard violation), + is regarded as having no stobjs, + if all its other functions have no stobjs. +

      " (or (variablep term) (fquotep term) (and (terms-no-stobjs-p (fargs term) wrld) @@ -166,9 +161,8 @@ ((lambd pseudo-lambdap) (wrld plist-worldp)) :returns (yes/no booleanp) :prepwork ((program)) - :short - "True iff the lambda expression has no stobjs, - i.e. its body has no stobjs." + :short "True iff the lambda expression has no stobjs, + i.e. its body has no stobjs." (term-no-stobjs-p (lambda-body lambd) wrld)) (defines term/terms-guard-verified-fns @@ -181,12 +175,12 @@ :short "True iff all the functions in the term are guard-verified." :long "

      - Note that if @('term') includes @(tsee mbe), - @('nil') is returned - if any function inside the @(':logic') component of @(tsee mbe) - is not guard-verified, - even when @('term') could otherwise be fully guard-verified. -

      " + Note that if @('term') includes @(tsee mbe), + @('nil') is returned + if any function inside the @(':logic') component of @(tsee mbe) + is not guard-verified, + even when @('term') could otherwise be fully guard-verified. +

      " (or (variablep term) (fquotep term) (and (guard-verified-fns-listp (fargs term) wrld) @@ -206,16 +200,15 @@ (define lambda-expr-p (x (wrld plist-worldp-with-formals)) :returns (yes/no booleanp) - :short - "True iff @('x') is a valid translated lambda expression." + :short "True iff @('x') is a valid translated lambda expression." :long "

      - Check whether @('x') is a @('nil')-terminated list of exactly three elements, - whose first element is the symbol @('lambda'), - whose second element is a list of legal variable symbols without duplicates, - and whose third element is a valid translated term - whose free variables are all among the ones in the second element. -

      " + Check whether @('x') is a @('nil')-terminated list of exactly three elements, + whose first element is the symbol @('lambda'), + whose second element is a list of legal variable symbols without duplicates, + and whose third element is a valid translated term + whose free variables are all among the ones in the second element. +

      " (and (true-listp x) (eql (len x) 3) (eq (first x) 'lambda) @@ -228,8 +221,8 @@ (wrld plist-worldp-with-formals)) :returns (yes/no booleanp) :guard-hints (("Goal" :in-theory (enable LAMBDA-EXPR-P))) - :short - "True iff all the functions in the lambda expression is guard-verified." + :short "True iff all the functions in the lambda expression + are guard-verified." (guard-verified-fnsp (lambda-body lambd) wrld)) (define check-user-term (x (wrld plist-worldp)) @@ -237,54 +230,54 @@ (msgp term/message))) (stobjs-out symbol-listp)) :prepwork ((program)) - :short - "Check whether @('x') is an untranslated term that is valid for evaluation." + :short "Check whether @('x') is an untranslated term + that is valid for evaluation." :long "

      - An untranslated @(see term) is a term as entered by the user. - This function checks @('x') by attempting to translate it. - If the translation succeeds, the translated term is returned, - along with the output @(see stobj)s of the term (see below for details). - Otherwise, a structured error message is returned (printable with @('~@')), - along with @('nil') as output stobjs. - These two possible outcomes can be distinguished by the fact that - the former yields a pseudo-term - while the latter does not. -

      -

      - The ‘output stobjs’ of a term are the analogous - of the @(tsee stobjs-out) property of a function, - namely a list of symbols that is like a “mask” for the result. - A @('nil') in the list means that - the corresponding result is a non-stobj value, - while the name of a stobj in the list means that - the corresponding result is the named stobj. - The list is a singleton, unless the term returns - multiple values. -

      -

      - The @(':stobjs-out') and @('((:stobjs-out . :stobjs-out))') arguments - passed to @('translate1-cmp') as bindings - mean that the term is checked to be valid for evaluation. - This is stricter than checking the term to be valid for use in a theorem, - and weaker than checking the term to be valid - for use in the body of an executable function; - these different checks are performed by passing different values - to the second and third arguments of @('translate1-cmp') - (see the ACL2 source code for details). - However, for terms whose functions are all in logic mode, - validity for evaluation and validity for executable function bodies - should coincide. -

      -

      - If @('translate1-cmp') is successful, - it returns updated bindings that associate @(':stobjs-out') - to the output stobjs of the term. -

      -

      - The @(tsee check-user-term) function does not terminate - if the translation expands an ill-behaved macro that does not terminate. -

      " + An untranslated @(see term) is a term as entered by the user. + This function checks @('x') by attempting to translate it. + If the translation succeeds, the translated term is returned, + along with the output @(see stobj)s of the term (see below for details). + Otherwise, a structured error message is returned (printable with @('~@')), + along with @('nil') as output stobjs. + These two possible outcomes can be distinguished by the fact that + the former yields a pseudo-term + while the latter does not. +

      +

      + The ‘output stobjs’ of a term are the analogous + of the @(tsee stobjs-out) property of a function, + namely a list of symbols that is like a “mask” for the result. + A @('nil') in the list means that + the corresponding result is a non-stobj value, + while the name of a stobj in the list means that + the corresponding result is the named stobj. + The list is a singleton, unless the term returns + multiple values. +

      +

      + The @(':stobjs-out') and @('((:stobjs-out . :stobjs-out))') arguments + passed to @('translate1-cmp') as bindings + mean that the term is checked to be valid for evaluation. + This is stricter than checking the term to be valid for use in a theorem, + and weaker than checking the term to be valid + for use in the body of an executable function; + these different checks are performed by passing different values + to the second and third arguments of @('translate1-cmp') + (see the ACL2 source code for details). + However, for terms whose functions are all in logic mode, + validity for evaluation and validity for executable function bodies + should coincide. +

      +

      + If @('translate1-cmp') is successful, + it returns updated bindings that associate @(':stobjs-out') + to the output stobjs of the term. +

      +

      + The @(tsee check-user-term) function does not terminate + if the translation expands an ill-behaved macro that does not terminate. +

      " (mv-let (ctx term/message bindings) (translate1-cmp x :stobjs-out @@ -304,32 +297,31 @@ (msgp lambd/message))) (stobjs-out symbol-listp)) :prepwork ((program)) - :short - "Check whether @('x') is - an untranslated lambda expression that is valid for evaluation." + :short "Check whether @('x') is + an untranslated lambda expression that is valid for evaluation." :long "

      - An untranslated @(see lambda) expression is - a lambda expression as entered by the user. - This function checks whether @('x')is - a @('nil')-terminated list of exactly three elements, - whose first element is the symbol @('lambda'), - whose second element is a list of legal variable symbols without duplicates, - and whose third element is an untranslated term that is valid for evaluation. -

      -

      - If the check succeeds, the translated lambda expression is returned, - along with the output @(see stobj)s of the body of the lambda expression - (see @(tsee check-user-term) for an explanation - of the output stobjs of a term). - Otherwise, a possibly structured error message is returned - (printable with @('~@')), - along with @('nil') as output stobjs. -

      -

      - The @(tsee check-user-lambda) function does not terminate - if @(tsee check-user-term) does not terminate. -

      " + An untranslated @(see lambda) expression is + a lambda expression as entered by the user. + This function checks whether @('x')is + a @('nil')-terminated list of exactly three elements, + whose first element is the symbol @('lambda'), + whose second element is a list of legal variable symbols without duplicates, + and whose third element is an untranslated term that is valid for evaluation. +

      +

      + If the check succeeds, the translated lambda expression is returned, + along with the output @(see stobj)s of the body of the lambda expression + (see @(tsee check-user-term) for an explanation + of the output stobjs of a term). + Otherwise, a possibly structured error message is returned + (printable with @('~@')), + along with @('nil') as output stobjs. +

      +

      + The @(tsee check-user-lambda) function does not terminate + if @(tsee check-user-term) does not terminate. +

      " (b* (((unless (true-listp x)) (mv `("~x0 is not a NIL-terminated list." (#\0 . ,x)) nil)) @@ -352,26 +344,26 @@ :short "Translated term that a call to the macro translates to." :long "

      - This function translates a call to the macro - that only includes its required formal arguments, - returning the resulting translated term. -

      -

      - Note that since the macro is in the ACL2 world - (because of the @(tsee macro-namep) guard), - the translation of the macro call should not fail. - However, the translation may not terminate, - as mentioned in @(tsee check-user-term). -

      -

      - Note also that if the macro has optional arguments, - its translation with non-default values for these arguments - may yield different terms. - Furthermore, if the macro is sensitive - to the “shape” of its arguments, - calls with argument that are not the required formal arguments - may yield different terms. -

      " + This function translates a call to the macro + that only includes its required formal arguments, + returning the resulting translated term. +

      +

      + Note that since the macro is in the ACL2 world + (because of the @(tsee macro-namep) guard), + the translation of the macro call should not fail. + However, the translation may not terminate, + as mentioned in @(tsee check-user-term). +

      +

      + Note also that if the macro has optional arguments, + its translation with non-default values for these arguments + may yield different terms. + Furthermore, if the macro is sensitive + to the “shape” of its arguments, + calls with argument that are not the required formal arguments + may yield different terms. +

      " (mv-let (term stobjs-out) (check-user-term (cons mac (macro-required-args mac wrld)) wrld) (declare (ignore stobjs-out)) @@ -383,10 +375,10 @@ :short "Formula expressing the guard obligation of the term." :long "

      - The case in which @('term') is a symbol is dealt with separately - because @(tsee guard-obligation) - interprets a symbol as a function or theorem name, not as a variable. -

      " + The case in which @('term') is a symbol is dealt with separately + because @(tsee guard-obligation) + interprets a symbol as a function or theorem name, not as a variable. +

      " (b* (((when (symbolp term)) *t*) ((mv erp val) (guard-obligation term nil nil __function__ state)) ((when erp) From 0d9e4c79931254ac6bd7a6db8b49ac5a9bd06b20 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Tue, 2 Aug 2016 18:26:39 -0700 Subject: [PATCH 64/70] Rename term utility. LAMBDA-EXPR-P is now LAMBDAP. Also made a few more minor formatting changes to the file. --- books/kestrel/utilities/terms-tests.lisp | 4 ++-- books/kestrel/utilities/terms.lisp | 21 ++++++++++----------- 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/books/kestrel/utilities/terms-tests.lisp b/books/kestrel/utilities/terms-tests.lisp index 083d2563975..f8d2e68428a 100644 --- a/books/kestrel/utilities/terms-tests.lisp +++ b/books/kestrel/utilities/terms-tests.lisp @@ -131,9 +131,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (assert-event - (lambda-expr-p '(lambda (x y) (binary-+ x (len (cons '3 'nil)))) (w state))) + (lambdap '(lambda (x y) (binary-+ x (len (cons '3 'nil)))) (w state))) -(assert-event (not (lambda-expr-p '(lambda (x) (fffff x)) (w state)))) +(assert-event (not (lambdap '(lambda (x) (fffff x)) (w state)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/books/kestrel/utilities/terms.lisp b/books/kestrel/utilities/terms.lisp index 825f723f8ac..0a79f31c3c2 100644 --- a/books/kestrel/utilities/terms.lisp +++ b/books/kestrel/utilities/terms.lisp @@ -51,11 +51,11 @@ (define lambda-closedp ((lambd pseudo-lambdap)) :returns (yes/no booleanp) - :guard-hints (("Goal" :in-theory (enable pseudo-lambdap))) :short "True iff the lambda expression is closed, i.e. it has no free variables." (subsetp-eq (all-vars (lambda-body lambd)) - (lambda-formals lambd))) + (lambda-formals lambd)) + :guard-hints (("Goal" :in-theory (enable pseudo-lambdap)))) (define pseudo-functionp (x) :returns (yes/no booleanp) @@ -77,8 +77,6 @@ (eql (len terms) (len (lambda-formals fn)))) ;; :returns (term pseudo-termp) - :guard-hints (("Goal" :in-theory (enable pseudo-functionp - pseudo-lambdap))) :short "Apply a pseudo-function to a list of pseudo-terms, obtaining a pseudo-term." @@ -88,7 +86,8 @@ a beta reduction is performed.

      " (cond ((symbolp fn) (cons-term fn terms)) - (t (subcor-var (lambda-formals fn) terms (lambda-body fn))))) + (t (subcor-var (lambda-formals fn) terms (lambda-body fn)))) + :guard-hints (("Goal" :in-theory (enable pseudo-functionp pseudo-lambdap)))) (defsection apply-term* :short "Apply a pseudo-function @@ -118,10 +117,10 @@ (define lambda-logic-fnsp ((lambd pseudo-lambdap) (wrld plist-worldp)) :returns (yes/no booleanp) - :guard-hints (("Goal" :in-theory (enable pseudo-lambdap))) :short "True iff the lambda expression is in logic mode, i.e. its body is in logic mode." - (logic-fnsp (lambda-body lambd) wrld)) + (logic-fnsp (lambda-body lambd) wrld) + :guard-hints (("Goal" :in-theory (enable pseudo-lambdap)))) (defines term/terms-no-stobjs-p :prepwork ((program)) @@ -198,7 +197,7 @@ (and (guard-verified-fnsp (car terms) wrld) (guard-verified-fns-listp (cdr terms) wrld))))) -(define lambda-expr-p (x (wrld plist-worldp-with-formals)) +(define lambdap (x (wrld plist-worldp-with-formals)) :returns (yes/no booleanp) :short "True iff @('x') is a valid translated lambda expression." :long @@ -217,13 +216,13 @@ (subsetp-eq (all-vars (third x)) (second x)))) -(define lambda-guard-verified-fnsp ((lambd (lambda-expr-p lambd wrld)) +(define lambda-guard-verified-fnsp ((lambd (lambdap lambd wrld)) (wrld plist-worldp-with-formals)) :returns (yes/no booleanp) - :guard-hints (("Goal" :in-theory (enable LAMBDA-EXPR-P))) :short "True iff all the functions in the lambda expression are guard-verified." - (guard-verified-fnsp (lambda-body lambd) wrld)) + (guard-verified-fnsp (lambda-body lambd) wrld) + :guard-hints (("Goal" :in-theory (enable lambdap)))) (define check-user-term (x (wrld plist-worldp)) :returns (mv (term/message (or (pseudo-termp term/message) From 95bf2ac19a36bddb8040c5a9b7f6586e418b3909 Mon Sep 17 00:00:00 2001 From: Alessandro Coglio Date: Tue, 2 Aug 2016 18:37:47 -0700 Subject: [PATCH 65/70] Improve term utility. Now CHECK-USER-LAMBDA incorporates the (error) message returned by TRANSLATE1-CMP into the (error) message generated by CHECK-USER-LAMBDA itself. --- books/kestrel/utilities/terms.lisp | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/books/kestrel/utilities/terms.lisp b/books/kestrel/utilities/terms.lisp index 0a79f31c3c2..49291565e08 100644 --- a/books/kestrel/utilities/terms.lisp +++ b/books/kestrel/utilities/terms.lisp @@ -322,19 +322,16 @@ if @(tsee check-user-term) does not terminate.

      " (b* (((unless (true-listp x)) - (mv `("~x0 is not a NIL-terminated list." (#\0 . ,x)) - nil)) + (mv (msg "~x0 is not a NIL-terminated list." x) nil)) ((unless (eql (len x) 3)) - (mv `("~x0 does not consist of exactly three elements." (#\0 . ,x)) - nil)) + (mv (msg "~x0 does not consist of exactly three elements." x) nil)) ((unless (eq (first x) 'lambda)) - (mv `("~x0 does not start with LAMBDA." (#\0 . ,x)) - nil)) + (mv (msg "~x0 does not start with LAMBDA." x) nil)) ((unless (arglistp (second x))) - (mv `("~x0 does not have valid formal parameters." (#\0 . ,x)) - nil)) + (mv (msg "~x0 does not have valid formal parameters." x) nil)) ((mv term/message stobjs-out) (check-user-term (third x) wrld)) - ((when (msgp term/message)) (mv term/message nil))) + ((when (msgp term/message)) + (mv (msg "~x0 does not have a valid body. ~@1" x term/message) nil))) (mv `(lambda ,(second x) ,term/message) stobjs-out))) (define trans-macro ((mac (macro-namep mac wrld)) (wrld plist-worldp)) From 1a2f6671ccb6c5b14603e1c6bd5fb9691acd4737 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 29 Jul 2016 19:55:51 -0700 Subject: [PATCH 66/70] Break line in comment to avoid warning about circular dependency. --- books/kestrel/utilities/non-ascii-pathnames.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/books/kestrel/utilities/non-ascii-pathnames.lisp b/books/kestrel/utilities/non-ascii-pathnames.lisp index e6e5ceca903..15e92d0511d 100644 --- a/books/kestrel/utilities/non-ascii-pathnames.lisp +++ b/books/kestrel/utilities/non-ascii-pathnames.lisp @@ -39,7 +39,8 @@ bash # Create a file whose name probably looks like a Euro sign. touch $'\xe2\x82\xac' # Start ACL2 here, based on CCL. Then: -(include-book "kestrel/utilities/non-ascii-pathnames" :dir :system) +(include-book ;break line to fool dependency scanner + "kestrel/utilities/non-ascii-pathnames" :dir :system) (set-raw-mode-on!) # Next we use a new utility, which converts OS pathnames to ACL2 pathnames, # to store the ACL2 pathname of the new file into a global. From 1b0b091935be431b60106dc896b7f33292ce1d5b Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 29 Jul 2016 20:03:11 -0700 Subject: [PATCH 67/70] Small xdoc changes: fix 'n-nth' typo, clarify that argument numbering starts at 1. --- books/system/doc/acl2-doc.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index 53ea1f50b6a..65bf995878b 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -98077,8 +98077,8 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") defined in terms of @('enabled-numep').
    7. @('(fargn x n)'): For a @(tsee pseudo-termp) @('x') that is a function - call and for a positive integer @('n'), return the @('n')-nth argument of - @('x').
      8. + call and for a positive integer @('n'), return the @('n')-th argument of + @('x'), where the numbering of arguments starts at 1.
    8. @('(fargs x)'): For a @(tsee pseudo-termp) @('x') that is a function call, return its arguments.
      9. From 923d522fe006be5a1652e19e68bcee1525c68267 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 5 Aug 2016 14:25:41 -0700 Subject: [PATCH 68/70] Add :hints and :otf-flg options to verify-guards-program. --- .../verify-guards-program-tests.lisp | 18 +++++++ .../utilities/verify-guards-program.lisp | 49 +++++++++++++------ 2 files changed, 52 insertions(+), 15 deletions(-) diff --git a/books/kestrel/utilities/verify-guards-program-tests.lisp b/books/kestrel/utilities/verify-guards-program-tests.lisp index 971ea4df404..434e194620e 100644 --- a/books/kestrel/utilities/verify-guards-program-tests.lisp +++ b/books/kestrel/utilities/verify-guards-program-tests.lisp @@ -54,3 +54,21 @@ ;; Fails because f0 does not exist (must-fail (verify-guards-program f0)) + +;;; A test with :hints: + +(defun foo (x) + (declare (xargs :mode :program + :guard (natp (car x)))) + x) +(defun bar (x) + (declare (xargs :mode :program + :guard (natp x))) + (foo (cons x nil))) +(in-theory (disable car-cons)) ;to make the proof fail without hints +;; fails without the hints: +(must-fail (verify-guards-program bar)) +(verify-guards-program bar :hints (("Goal" :in-theory (enable car-cons)))) +;Also test :otf-flg +(verify-guards-program bar :otf-flg t + :hints (("Goal" :in-theory (enable car-cons)))) diff --git a/books/kestrel/utilities/verify-guards-program.lisp b/books/kestrel/utilities/verify-guards-program.lisp index 278ab796cec..9d14d61ec50 100644 --- a/books/kestrel/utilities/verify-guards-program.lisp +++ b/books/kestrel/utilities/verify-guards-program.lisp @@ -27,7 +27,7 @@ ; already a guard-verified function symbol, and maybe even if it's already in ; :logic mode (since then perhaps verify-guards would be more appropriate). -; - Consider a mechanism for providing hints. +; - Consider a mechanism for providing termination hints. ; - Consider adding an option that proves both termination and guards for the ; given function, rather than skipping the termination proof. @@ -274,16 +274,20 @@ (t `(skip-proofs (verify-termination ,f (declare (xargs :verify-guards nil))))))) -(defun verify-term-guards-form (g sibs wrld) +(defun verify-term-guards-form (g sibs hints otf-flg wrld) (cond ((eq (getpropc g 'symbol-class nil wrld) :program) `(progn ,(verify-termination-form g sibs wrld) - (verify-guards ,g))) + (verify-guards ,g + ,@(and hints `(:hints ,hints)) + ,@(and otf-flg `(:otf-flg ,otf-flg))))) (t ; typically (eq class :ideal) - `(verify-guards ,g)))) + `(verify-guards ,g + ,@(and hints `(:hints ,hints)) + ,@(and otf-flg `(:otf-flg ,otf-flg)))))) -(defun verify-guards-program-forms-1 (fn-alist wrld acc) +(defun verify-guards-program-forms-1 (fn-alist fn hints otf-flg wrld acc) ; Fn-alist is an alist with entries (fn . val), where fn is a function symbol ; of wrld and val is t if fn is non-recursive, else val is a list of the @@ -296,17 +300,30 @@ (reverse acc)) ; restore the order (t (verify-guards-program-forms-1 (cdr fn-alist) + fn + hints + otf-flg wrld (let ((entry (car fn-alist))) - (cons (let ((form (verify-term-guards-form (car entry) - (cdr entry) - wrld))) - (if (consp (cdr fn-alist)) - `(skip-proofs ,form) - form)) + (cons (let* ((val (cdr entry)) + ;; Test whether this is the entry for the + ;; function on which verify-guards-program + ;; was invoked (if so, attempt the guard + ;; proof [with hints], if not skip the guard + ;; proof): + (main-fnp (and (not (eq t val)) + (member-eq fn val))) + (form (verify-term-guards-form (car entry) + (cdr entry) + (and main-fnp hints) + (and main-fnp otf-flg) + wrld))) + (if main-fnp + form + `(skip-proofs ,form))) acc)))))) -(defun verify-guards-program-forms (fn wrld) +(defun verify-guards-program-forms (fn hints otf-flg wrld) (cond ((not (and (symbolp fn) (function-symbolp fn wrld))) `((value-triple (er hard 'verify-guards-program @@ -319,10 +336,12 @@ (alist (order-alist-by-non-compliant-supporters-depth (non-compliant-supporters fn wrld ctx state-vars) wrld ctx state-vars nil))) - (verify-guards-program-forms-1 alist wrld nil))))) + (verify-guards-program-forms-1 alist fn hints otf-flg wrld nil))))) (defmacro verify-guards-program (fn &key - (print ':use-default print-p)) + (print ':use-default print-p) + (hints 'nil) + (otf-flg 'nil)) `(make-event (mv-let (erp val state) (ld (list* '(logic) '(set-state-ok t) @@ -332,7 +351,7 @@ '(set-temp-touchable-vars t state) '(set-temp-touchable-fns t state) '(assign verify-termination-on-raw-program-okp t) - (verify-guards-program-forms ',fn (w state))) + (verify-guards-program-forms ',fn ',hints ',otf-flg (w state))) :ld-error-action :error ,@(and print-p `(:ld-pre-eval-print ,print))) (declare (ignore val)) From b3d77d2e48bc72de47506ff07eb3d00513f89f28 Mon Sep 17 00:00:00 2001 From: Eric Smith Date: Fri, 5 Aug 2016 16:28:12 -0700 Subject: [PATCH 69/70] Fix xdoc typo. --- books/system/doc/acl2-doc.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/books/system/doc/acl2-doc.lisp b/books/system/doc/acl2-doc.lisp index 65bf995878b..f1f49d1ef11 100644 --- a/books/system/doc/acl2-doc.lisp +++ b/books/system/doc/acl2-doc.lisp @@ -98212,7 +98212,7 @@ arithmetic) for libraries of @(see books) for arithmetic reasoning.

      ") of mutually recursive functions of which @('fn') is a member. The list is empty iff @('fn') is not recursive. The list contains just @('fn') iff @('fn') is singly recursive. NOTE: @('flg') should be @('t') or @('nil'). If - @('flg') is @('nil'), or result is based solely on the @(tsee defun) form that + @('flg') is @('nil'), the result is based solely on the @(tsee defun) form that introduced @('fn') and is equal to @('(getpropc fn 'recursivep nil w)'). If @('flg') is @('t'), then the most recent @(see definition) rule for @('fn') with a non-@('nil') value of @(':install-body') — which could be the From e7de751c14d974ba2734e735cef8612bc7cc10ed Mon Sep 17 00:00:00 2001 From: Shilpi Goel Date: Mon, 8 Aug 2016 11:41:28 -0500 Subject: [PATCH 70/70] x86isa: Misc. changes -- Added Dmitry Nadezhin's contribution: functions rm/wm128 are now logically equal to rb/wb, respectively. -- Replaced popcount program in proofs/popcount with a more interesting version. --- .../x86-jump-and-loop-instructions.lisp | 2 - .../x86-segmentation-instructions.lisp | 6 +- .../x86-register-readers-and-writers.lisp | 7 +- .../x86isa/machine/x86-top-level-memory.lisp | 850 ++++++++++-------- .../x86isa/proofs/popcount/popcount.lisp | 796 ++++++++-------- .../system-level-mode/marking-mode-utils.lisp | 36 +- 6 files changed, 913 insertions(+), 784 deletions(-) diff --git a/books/projects/x86isa/machine/instructions/x86-jump-and-loop-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-jump-and-loop-instructions.lisp index 21dfe12b659..aad3d2f5ec5 100644 --- a/books/projects/x86isa/machine/instructions/x86-jump-and-loop-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-jump-and-loop-instructions.lisp @@ -266,8 +266,6 @@ indirectly with a memory location \(m16:16 or m16:32 or m16:64\).

      " ;; Offset size can be 2, 4, or 8 bytes. (select-operand-size nil rex-byte nil prefixes)) (inst-ac? t) - ;; TODO: I'm not sure that (+ 2 offset-size) below is correct. - ;; I need to check what "Mp" operands really mean. ((mv flg mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) ?v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes diff --git a/books/projects/x86isa/machine/instructions/x86-segmentation-instructions.lisp b/books/projects/x86isa/machine/instructions/x86-segmentation-instructions.lisp index d681fd4bb98..28413f51feb 100644 --- a/books/projects/x86isa/machine/instructions/x86-segmentation-instructions.lisp +++ b/books/projects/x86isa/machine/instructions/x86-segmentation-instructions.lisp @@ -69,7 +69,7 @@ ((mv flg0 mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - 0 10 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 10 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 ;; No immediate operand x86)) ((when flg0) @@ -156,7 +156,7 @@ ((mv flg0 mem (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - 0 10 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 10 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 ;; No immediate operand x86)) ((when flg0) @@ -248,7 +248,7 @@ a non-canonical form, raise the SS exception.

      " ((mv flg0 selector (the (unsigned-byte 3) increment-RIP-by) (the (signed-byte #.*max-linear-address-size*) v-addr) x86) (x86-operand-from-modr/m-and-sib-bytes - 0 2 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib + 0 2 inst-ac? p2 p4? temp-rip rex-byte r/m mod sib 0 ;; No immediate operand x86)) ((when flg0) diff --git a/books/projects/x86isa/machine/x86-register-readers-and-writers.lisp b/books/projects/x86isa/machine/x86-register-readers-and-writers.lisp index d58ca403045..4ef63ae5a32 100644 --- a/books/projects/x86isa/machine/x86-register-readers-and-writers.lisp +++ b/books/projects/x86isa/machine/x86-register-readers-and-writers.lisp @@ -923,8 +923,13 @@ values.

      " (defun create-undef (x) (nfix x))) + (defthm integerp-create-undef + (integerp (create-undef x)) + :rule-classes (:rewrite :type-prescription)) + (defthm natp-create-undef - (natp (create-undef x)))) + (natp (create-undef x)) + :rule-classes (:rewrite :type-prescription))) (define unsafe-!undef (v x86) diff --git a/books/projects/x86isa/machine/x86-top-level-memory.lisp b/books/projects/x86isa/machine/x86-top-level-memory.lisp index 5fa1a4df44e..15c53de8a70 100644 --- a/books/projects/x86isa/machine/x86-top-level-memory.lisp +++ b/books/projects/x86isa/machine/x86-top-level-memory.lisp @@ -1,7 +1,8 @@ ;; AUTHORS: ;; Shilpi Goel ;; Robert Krug -;; Help on the unraveling loghead meta rule by Matt Kaufmann +;; Thanks to Dmitry Nadezhin for proving the equivalence of rm/wm128 +;; to rb/wb. (in-package "X86ISA") (include-book "x86-ia32e-segmentation" :ttags (:undef-flg)) @@ -13,6 +14,7 @@ (local (include-book "centaur/bitops/ihs-extensions" :dir :system)) (local (include-book "centaur/bitops/signed-byte-p" :dir :system)) (local (include-book "arithmetic/top-with-meta" :dir :system)) +(local (include-book "std/basic/inductions" :dir :system)) ;; ====================================================================== @@ -197,6 +199,8 @@ memory. #|| +;; Help on the unraveling loghead meta rule by Matt Kaufmann. + ;; Unraveling nests of loghead: ;; unravel-loghead-meta-lemma will help me avoid explicitly proving @@ -757,7 +761,8 @@ memory. ((mv flg byte x86) (rvm08 addr x86)) ((when flg) - (mv flg acc x86))) + ;; Note: the bytes returned are nil, not acc. + (mv flg nil x86))) (rb-1 (cdr addresses) r-w-x x86 (append acc (list byte))))) (mv t acc x86)) @@ -1007,6 +1012,90 @@ memory. :in-theory (e/d* (!flgi-open-to-xw-rflags) (las-to-pas-xw-rflags-state-not-ac)))))) + (define las-to-pas-tailrec + (l-addrs + (p-addrs physical-address-listp) + (r-w-x :type (member :r :w :x)) + (cpl :type (unsigned-byte 2)) + x86) + :short "Used to discharge @('mbe') proof obligations for @(see + rm128) and @(see wm128)" + :enabled t + :guard (and (not (programmer-level-mode x86)) + (canonical-address-listp l-addrs)) + + (if (atom l-addrs) + (mv nil (acl2::rev p-addrs) x86) + + (b* (((mv flg p-addr x86) + (ia32e-la-to-pa (car l-addrs) r-w-x cpl x86)) + ((when flg) (mv flg nil x86))) + (las-to-pas-tailrec + (cdr l-addrs) (cons p-addr p-addrs) r-w-x cpl x86))) + + /// + + (defthmd las-to-pas-tailrec-opener + (implies + (consp l-addrs) + (equal + (las-to-pas-tailrec l-addrs p-addrs r-w-x cpl x86) + (mv-let + (flg p-addr x86) + (ia32e-la-to-pa (car l-addrs) r-w-x cpl x86) + (if flg + (mv flg () x86) + (las-to-pas-tailrec (cdr l-addrs) (cons p-addr p-addrs) r-w-x cpl x86)))))) + + (defthmd las-to-pas-tailrec-nil + (equal + (las-to-pas-tailrec () p-addrs r-w-x cpl x86) + (mv nil (acl2::rev p-addrs) x86))) + + (local + (defthmd las-to-pas-tailrec-as-las-to-pas-lemma + (b* (((mv flg-new p-addrs-new x86-new) + (las-to-pas l-addrs r-w-x cpl x86)) + ((mv flg-alt p-addrs-alt x86-alt) + (las-to-pas-tailrec l-addrs p-addrs r-w-x cpl x86))) + (and (equal flg-alt flg-new) + (equal p-addrs-alt + (if flg-new + () + (revappend p-addrs p-addrs-new))) + (equal x86-alt x86-new))) + :hints (("goal" :induct (las-to-pas-tailrec + l-addrs p-addrs r-w-x cpl x86))))) + + (local + (defthm las-to-pas-as-list + (let ((mv (las-to-pas l-addrs r-w-x cpl x86))) + (equal mv (list (mv-nth 0 mv) + (mv-nth 1 mv) + (mv-nth 2 mv)))) + :rule-classes ())) + + (local + (defthm las-to-pas-tailrec-as-list + (let ((mv (las-to-pas-tailrec l-addrs p-addrs r-w-x cpl x86))) + (equal mv (list (mv-nth 0 mv) + (mv-nth 1 mv) + (mv-nth 2 mv)))) + :rule-classes ())) + + (local + (defrule last-to-pas-when-flg + (b* (((mv flg p-addrs ?x86) (las-to-pas l-addrs r-w-x cpl x86))) + (implies flg (not p-addrs))))) + + (defthmd las-to-pas-as-las-to-pas-tailrec + (equal (las-to-pas l-addrs r-w-x cpl x86) + (las-to-pas-tailrec l-addrs () r-w-x cpl x86)) + :hints (("goal" :use + (las-to-pas-as-list + (:instance las-to-pas-tailrec-as-list (p-addrs ())) + (:instance las-to-pas-tailrec-as-las-to-pas-lemma (p-addrs ()))))))) + (define read-from-physical-memory ((p-addrs physical-address-listp) x86) @@ -2013,7 +2102,6 @@ memory. (* 8 (len xs)))))) :hints (("Goal" :in-theory (e/d* (push-ash-inside-logior) ()))))) - ;; ====================================================================== ;; Defining the 8, 16, 32, and 64, and 128 bit memory read/write @@ -3257,8 +3345,16 @@ memory. :parents (x86-top-level-memory) :guard (canonical-address-p lin-addr) - :guard-hints (("Goal" :in-theory (e/d (rb-and-rvm128 rm08) - (rb ;;signed-byte-p + :guard-hints (("Goal" :in-theory (e/d (rb-and-rvm128 + las-to-pas-as-las-to-pas-tailrec + las-to-pas-tailrec-opener + las-to-pas-tailrec-nil + combine-bytes-as-merge-16-u8s + natp-memi memi<256) + (rvm128 + las-to-pas + memi + combine-bytes not member-equal ash-monotone-2)))) @@ -3330,10 +3426,9 @@ memory. rb-and-rvm128-helper-2) (force (force)))))) - (defthm combine-bytes-size-for-rm128-programmer-level-mode + (defthm combine-bytes-size-for-rm128 (implies (and (signed-byte-p 48 lin-addr) (x86p x86) - (programmer-level-mode x86) (signed-byte-p 48 (+ 15 lin-addr))) (< (combine-bytes (mv-nth 1 (rb (create-canonical-address-list 16 lin-addr) @@ -3379,7 +3474,60 @@ memory. :hints (("Goal" :in-theory (e/d* () (unsigned-byte-p)))) :hints-l (("Goal" :in-theory (e/d* (unsigned-byte-p) (bitops::unsigned-byte-p-128-of-merge-16-u8s)) :use ((:instance bitops::unsigned-byte-p-128-of-merge-16-u8s)))) - :gen-linear t)) + :gen-linear t) + + (local + (defthm floor-1 + (implies (integerp x) + (equal (floor x 1) x)) + :hints (("goal" :in-theory (enable floor))))) + + (local + (defthm 2*ash + (implies (posp n) + (equal (* 2 (ash x (1- n))) + (ash x n))) + :hints (("goal" :in-theory (enable ash) + :use (:instance acl2::exponents-add-unrestricted + (r 2) (i 1) (j (1- n))))))) + + (local + (defthmd ash-logior + (implies (natp n) + (equal (ash (logior x y) n) + (logior (ash x n) + (ash y n)))) + :hints (("goal" :in-theory (enable logcons) :induct (acl2::dec-induct n)) + ("subgoal *1/2" :use ((:instance logior** (i (ash x n)) (j (ash y n)))))))) + + (local + (defthmd ash-logior-8 + (equal (ash (logior x y) 8) + (logior (ash x 8) + (ash y 8))) + :hints (("goal" :in-theory (enable ash-logior))))) + + (defthmd combine-bytes-as-merge-16-u8s + (implies + (and (natp b0) (natp b1) (natp b2) (natp b3) + (natp b4) (natp b5) (natp b6) (natp b7) + (natp b8) (natp b9) (natp b10) (natp b11) + (natp b12) (natp b13) (natp b14) (natp b15)) + (equal + (combine-bytes + (list + b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15)) + (bitops::merge-16-u8s + b15 b14 b13 b12 b11 b10 b9 b8 b7 b6 b5 b4 b3 b2 b1 b0))) + :hints (("goal" :in-theory (enable ash-logior-8 merge-16-u8s)))) + + (defthmd natp-memi + (implies (and (x86p x86)) + (natp (memi p-addr x86)))) + + (defthmd memi<256 + (implies (and (x86p x86)) + (< (memi p-addr x86) 256)))) (if (mbt (canonical-address-p lin-addr)) @@ -3392,122 +3540,125 @@ memory. 15+lin-addr) #.*2^47*)) - (if (programmer-level-mode x86) - - (mbe :logic (b* (((mv flg bytes x86) - (rb (create-canonical-address-list 16 lin-addr) - r-w-x x86)) - (result (combine-bytes bytes))) - (mv flg result x86)) - :exec (rvm128 lin-addr x86)) - - (let* ((cpl (cpl x86))) - - (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) - (la-to-pa lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) - (+ 1 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) - (la-to-pa 1+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+2*) 2+lin-addr) - (+ 2 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) - (la-to-pa 2+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+3*) 3+lin-addr) - (+ 3 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) - (la-to-pa 3+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+4*) 4+lin-addr) - (+ 4 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr4) x86) - (la-to-pa 4+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+5*) 5+lin-addr) - (+ 5 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr5) x86) - (la-to-pa 5+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+6*) 6+lin-addr) - (+ 6 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr6) x86) - (la-to-pa 6+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+7*) 7+lin-addr) - (+ 7 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr7) x86) - (la-to-pa 7+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+8*) 8+lin-addr) - (+ 8 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr8) x86) - (la-to-pa 8+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+9*) 9+lin-addr) - (+ 9 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr9) x86) - (la-to-pa 9+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+10*) 10+lin-addr) - (+ 10 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr10) x86) - (la-to-pa 10+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+11*) 11+lin-addr) - (+ 11 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr11) x86) - (la-to-pa 11+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+12*) 12+lin-addr) - (+ 12 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr12) x86) - (la-to-pa 12+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+13*) 13+lin-addr) - (+ 13 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr13) x86) - (la-to-pa 13+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+14*) 14+lin-addr) - (+ 14 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr14) x86) - (la-to-pa 14+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - ((the (signed-byte #.*max-linear-address-size+15*) 15+lin-addr) - (+ 15 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr15) x86) - (la-to-pa 15+lin-addr r-w-x cpl x86)) - ((when flag) (mv flag 0 x86)) - - (byte0 (memi p-addr0 x86)) - (byte1 (memi p-addr1 x86)) - (byte2 (memi p-addr2 x86)) - (byte3 (memi p-addr3 x86)) - (byte4 (memi p-addr4 x86)) - (byte5 (memi p-addr5 x86)) - (byte6 (memi p-addr6 x86)) - (byte7 (memi p-addr7 x86)) - (byte8 (memi p-addr8 x86)) - (byte9 (memi p-addr9 x86)) - (byte10 (memi p-addr10 x86)) - (byte11 (memi p-addr11 x86)) - (byte12 (memi p-addr12 x86)) - (byte13 (memi p-addr13 x86)) - (byte14 (memi p-addr14 x86)) - (byte15 (memi p-addr15 x86)) - - (oword - (the (unsigned-byte 128) - (bitops::merge-16-u8s - byte15 byte14 byte13 byte12 - byte11 byte10 byte9 byte8 - byte7 byte6 byte5 byte4 - byte3 byte2 byte1 byte0)))) - - (mv nil oword x86)))) + (mbe :logic + (b* (((mv flg bytes x86) + (rb (create-canonical-address-list 16 lin-addr) + r-w-x x86)) + (result (combine-bytes bytes))) + (mv flg result x86)) + + :exec + (if (programmer-level-mode x86) + + (rvm128 lin-addr x86) + + (let* ((cpl (cpl x86))) + + (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) + (la-to-pa lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) + (+ 1 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) + (la-to-pa 1+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+2*) 2+lin-addr) + (+ 2 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) + (la-to-pa 2+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+3*) 3+lin-addr) + (+ 3 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) + (la-to-pa 3+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+4*) 4+lin-addr) + (+ 4 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr4) x86) + (la-to-pa 4+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+5*) 5+lin-addr) + (+ 5 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr5) x86) + (la-to-pa 5+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+6*) 6+lin-addr) + (+ 6 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr6) x86) + (la-to-pa 6+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+7*) 7+lin-addr) + (+ 7 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr7) x86) + (la-to-pa 7+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+8*) 8+lin-addr) + (+ 8 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr8) x86) + (la-to-pa 8+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+9*) 9+lin-addr) + (+ 9 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr9) x86) + (la-to-pa 9+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+10*) 10+lin-addr) + (+ 10 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr10) x86) + (la-to-pa 10+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+11*) 11+lin-addr) + (+ 11 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr11) x86) + (la-to-pa 11+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+12*) 12+lin-addr) + (+ 12 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr12) x86) + (la-to-pa 12+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+13*) 13+lin-addr) + (+ 13 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr13) x86) + (la-to-pa 13+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+14*) 14+lin-addr) + (+ 14 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr14) x86) + (la-to-pa 14+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + ((the (signed-byte #.*max-linear-address-size+15*) 15+lin-addr) + (+ 15 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr15) x86) + (la-to-pa 15+lin-addr r-w-x cpl x86)) + ((when flag) (mv flag 0 x86)) + + (byte0 (memi p-addr0 x86)) + (byte1 (memi p-addr1 x86)) + (byte2 (memi p-addr2 x86)) + (byte3 (memi p-addr3 x86)) + (byte4 (memi p-addr4 x86)) + (byte5 (memi p-addr5 x86)) + (byte6 (memi p-addr6 x86)) + (byte7 (memi p-addr7 x86)) + (byte8 (memi p-addr8 x86)) + (byte9 (memi p-addr9 x86)) + (byte10 (memi p-addr10 x86)) + (byte11 (memi p-addr11 x86)) + (byte12 (memi p-addr12 x86)) + (byte13 (memi p-addr13 x86)) + (byte14 (memi p-addr14 x86)) + (byte15 (memi p-addr15 x86)) + + (oword + (the (unsigned-byte 128) + (bitops::merge-16-u8s + byte15 byte14 byte13 byte12 + byte11 byte10 byte9 byte8 + byte7 byte6 byte5 byte4 + byte3 byte2 byte1 byte0)))) + + (mv nil oword x86))))) (mv 'rm128 0 x86))) @@ -3542,7 +3693,14 @@ memory. :parents (x86-top-level-memory) :guard (canonical-address-p lin-addr) - :guard-hints (("Goal" :in-theory (e/d (wb-and-wvm128) (wb)))) + :guard-hints (("Goal" :in-theory (e/d (wb-and-wvm128 + byte-ify + las-to-pas-as-las-to-pas-tailrec + las-to-pas-tailrec-opener + las-to-pas-tailrec-nil + create-addr-bytes-alist-opener) + (wvm128 + las-to-pas)))) :prepwork @@ -3559,7 +3717,16 @@ memory. (append-and-create-addr-bytes-alist cons-and-create-addr-bytes-alist append-and-addr-byte-alistp - force (force) nthcdr-byte-listp)))))) + force (force) nthcdr-byte-listp))))) + + (defthmd create-addr-bytes-alist-opener + (implies + (and (consp addr-list) + (equal (len addr-list) (len byte-list))) + (equal (create-addr-bytes-alist addr-list byte-list) + (acons (car addr-list) (car byte-list) + (create-addr-bytes-alist (cdr addr-list) + (cdr byte-list))))))) (if (mbt (canonical-address-p lin-addr)) @@ -3573,166 +3740,166 @@ memory. 15+lin-addr) #.*2^47*)) - (if (programmer-level-mode x86) + (mbe + :logic + (wb (create-addr-bytes-alist + (create-canonical-address-list 16 lin-addr) + (byte-ify 16 val)) + x86) + + :exec + (if (programmer-level-mode x86) - (mbe - :logic - (wb (create-addr-bytes-alist - (create-canonical-address-list 16 lin-addr) - (byte-ify 16 val)) - x86) - :exec - (wvm128 lin-addr val x86)) - - - (let* ((cpl (cpl x86))) - - (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) - (la-to-pa lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) - (+ 1 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) - (la-to-pa 1+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+2*) 2+lin-addr) - (+ 2 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) - (la-to-pa 2+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+3*) 3+lin-addr) - (+ 3 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) - (la-to-pa 3+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+4*) 4+lin-addr) - (+ 4 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr4) x86) - (la-to-pa 4+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+5*) 5+lin-addr) - (+ 5 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr5) x86) - (la-to-pa 5+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+6*) 6+lin-addr) - (+ 6 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr6) x86) - (la-to-pa 6+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+7*) 7+lin-addr) - (+ 7 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr7) x86) - (la-to-pa 7+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+8*) 8+lin-addr) - (+ 8 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr8) x86) - (la-to-pa 8+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+9*) 9+lin-addr) - (+ 9 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr9) x86) - (la-to-pa 9+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+10*) 10+lin-addr) - (+ 10 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr10) x86) - (la-to-pa 10+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+11*) 11+lin-addr) - (+ 11 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr11) x86) - (la-to-pa 11+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+12*) 12+lin-addr) - (+ 12 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr12) x86) - (la-to-pa 12+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+13*) 13+lin-addr) - (+ 13 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr13) x86) - (la-to-pa 13+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+14*) 14+lin-addr) - (+ 14 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr14) x86) - (la-to-pa 14+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - ((the (signed-byte #.*max-linear-address-size+15*) 15+lin-addr) - (+ 15 lin-addr)) - ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr15) x86) - (la-to-pa 15+lin-addr :w cpl x86)) - ((when flag) (mv flag x86)) - - (byte0 (mbe :logic (part-select val :low 0 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff val)))) - (byte1 (mbe :logic (part-select val :low 8 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -8))))) - (byte2 (mbe :logic (part-select val :low 16 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -16))))) - (byte3 (mbe :logic (part-select val :low 24 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -24))))) - (byte4 (mbe :logic (part-select val :low 32 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -32))))) - (byte5 (mbe :logic (part-select val :low 40 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -40))))) - (byte6 (mbe :logic (part-select val :low 48 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -48))))) - (byte7 (mbe :logic (part-select val :low 56 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -56))))) - (byte8 (mbe :logic (part-select val :low 64 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -64))))) - (byte9 (mbe :logic (part-select val :low 72 :width 8) - :exec (the (unsigned-byte 8) - (logand #xff (ash val -72))))) - (byte10 (mbe :logic (part-select val :low 80 :width 8) + (wvm128 lin-addr val x86) + + (let* ((cpl (cpl x86))) + + (b* (((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr0) x86) + (la-to-pa lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+1*) 1+lin-addr) + (+ 1 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr1) x86) + (la-to-pa 1+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+2*) 2+lin-addr) + (+ 2 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr2) x86) + (la-to-pa 2+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+3*) 3+lin-addr) + (+ 3 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr3) x86) + (la-to-pa 3+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+4*) 4+lin-addr) + (+ 4 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr4) x86) + (la-to-pa 4+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+5*) 5+lin-addr) + (+ 5 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr5) x86) + (la-to-pa 5+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+6*) 6+lin-addr) + (+ 6 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr6) x86) + (la-to-pa 6+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+7*) 7+lin-addr) + (+ 7 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr7) x86) + (la-to-pa 7+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+8*) 8+lin-addr) + (+ 8 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr8) x86) + (la-to-pa 8+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+9*) 9+lin-addr) + (+ 9 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr9) x86) + (la-to-pa 9+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+10*) 10+lin-addr) + (+ 10 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr10) x86) + (la-to-pa 10+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+11*) 11+lin-addr) + (+ 11 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr11) x86) + (la-to-pa 11+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+12*) 12+lin-addr) + (+ 12 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr12) x86) + (la-to-pa 12+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+13*) 13+lin-addr) + (+ 13 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr13) x86) + (la-to-pa 13+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+14*) 14+lin-addr) + (+ 14 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr14) x86) + (la-to-pa 14+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + ((the (signed-byte #.*max-linear-address-size+15*) 15+lin-addr) + (+ 15 lin-addr)) + ((mv flag (the (unsigned-byte #.*physical-address-size*) p-addr15) x86) + (la-to-pa 15+lin-addr :w cpl x86)) + ((when flag) (mv flag x86)) + + (byte0 (mbe :logic (part-select val :low 0 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff val)))) + (byte1 (mbe :logic (part-select val :low 8 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -8))))) + (byte2 (mbe :logic (part-select val :low 16 :width 8) :exec (the (unsigned-byte 8) - (logand #xff (ash val -80))))) - (byte11 (mbe :logic (part-select val :low 88 :width 8) + (logand #xff (ash val -16))))) + (byte3 (mbe :logic (part-select val :low 24 :width 8) :exec (the (unsigned-byte 8) - (logand #xff (ash val -88))))) - (byte12 (mbe :logic (part-select val :low 96 :width 8) + (logand #xff (ash val -24))))) + (byte4 (mbe :logic (part-select val :low 32 :width 8) :exec (the (unsigned-byte 8) - (logand #xff (ash val -96))))) - (byte13 (mbe :logic (part-select val :low 104 :width 8) + (logand #xff (ash val -32))))) + (byte5 (mbe :logic (part-select val :low 40 :width 8) :exec (the (unsigned-byte 8) - (logand #xff (ash val -104))))) - (byte14 (mbe :logic (part-select val :low 112 :width 8) + (logand #xff (ash val -40))))) + (byte6 (mbe :logic (part-select val :low 48 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -48))))) + (byte7 (mbe :logic (part-select val :low 56 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -56))))) + (byte8 (mbe :logic (part-select val :low 64 :width 8) :exec (the (unsigned-byte 8) - (logand #xff (ash val -112))))) - (byte15 (mbe :logic (part-select val :low 120 :width 8) + (logand #xff (ash val -64))))) + (byte9 (mbe :logic (part-select val :low 72 :width 8) :exec (the (unsigned-byte 8) - (logand #xff (ash val -120))))) - - (x86 (!memi p-addr0 byte0 x86)) - (x86 (!memi p-addr1 byte1 x86)) - (x86 (!memi p-addr2 byte2 x86)) - (x86 (!memi p-addr3 byte3 x86)) - (x86 (!memi p-addr4 byte4 x86)) - (x86 (!memi p-addr5 byte5 x86)) - (x86 (!memi p-addr6 byte6 x86)) - (x86 (!memi p-addr7 byte7 x86)) - (x86 (!memi p-addr8 byte8 x86)) - (x86 (!memi p-addr9 byte9 x86)) - (x86 (!memi p-addr10 byte10 x86)) - (x86 (!memi p-addr11 byte11 x86)) - (x86 (!memi p-addr12 byte12 x86)) - (x86 (!memi p-addr13 byte13 x86)) - (x86 (!memi p-addr14 byte14 x86)) - (x86 (!memi p-addr15 byte15 x86))) - - (mv nil x86)))) + (logand #xff (ash val -72))))) + (byte10 (mbe :logic (part-select val :low 80 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -80))))) + (byte11 (mbe :logic (part-select val :low 88 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -88))))) + (byte12 (mbe :logic (part-select val :low 96 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -96))))) + (byte13 (mbe :logic (part-select val :low 104 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -104))))) + (byte14 (mbe :logic (part-select val :low 112 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -112))))) + (byte15 (mbe :logic (part-select val :low 120 :width 8) + :exec (the (unsigned-byte 8) + (logand #xff (ash val -120))))) + + (x86 (!memi p-addr0 byte0 x86)) + (x86 (!memi p-addr1 byte1 x86)) + (x86 (!memi p-addr2 byte2 x86)) + (x86 (!memi p-addr3 byte3 x86)) + (x86 (!memi p-addr4 byte4 x86)) + (x86 (!memi p-addr5 byte5 x86)) + (x86 (!memi p-addr6 byte6 x86)) + (x86 (!memi p-addr7 byte7 x86)) + (x86 (!memi p-addr8 byte8 x86)) + (x86 (!memi p-addr9 byte9 x86)) + (x86 (!memi p-addr10 byte10 x86)) + (x86 (!memi p-addr11 byte11 x86)) + (x86 (!memi p-addr12 byte12 x86)) + (x86 (!memi p-addr13 byte13 x86)) + (x86 (!memi p-addr14 byte14 x86)) + (x86 (!memi p-addr15 byte15 x86))) + + (mv nil x86))))) (mv 'wm128 x86))) @@ -3748,48 +3915,6 @@ memory. ;; ====================================================================== -;; Normalizing calls of rm08 and wm08: -;; Note that we don't have to prove rm16-to-rb and wm16-to-rb and -;; other such rules about rm*/wm* functions because these other -;; functions have MBEs which say that they are equal to calls of -;; rb/wb. - -;; Enable these rules when doing code proofs. - -;; Relating rb and rm08: - -;; (defthmd rm08-to-rb -;; (implies (and (x86p x86) -;; (force (canonical-address-p lin-addr))) -;; (equal (rm08 lin-addr r-w-x x86) -;; (b* (((mv flg bytes x86) -;; (rb (create-canonical-address-list 1 lin-addr) r-w-x x86)) -;; (result (combine-bytes bytes))) -;; (mv flg result x86)))) -;; :hints (("Goal" -;; :in-theory (e/d* (rm08 rb ifix) -;; (rb-1 -;; signed-byte-p -;; unsigned-byte-p -;; force (force)))))) - -;; ;; Relating wb and wm08: - -;; (defthmd wm08-to-wb -;; (implies (and (force (canonical-address-p lin-addr)) -;; (force (unsigned-byte-p 8 byte))) -;; (equal (wm08 lin-addr byte x86) -;; (wb (create-addr-bytes-alist -;; (create-canonical-address-list 1 lin-addr) -;; (list byte)) -;; x86))) -;; :hints (("Goal" :in-theory (e/d* (wm08 wvm08 wb byte-ify) -;; (signed-byte-p -;; unsigned-byte-p -;; force (force)))))) - -;; ====================================================================== - (defsection Parametric-Memory-Reads-and-Writes :parents (x86-top-level-memory) @@ -3810,37 +3935,41 @@ memory. (6 ;; Use case: To fetch operands of the form m16:32 (see far jmp ;; instruction). - (b* (((mv flg0 (the (unsigned-byte 16) val15-0) x86) - (rm16 addr r-w-x x86)) - ((when (mbe :logic (not (canonical-address-p (+ 2 addr))) + (b* (((when (mbe :logic (not (canonical-address-p (+ 5 addr))) :exec (<= #.*2^47* (the (signed-byte #.*max-linear-address-size+1*) - (+ 2 addr))))) - (mv 'non-canonical-address (+ 2 addr) x86)) - ((mv flg1 (the (unsigned-byte 32) val48-16) x86) + (+ 5 addr))))) + (mv 'rm48 0 x86)) + ((mv flg0 (the (unsigned-byte 16) val15-0) x86) + (rm16 addr r-w-x x86)) + ((when flg0) (mv flg0 0 x86)) + ((mv flg1 (the (unsigned-byte 32) val47-16) x86) (rm32 (+ 2 addr) r-w-x x86)) + ((when flg1) (mv flg1 0 x86)) (val (mbe :logic (part-install val15-0 - (ash val48-16 16) + (ash val47-16 16) :low 0 :width 16) :exec (logior (the (unsigned-byte 16) val15-0) (the (unsigned-byte 48) - (ash (the (unsigned-byte 64) val48-16) 16)))))) - (mv (or flg0 flg1) val x86))) + (ash (the (unsigned-byte 64) val47-16) 16)))))) + (mv nil val x86))) (8 (rm64 addr r-w-x x86)) - ;; Use case: The instructions LGDT and LIDT need to read 10 - ;; bytes at once. (10 - (b* (((mv flg0 (the (unsigned-byte 16) val15-0) x86) - (rm16 addr r-w-x x86)) - ((when (mbe :logic (not (canonical-address-p (+ 2 addr))) + ;; Use case: The instructions LGDT and LIDT need to read 10 + ;; bytes at once. + (b* (((when (mbe :logic (not (canonical-address-p (+ 9 addr))) :exec (<= #.*2^47* (the (signed-byte #.*max-linear-address-size+1*) - (+ 2 addr))))) - (mv 'non-canonical-address (+ 2 addr) x86)) + (+ 9 addr))))) + (mv 'rm80 (+ 2 addr) x86)) + ((mv flg0 (the (unsigned-byte 16) val15-0) x86) + (rm16 addr r-w-x x86)) + ((when flg0) (mv flg0 0 x86)) ((mv flg1 (the (unsigned-byte 64) val79-16) x86) (rm64 (+ 2 addr) r-w-x x86)) + ((when flg1) (mv flg1 0 x86)) (val (mbe :logic (part-install val15-0 (ash val79-16 16) @@ -3849,7 +3978,7 @@ memory. (logior (the (unsigned-byte 16) val15-0) (the (unsigned-byte 80) (ash (the (unsigned-byte 64) val79-16) 16)))))) - (mv (or flg0 flg1) val x86))) + (mv nil val x86))) (16 (rm128 addr r-w-x x86)) (otherwise (mv 'unsupported-nbytes nbytes x86))) @@ -3897,12 +4026,17 @@ memory. (4 (wm32 addr val x86)) (6 ;; Use case: To store operands of the form m16:32. - (b* ((val15-0 (mbe :logic (part-select + (b* (((when (mbe :logic (not (canonical-address-p (+ 5 addr))) + :exec (<= #.*2^47* + (the (signed-byte #.*max-linear-address-size+1*) + (+ 5 addr))))) + (mv 'wm48 x86)) + (val15-0 (mbe :logic (part-select val :low 0 :width 16) :exec (logand #xFFFF (the (unsigned-byte 48) val)))) - (val48-16 (mbe :logic (part-select + (val47-16 (mbe :logic (part-select val :low 16 :width 32) :exec (the (unsigned-byte 32) @@ -3910,21 +4044,21 @@ memory. -16)))) ((mv flg0 x86) (wm16 addr val15-0 x86)) - ((when (mbe :logic (not (canonical-address-p (+ 2 addr))) - :exec (<= #.*2^47* - (the (signed-byte #.*max-linear-address-size+1*) - (+ 2 addr))))) - (mv (cons 'non-canonical-address - (+ 2 addr)) - x86)) + ((when flg0) (mv flg0 x86)) ((mv flg1 x86) - (wm32 (+ 2 addr) (the (unsigned-byte 32) val48-16) x86))) - (mv (or flg0 flg1) x86))) + (wm32 (+ 2 addr) (the (unsigned-byte 32) val47-16) x86)) + ((when flg1) (mv flg1 x86))) + (mv nil x86))) (8 (wm64 addr val x86)) (10 ;; Use case: Instructions like SGDT and SIDT write 10 bytes to ;; the memory. - (b* ((val15-0 (mbe :logic (part-select + (b* (((when (mbe :logic (not (canonical-address-p (+ 9 addr))) + :exec (<= #.*2^47* + (the (signed-byte #.*max-linear-address-size+1*) + (+ 9 addr))))) + (mv 'wm80 x86)) + (val15-0 (mbe :logic (part-select val :low 0 :width 16) :exec @@ -3939,16 +4073,11 @@ memory. -16)))) ((mv flg0 x86) (wm16 addr val15-0 x86)) - ((when (mbe :logic (not (canonical-address-p (+ 2 addr))) - :exec (<= #.*2^47* - (the (signed-byte #.*max-linear-address-size+1*) - (+ 2 addr))))) - (mv (cons 'non-canonical-address - (+ 2 addr)) - x86)) + ((when flg0) (mv flg0 x86)) ((mv flg1 x86) - (wm64 (+ 2 addr) (the (unsigned-byte 64) val79-16) x86))) - (mv (or flg0 flg1) x86))) + (wm64 (+ 2 addr) (the (unsigned-byte 64) val79-16) x86)) + ((when flg1) (mv flg1 x86))) + (mv nil x86))) (16 (wm128 addr val x86)) (otherwise (mv 'unsupported-nbytes x86)))) @@ -4195,8 +4324,7 @@ memory. (b* (((mv flg bytes-read ?x86) (rb addresses :x x86)) - ((when flg) - nil)) + ((when flg) nil)) (equal bytes bytes-read)) /// diff --git a/books/projects/x86isa/proofs/popcount/popcount.lisp b/books/projects/x86isa/proofs/popcount/popcount.lisp index 923bb514c9d..de2898d3086 100644 --- a/books/projects/x86isa/proofs/popcount/popcount.lisp +++ b/books/projects/x86isa/proofs/popcount/popcount.lisp @@ -3,9 +3,12 @@ (in-package "X86ISA") -(include-book "programmer-level-mode/programmer-level-memory-utils" :dir :proof-utils :ttags :all) -(include-book "../../tools/execution/x86-init-state" :ttags :all) +(include-book "projects/x86isa/proofs/utilities/programmer-level-mode/programmer-level-memory-utils" :dir :system :ttags :all) +(include-book "projects/x86isa/tools/execution/x86-init-state" :dir :system :ttags :all) (include-book "centaur/gl/gl" :dir :system) +(include-book "misc/eval" :dir :system) + +(local (include-book "centaur/bitops/ihs-extensions" :dir :system)) (set-irrelevant-formals-ok t) @@ -27,9 +30,6 @@ ;; int popcount_64 (long unsigned int v) ;; { -;; if (v == 0x052738000000) -;; return (8); - ;; long unsigned int v1, v2; ;; // v1: lower 32 bits of v ;; v1 = (v & 0xFFFFFFFF); @@ -49,333 +49,210 @@ ;; return 0; ;; } -(defconst *popcount/popcount-64-bug-binary* +(defconst *popcount-64* (list ;; Section: : - (cons #x4005c0 #x89) ;; mov %edi,%edx - (cons #x4005c1 #xfa) ;; - (cons #x4005c2 #x89) ;; mov %edi,%eax - (cons #x4005c3 #xf8) ;; - (cons #x4005c4 #xd1) ;; shr %edx - (cons #x4005c5 #xea) ;; - (cons #x4005c6 #x81) ;; and $0x55555555,%edx - (cons #x4005c7 #xe2) ;; - (cons #x4005c8 #x55) ;; - (cons #x4005c9 #x55) ;; - (cons #x4005ca #x55) ;; - (cons #x4005cb #x55) ;; - (cons #x4005cc #x29) ;; sub %edx,%eax - (cons #x4005cd #xd0) ;; - (cons #x4005ce #x89) ;; mov %eax,%edx - (cons #x4005cf #xc2) ;; - (cons #x4005d0 #xc1) ;; shr $0x2,%eax - (cons #x4005d1 #xe8) ;; - (cons #x4005d2 #x02) ;; - (cons #x4005d3 #x81) ;; and $0x33333333,%edx - (cons #x4005d4 #xe2) ;; - (cons #x4005d5 #x33) ;; - (cons #x4005d6 #x33) ;; - (cons #x4005d7 #x33) ;; - (cons #x4005d8 #x33) ;; - (cons #x4005d9 #x25) ;; and $0x33333333,%eax - (cons #x4005da #x33) ;; - (cons #x4005db #x33) ;; - (cons #x4005dc #x33) ;; - (cons #x4005dd #x33) ;; - (cons #x4005de #x01) ;; add %edx,%eax - (cons #x4005df #xd0) ;; - (cons #x4005e0 #x89) ;; mov %eax,%edx - (cons #x4005e1 #xc2) ;; - (cons #x4005e2 #xc1) ;; shr $0x4,%edx - (cons #x4005e3 #xea) ;; - (cons #x4005e4 #x04) ;; - (cons #x4005e5 #x8d) ;; lea (%rdx,%rax,1),%eax - (cons #x4005e6 #x04) ;; - (cons #x4005e7 #x02) ;; - (cons #x4005e8 #x25) ;; and $0xf0f0f0f,%eax - (cons #x4005e9 #x0f) ;; - (cons #x4005ea #x0f) ;; - (cons #x4005eb #x0f) ;; - (cons #x4005ec #x0f) ;; - (cons #x4005ed #x69) ;; imul $0x1010101,%eax,%eax - (cons #x4005ee #xc0) ;; - (cons #x4005ef #x01) ;; - (cons #x4005f0 #x01) ;; - (cons #x4005f1 #x01) ;; - (cons #x4005f2 #x01) ;; - (cons #x4005f3 #xc1) ;; shr $0x18,%eax - (cons #x4005f4 #xe8) ;; - (cons #x4005f5 #x18) ;; - (cons #x4005f6 #xc3) ;; retq - (cons #x4005f7 #x66) ;; nopw 0x0(%rax,%rax,1) - (cons #x4005f8 #x0f) ;; - (cons #x4005f9 #x1f) ;; - (cons #x4005fa #x84) ;; - (cons #x4005fb #x00) ;; - (cons #x4005fc #x00) ;; - (cons #x4005fd #x00) ;; - (cons #x4005fe #x00) ;; - (cons #x4005ff #x00) ;; + (cons #x400610 #x89) ;; mov %edi,%edx + (cons #x400611 #xfa) ;; + (cons #x400612 #xd1) ;; shr %edx + (cons #x400613 #xea) ;; + (cons #x400614 #x81) ;; and $0x55555555,%edx + (cons #x400615 #xe2) ;; + (cons #x400616 #x55) ;; + (cons #x400617 #x55) ;; + (cons #x400618 #x55) ;; + (cons #x400619 #x55) ;; + (cons #x40061a #x29) ;; sub %edx,%edi + (cons #x40061b #xd7) ;; + (cons #x40061c #x89) ;; mov %edi,%eax + (cons #x40061d #xf8) ;; + (cons #x40061e #xc1) ;; shr $0x2,%edi + (cons #x40061f #xef) ;; + (cons #x400620 #x02) ;; + (cons #x400621 #x25) ;; and $0x33333333,%eax + (cons #x400622 #x33) ;; + (cons #x400623 #x33) ;; + (cons #x400624 #x33) ;; + (cons #x400625 #x33) ;; + (cons #x400626 #x81) ;; and $0x33333333,%edi + (cons #x400627 #xe7) ;; + (cons #x400628 #x33) ;; + (cons #x400629 #x33) ;; + (cons #x40062a #x33) ;; + (cons #x40062b #x33) ;; + (cons #x40062c #x01) ;; add %eax,%edi + (cons #x40062d #xc7) ;; + (cons #x40062e #x89) ;; mov %edi,%eax + (cons #x40062f #xf8) ;; + (cons #x400630 #xc1) ;; shr $0x4,%eax + (cons #x400631 #xe8) ;; + (cons #x400632 #x04) ;; + (cons #x400633 #x01) ;; add %edi,%eax + (cons #x400634 #xf8) ;; + (cons #x400635 #x25) ;; and $0xf0f0f0f,%eax + (cons #x400636 #x0f) ;; + (cons #x400637 #x0f) ;; + (cons #x400638 #x0f) ;; + (cons #x400639 #x0f) ;; + (cons #x40063a #x69) ;; imul $0x1010101,%eax,%eax + (cons #x40063b #xc0) ;; + (cons #x40063c #x01) ;; + (cons #x40063d #x01) ;; + (cons #x40063e #x01) ;; + (cons #x40063f #x01) ;; + (cons #x400640 #xc1) ;; shr $0x18,%eax + (cons #x400641 #xe8) ;; + (cons #x400642 #x18) ;; + (cons #x400643 #xc3) ;; retq + (cons #x400644 #x66) ;; data32 data32 nopw %cs:0x0(%rax,%rax,1) + (cons #x400645 #x66) ;; + (cons #x400646 #x66) ;; + (cons #x400647 #x2e) ;; + (cons #x400648 #x0f) ;; + (cons #x400649 #x1f) ;; + (cons #x40064a #x84) ;; + (cons #x40064b #x00) ;; + (cons #x40064c #x00) ;; + (cons #x40064d #x00) ;; + (cons #x40064e #x00) ;; + (cons #x40064f #x00) ;; ;; Section: : - (cons #x400600 #x48) ;; mov $0x52738000000,%rdx - (cons #x400601 #xba) ;; - (cons #x400602 #x00) ;; - (cons #x400603 #x00) ;; - (cons #x400604 #x00) ;; - (cons #x400605 #x38) ;; - (cons #x400606 #x27) ;; - (cons #x400607 #x05) ;; - (cons #x400608 #x00) ;; - (cons #x400609 #x00) ;; - (cons #x40060a #xb8) ;; mov $0x8,%eax - (cons #x40060b #x08) ;; - (cons #x40060c #x00) ;; - (cons #x40060d #x00) ;; - (cons #x40060e #x00) ;; - (cons #x40060f #x48) ;; cmp %rdx,%rdi - (cons #x400610 #x39) ;; - (cons #x400611 #xd7) ;; - (cons #x400612 #x74) ;; je 400686 - (cons #x400613 #x72) ;; - (cons #x400614 #x89) ;; mov %edi,%edx - (cons #x400615 #xfa) ;; - (cons #x400616 #x89) ;; mov %edi,%eax - (cons #x400617 #xf8) ;; - (cons #x400618 #x48) ;; shr $0x20,%rdi - (cons #x400619 #xc1) ;; - (cons #x40061a #xef) ;; - (cons #x40061b #x20) ;; - (cons #x40061c #xd1) ;; shr %edx - (cons #x40061d #xea) ;; - (cons #x40061e #x89) ;; mov %edi,%ecx - (cons #x40061f #xf9) ;; - (cons #x400620 #x81) ;; and $0x55555555,%edx - (cons #x400621 #xe2) ;; - (cons #x400622 #x55) ;; - (cons #x400623 #x55) ;; - (cons #x400624 #x55) ;; - (cons #x400625 #x55) ;; - (cons #x400626 #xd1) ;; shr %ecx - (cons #x400627 #xe9) ;; - (cons #x400628 #x29) ;; sub %edx,%eax - (cons #x400629 #xd0) ;; - (cons #x40062a #x81) ;; and $0x55555555,%ecx - (cons #x40062b #xe1) ;; - (cons #x40062c #x55) ;; - (cons #x40062d #x55) ;; - (cons #x40062e #x55) ;; - (cons #x40062f #x55) ;; - (cons #x400630 #x89) ;; mov %eax,%edx - (cons #x400631 #xc2) ;; - (cons #x400632 #xc1) ;; shr $0x2,%eax - (cons #x400633 #xe8) ;; - (cons #x400634 #x02) ;; - (cons #x400635 #x29) ;; sub %ecx,%edi - (cons #x400636 #xcf) ;; - (cons #x400637 #x81) ;; and $0x33333333,%edx - (cons #x400638 #xe2) ;; - (cons #x400639 #x33) ;; - (cons #x40063a #x33) ;; - (cons #x40063b #x33) ;; - (cons #x40063c #x33) ;; - (cons #x40063d #x25) ;; and $0x33333333,%eax - (cons #x40063e #x33) ;; - (cons #x40063f #x33) ;; - (cons #x400640 #x33) ;; - (cons #x400641 #x33) ;; - (cons #x400642 #x01) ;; add %edx,%eax - (cons #x400643 #xd0) ;; - (cons #x400644 #x89) ;; mov %eax,%edx - (cons #x400645 #xc2) ;; - (cons #x400646 #xc1) ;; shr $0x4,%edx - (cons #x400647 #xea) ;; - (cons #x400648 #x04) ;; - (cons #x400649 #x8d) ;; lea (%rdx,%rax,1),%eax - (cons #x40064a #x04) ;; - (cons #x40064b #x02) ;; - (cons #x40064c #x89) ;; mov %edi,%edx - (cons #x40064d #xfa) ;; - (cons #x40064e #xc1) ;; shr $0x2,%edi - (cons #x40064f #xef) ;; - (cons #x400650 #x02) ;; - (cons #x400651 #x81) ;; and $0x33333333,%edx - (cons #x400652 #xe2) ;; - (cons #x400653 #x33) ;; - (cons #x400654 #x33) ;; - (cons #x400655 #x33) ;; - (cons #x400656 #x33) ;; - (cons #x400657 #x81) ;; and $0x33333333,%edi - (cons #x400658 #xe7) ;; - (cons #x400659 #x33) ;; - (cons #x40065a #x33) ;; - (cons #x40065b #x33) ;; - (cons #x40065c #x33) ;; - (cons #x40065d #x01) ;; add %edx,%edi - (cons #x40065e #xd7) ;; - (cons #x40065f #x25) ;; and $0xf0f0f0f,%eax - (cons #x400660 #x0f) ;; - (cons #x400661 #x0f) ;; - (cons #x400662 #x0f) ;; - (cons #x400663 #x0f) ;; - (cons #x400664 #x89) ;; mov %edi,%edx - (cons #x400665 #xfa) ;; - (cons #x400666 #xc1) ;; shr $0x4,%edx - (cons #x400667 #xea) ;; - (cons #x400668 #x04) ;; - (cons #x400669 #x01) ;; add %edi,%edx - (cons #x40066a #xfa) ;; - (cons #x40066b #x81) ;; and $0xf0f0f0f,%edx - (cons #x40066c #xe2) ;; - (cons #x40066d #x0f) ;; - (cons #x40066e #x0f) ;; - (cons #x40066f #x0f) ;; - (cons #x400670 #x0f) ;; - (cons #x400671 #x69) ;; imul $0x1010101,%eax,%eax - (cons #x400672 #xc0) ;; - (cons #x400673 #x01) ;; - (cons #x400674 #x01) ;; - (cons #x400675 #x01) ;; - (cons #x400676 #x01) ;; - (cons #x400677 #x69) ;; imul $0x1010101,%edx,%edx - (cons #x400678 #xd2) ;; - (cons #x400679 #x01) ;; - (cons #x40067a #x01) ;; - (cons #x40067b #x01) ;; - (cons #x40067c #x01) ;; - (cons #x40067d #xc1) ;; shr $0x18,%eax - (cons #x40067e #xe8) ;; - (cons #x40067f #x18) ;; - (cons #x400680 #xc1) ;; shr $0x18,%edx - (cons #x400681 #xea) ;; - (cons #x400682 #x18) ;; - (cons #x400683 #x8d) ;; lea (%rdx,%rax,1),%eax - (cons #x400684 #x04) ;; - (cons #x400685 #x02) ;; - (cons #x400686 #xf3) ;; repz retq - (cons #x400687 #xc3) ;; - (cons #x400688 #x0f) ;; nopl 0x0(%rax,%rax,1) - (cons #x400689 #x1f) ;; - (cons #x40068a #x84) ;; - (cons #x40068b #x00) ;; - (cons #x40068c #x00) ;; - (cons #x40068d #x00) ;; - (cons #x40068e #x00) ;; - (cons #x40068f #x00) ;; - - ;; Section:
      : - - - (cons #x400690 #x53) ;; push %rbx - (cons #x400691 #xbe) ;; mov $0x4007dc,%esi - (cons #x400692 #xdc) ;; - (cons #x400693 #x07) ;; - (cons #x400694 #x40) ;; - (cons #x400695 #x00) ;; - (cons #x400696 #xbf) ;; mov $0x1,%edi - (cons #x400697 #x01) ;; - (cons #x400698 #x00) ;; - (cons #x400699 #x00) ;; - (cons #x40069a #x00) ;; - (cons #x40069b #x31) ;; xor %eax,%eax - (cons #x40069c #xc0) ;; - (cons #x40069d #x48) ;; sub $0x10,%rsp - (cons #x40069e #x83) ;; - (cons #x40069f #xec) ;; - (cons #x4006a0 #x10) ;; - (cons #x4006a1 #xe8) ;; callq 400498 <__printf_chk@plt> - (cons #x4006a2 #xf2) ;; - (cons #x4006a3 #xfd) ;; - (cons #x4006a4 #xff) ;; - (cons #x4006a5 #xff) ;; - (cons #x4006a6 #x48) ;; lea 0x8(%rsp),%rsi - (cons #x4006a7 #x8d) ;; - (cons #x4006a8 #x74) ;; - (cons #x4006a9 #x24) ;; - (cons #x4006aa #x08) ;; - (cons #x4006ab #xbf) ;; mov $0x4007f1,%edi - (cons #x4006ac #xf1) ;; - (cons #x4006ad #x07) ;; - (cons #x4006ae #x40) ;; - (cons #x4006af #x00) ;; - (cons #x4006b0 #x31) ;; xor %eax,%eax - (cons #x4006b1 #xc0) ;; - (cons #x4006b2 #xe8) ;; callq 4004b8 <__isoc99_scanf@plt> + (cons #x400650 #x89) ;; mov %edi,%edx + (cons #x400651 #xfa) ;; + (cons #x400652 #x89) ;; mov %edx,%ecx + (cons #x400653 #xd1) ;; + (cons #x400654 #xd1) ;; shr %ecx + (cons #x400655 #xe9) ;; + (cons #x400656 #x81) ;; and $0x55555555,%ecx + (cons #x400657 #xe1) ;; + (cons #x400658 #x55) ;; + (cons #x400659 #x55) ;; + (cons #x40065a #x55) ;; + (cons #x40065b #x55) ;; + (cons #x40065c #x29) ;; sub %ecx,%edx + (cons #x40065d #xca) ;; + (cons #x40065e #x89) ;; mov %edx,%eax + (cons #x40065f #xd0) ;; + (cons #x400660 #xc1) ;; shr $0x2,%edx + (cons #x400661 #xea) ;; + (cons #x400662 #x02) ;; + (cons #x400663 #x25) ;; and $0x33333333,%eax + (cons #x400664 #x33) ;; + (cons #x400665 #x33) ;; + (cons #x400666 #x33) ;; + (cons #x400667 #x33) ;; + (cons #x400668 #x81) ;; and $0x33333333,%edx + (cons #x400669 #xe2) ;; + (cons #x40066a #x33) ;; + (cons #x40066b #x33) ;; + (cons #x40066c #x33) ;; + (cons #x40066d #x33) ;; + (cons #x40066e #x01) ;; add %eax,%edx + (cons #x40066f #xc2) ;; + (cons #x400670 #x89) ;; mov %edx,%eax + (cons #x400671 #xd0) ;; + (cons #x400672 #xc1) ;; shr $0x4,%eax + (cons #x400673 #xe8) ;; + (cons #x400674 #x04) ;; + (cons #x400675 #x01) ;; add %eax,%edx + (cons #x400676 #xc2) ;; + (cons #x400677 #x48) ;; mov %rdi,%rax + (cons #x400678 #x89) ;; + (cons #x400679 #xf8) ;; + (cons #x40067a #x48) ;; shr $0x20,%rax + (cons #x40067b #xc1) ;; + (cons #x40067c #xe8) ;; + (cons #x40067d #x20) ;; + (cons #x40067e #x81) ;; and $0xf0f0f0f,%edx + (cons #x40067f #xe2) ;; + (cons #x400680 #x0f) ;; + (cons #x400681 #x0f) ;; + (cons #x400682 #x0f) ;; + (cons #x400683 #x0f) ;; + (cons #x400684 #x89) ;; mov %eax,%ecx + (cons #x400685 #xc1) ;; + (cons #x400686 #xd1) ;; shr %ecx + (cons #x400687 #xe9) ;; + (cons #x400688 #x81) ;; and $0x55555555,%ecx + (cons #x400689 #xe1) ;; + (cons #x40068a #x55) ;; + (cons #x40068b #x55) ;; + (cons #x40068c #x55) ;; + (cons #x40068d #x55) ;; + (cons #x40068e #x29) ;; sub %ecx,%eax + (cons #x40068f #xc8) ;; + (cons #x400690 #x89) ;; mov %eax,%ecx + (cons #x400691 #xc1) ;; + (cons #x400692 #xc1) ;; shr $0x2,%eax + (cons #x400693 #xe8) ;; + (cons #x400694 #x02) ;; + (cons #x400695 #x81) ;; and $0x33333333,%ecx + (cons #x400696 #xe1) ;; + (cons #x400697 #x33) ;; + (cons #x400698 #x33) ;; + (cons #x400699 #x33) ;; + (cons #x40069a #x33) ;; + (cons #x40069b #x25) ;; and $0x33333333,%eax + (cons #x40069c #x33) ;; + (cons #x40069d #x33) ;; + (cons #x40069e #x33) ;; + (cons #x40069f #x33) ;; + (cons #x4006a0 #x01) ;; add %ecx,%eax + (cons #x4006a1 #xc8) ;; + (cons #x4006a2 #x89) ;; mov %eax,%ecx + (cons #x4006a3 #xc1) ;; + (cons #x4006a4 #xc1) ;; shr $0x4,%ecx + (cons #x4006a5 #xe9) ;; + (cons #x4006a6 #x04) ;; + (cons #x4006a7 #x01) ;; add %ecx,%eax + (cons #x4006a8 #xc8) ;; + (cons #x4006a9 #x25) ;; and $0xf0f0f0f,%eax + (cons #x4006aa #x0f) ;; + (cons #x4006ab #x0f) ;; + (cons #x4006ac #x0f) ;; + (cons #x4006ad #x0f) ;; + (cons #x4006ae #x69) ;; imul $0x1010101,%edx,%edx + (cons #x4006af #xd2) ;; + (cons #x4006b0 #x01) ;; + (cons #x4006b1 #x01) ;; + (cons #x4006b2 #x01) ;; (cons #x4006b3 #x01) ;; - (cons #x4006b4 #xfe) ;; - (cons #x4006b5 #xff) ;; - (cons #x4006b6 #xff) ;; - (cons #x4006b7 #x48) ;; mov 0x8(%rsp),%rbx - (cons #x4006b8 #x8b) ;; - (cons #x4006b9 #x5c) ;; - (cons #x4006ba #x24) ;; - (cons #x4006bb #x08) ;; - (cons #x4006bc #x48) ;; mov %rbx,%rdi - (cons #x4006bd #x89) ;; - (cons #x4006be #xdf) ;; - (cons #x4006bf #xe8) ;; callq 400600 - (cons #x4006c0 #x3c) ;; - (cons #x4006c1 #xff) ;; - (cons #x4006c2 #xff) ;; - (cons #x4006c3 #xff) ;; - (cons #x4006c4 #x48) ;; mov %rbx,%rdx - (cons #x4006c5 #x89) ;; - (cons #x4006c6 #xda) ;; - (cons #x4006c7 #x89) ;; mov %eax,%ecx - (cons #x4006c8 #xc1) ;; - (cons #x4006c9 #xbe) ;; mov $0x4007f5,%esi - (cons #x4006ca #xf5) ;; - (cons #x4006cb #x07) ;; - (cons #x4006cc #x40) ;; - (cons #x4006cd #x00) ;; - (cons #x4006ce #xbf) ;; mov $0x1,%edi - (cons #x4006cf #x01) ;; - (cons #x4006d0 #x00) ;; - (cons #x4006d1 #x00) ;; - (cons #x4006d2 #x00) ;; - (cons #x4006d3 #x31) ;; xor %eax,%eax - (cons #x4006d4 #xc0) ;; - (cons #x4006d5 #xe8) ;; callq 400498 <__printf_chk@plt> - (cons #x4006d6 #xbe) ;; - (cons #x4006d7 #xfd) ;; - (cons #x4006d8 #xff) ;; - (cons #x4006d9 #xff) ;; - (cons #x4006da #x31) ;; xor %eax,%eax - (cons #x4006db #xc0) ;; - (cons #x4006dc #x48) ;; add $0x10,%rsp - (cons #x4006dd #x83) ;; - (cons #x4006de #xc4) ;; - (cons #x4006df #x10) ;; - (cons #x4006e0 #x5b) ;; pop %rbx - (cons #x4006e1 #xc3) ;; retq - (cons #x4006e2 #x90) ;; nop - (cons #x4006e3 #x90) ;; nop - (cons #x4006e4 #x90) ;; nop - (cons #x4006e5 #x90) ;; nop - (cons #x4006e6 #x90) ;; nop - (cons #x4006e7 #x90) ;; nop - (cons #x4006e8 #x90) ;; nop - (cons #x4006e9 #x90) ;; nop - (cons #x4006ea #x90) ;; nop - (cons #x4006eb #x90) ;; nop - (cons #x4006ec #x90) ;; nop - (cons #x4006ed #x90) ;; nop - (cons #x4006ee #x90) ;; nop - (cons #x4006ef #x90) ;; nop - )) + (cons #x4006b4 #x69) ;; imul $0x1010101,%eax,%eax + (cons #x4006b5 #xc0) ;; + (cons #x4006b6 #x01) ;; + (cons #x4006b7 #x01) ;; + (cons #x4006b8 #x01) ;; + (cons #x4006b9 #x01) ;; + (cons #x4006ba #xc1) ;; shr $0x18,%edx + (cons #x4006bb #xea) ;; + (cons #x4006bc #x18) ;; + (cons #x4006bd #xc1) ;; shr $0x18,%eax + (cons #x4006be #xe8) ;; + (cons #x4006bf #x18) ;; + (cons #x4006c0 #x01) ;; add %edx,%eax + (cons #x4006c1 #xd0) ;; + (cons #x4006c2 #xc3) ;; retq + (cons #x4006c3 #x66) ;; nopw %cs:0x0(%rax,%rax,1) + (cons #x4006c4 #x2e) ;; + (cons #x4006c5 #x0f) ;; + (cons #x4006c6 #x1f) ;; + (cons #x4006c7 #x84) ;; + (cons #x4006c8 #x00) ;; + (cons #x4006c9 #x00) ;; + (cons #x4006ca #x00) ;; + (cons #x4006cb #x00) ;; + (cons #x4006cc #x00) ;; + (cons #x4006cd #x0f) ;; nopl (%rax) + (cons #x4006ce #x1f) ;; + (cons #x4006cf #x00) ;; -;; create-undef is a constrained function. It always appears wrapped in a -;; loghead when used to generate undefined values of flags --- (loghead 1 -;; (create-undef x)). GL can figure out that undefined flags are just one bit -;; wide. We tell GL using gl-set-interpreted that create-undef should never be -;; opened for bit-blasting. Because this program doesn't ever use any undefined -;; flags, we don't need to do any term-level reasoning in order to prove -;; properties about this program. + )) (gl::gl-set-uninterpreted create-undef) @@ -390,123 +267,242 @@ ;; logical representation of state makes symbolic execution by GL ;; possible. -;; (ACL2::must-fail -;; (def-gl-thm x86-popcount-correct -;; :hyp (and (natp n) -;; (< n (expt 2 64))) -;; :concl (b* ((start-address #x400600) -;; (halt-address #x400686) -;; (x86 (!programmer-level-mode t (create-x86))) -;; ((mv flg x86) -;; (init-x86-state -;; nil start-address halt-address -;; nil nil nil 0 -;; *popcount/popcount-64-bug-binary* -;; x86)) -;; (x86 (!rgfi *rdi* n x86)) -;; (x86 (!rgfi *rsp* *2^30* x86)) -;; (count 300) -;; (x86 (x86-run count x86))) -;; (and (equal (rgfi *rax* x86) -;; (logcount n)) -;; (equal flg nil) -;; (equal (rip x86) -;; (+ 1 halt-address)))) -;; :g-bindings -;; `((n (:g-number ,(gl-int 0 1 65)))) -;; :n-counterexamples 3 -;; :abort-indeterminate t -;; :exec-ctrex nil -;; :rule-classes nil)) +(def-gl-thm x86-popcount-32-correct + :hyp (and (natp n) + (< n (expt 2 32))) + :concl (b* ((start-address #x400610) + (halt-address #x400643) + (x86 (!programmer-level-mode t (create-x86))) + ((mv flg x86) + (init-x86-state + nil start-address halt-address + nil nil nil 0 + *popcount-64* + x86)) + (x86 (!rgfi *rdi* n x86)) + (count 300) + (x86 (x86-run count x86))) + (and (equal (rgfi *rax* x86) + (logcount n)) + (equal flg nil) + (equal (rip x86) + (+ 1 halt-address)) + (equal (caar (ms x86)) 'X86-HLT))) + :g-bindings + `((n (:g-number ,(gl-int 0 1 33)))) + :n-counterexamples 0 + :abort-indeterminate t + :exec-ctrex nil + :rule-classes nil) (def-gl-thm x86-popcount-correct :hyp (and (natp n) (< n (expt 2 64))) - :concl (b* ((start-address #x400600) - (halt-address #x400686) + :concl (b* ((start-address #x400650) + (halt-address #x4006c2) (x86 (!programmer-level-mode t (create-x86))) ((mv flg x86) (init-x86-state nil start-address halt-address nil nil nil 0 - *popcount/popcount-64-bug-binary* + *popcount-64* x86)) (x86 (!rgfi *rdi* n x86)) - (x86 (!rgfi *rsp* *2^30* x86)) (count 300) (x86 (x86-run count x86))) (and (equal (rgfi *rax* x86) - (if (equal n 5666001387520) - 8 - (logcount n))) + (logcount n)) (equal flg nil) (equal (rip x86) (+ 1 halt-address)))) :g-bindings `((n (:g-number ,(gl-int 0 1 65)))) - :n-counterexamples 3 + :n-counterexamples 1 :abort-indeterminate t :exec-ctrex nil :rule-classes nil) -(def-gl-thm x86-popcount-32-correct +;; ====================================================================== + +;; Now, an experiment involving a buggy popcount implementation: + +;; Final SHR replaced with a NOP instruction. +(defconst *popcount-32-buggy* + (list + + ;; Section: : + + + (cons #x400610 #x89) ;; mov %edi,%edx + (cons #x400611 #xfa) ;; + (cons #x400612 #xd1) ;; shr %edx + (cons #x400613 #xea) ;; + (cons #x400614 #x81) ;; and $0x55555555,%edx + (cons #x400615 #xe2) ;; + (cons #x400616 #x55) ;; + (cons #x400617 #x55) ;; + (cons #x400618 #x55) ;; + (cons #x400619 #x55) ;; + (cons #x40061a #x29) ;; sub %edx,%edi + (cons #x40061b #xd7) ;; + (cons #x40061c #x89) ;; mov %edi,%eax + (cons #x40061d #xf8) ;; + (cons #x40061e #xc1) ;; shr $0x2,%edi + (cons #x40061f #xef) ;; + (cons #x400620 #x02) ;; + (cons #x400621 #x25) ;; and $0x33333333,%eax + (cons #x400622 #x33) ;; + (cons #x400623 #x33) ;; + (cons #x400624 #x33) ;; + (cons #x400625 #x33) ;; + (cons #x400626 #x81) ;; and $0x33333333,%edi + (cons #x400627 #xe7) ;; + (cons #x400628 #x33) ;; + (cons #x400629 #x33) ;; + (cons #x40062a #x33) ;; + (cons #x40062b #x33) ;; + (cons #x40062c #x01) ;; add %eax,%edi + (cons #x40062d #xc7) ;; + (cons #x40062e #x89) ;; mov %edi,%eax + (cons #x40062f #xf8) ;; + (cons #x400630 #xc1) ;; shr $0x4,%eax + (cons #x400631 #xe8) ;; + (cons #x400632 #x04) ;; + (cons #x400633 #x01) ;; add %edi,%eax + (cons #x400634 #xf8) ;; + (cons #x400635 #x25) ;; and $0xf0f0f0f,%eax + (cons #x400636 #x0f) ;; + (cons #x400637 #x0f) ;; + (cons #x400638 #x0f) ;; + (cons #x400639 #x0f) ;; + (cons #x40063a #x69) ;; imul $0x1010101,%eax,%eax + (cons #x40063b #xc0) ;; + (cons #x40063c #x01) ;; + (cons #x40063d #x01) ;; + (cons #x40063e #x01) ;; + (cons #x40063f #x01) ;; + + ;; (cons #x400640 #xc1) ;; shr $0x18,%eax + ;; (cons #x400641 #xe8) ;; + ;; (cons #x400642 #x18) ;; + (cons #x400640 #x0f) ;; nopl (%rax) + (cons #x400641 #x1f) ;; + (cons #x400642 #x00) ;; + + (cons #x400643 #xc3) ;; retq + (cons #x400644 #x66) ;; data32 data32 nopw %cs:0x0(%rax,%rax,1) + (cons #x400645 #x66) ;; + (cons #x400646 #x66) ;; + (cons #x400647 #x2e) ;; + (cons #x400648 #x0f) ;; + (cons #x400649 #x1f) ;; + (cons #x40064a #x84) ;; + (cons #x40064b #x00) ;; + (cons #x40064c #x00) ;; + (cons #x40064d #x00) ;; + (cons #x40064e #x00) ;; + (cons #x40064f #x00) ;; + + )) + +(gl::def-gl-rewrite split-on-logapp-of-create-undef + ;; From Sol Swords. + (equal (logapp 1 (create-undef x) 0) + (let ((undef (create-undef x))) + (if (gl::gl-hide (logbitp 0 undef)) + 1 + 0)))) + +(gl::def-gl-rewrite integerp-of-create-undef + (equal (integerp (create-undef n)) t)) + +;; FAILS! +(acl2::must-fail + (def-gl-thm x86-popcount-32-buggy + :hyp (and (natp n) + (< n (expt 2 32))) + :concl (b* ((start-address #x400610) + (halt-address #x400643) + (x86 (!programmer-level-mode t (create-x86))) + ((mv flg x86) + (init-x86-state + nil start-address halt-address + nil nil nil 0 + *popcount-32-buggy* + x86)) + (x86 (!rgfi *rdi* n x86)) + (count 300) + (x86 (x86-run count x86))) + (and (equal (rgfi *rax* x86) + (logcount n)) + (equal flg nil) + (equal (rip x86) + (+ 1 halt-address)))) + :g-bindings + `((n (:g-number ,(gl-int 0 1 33)))) + :n-counterexamples 3 + :abort-indeterminate t + :exec-ctrex nil)) + +#|| + +(b* ((start-address #x400610) + (halt-address #x400643) + (x86 (!programmer-level-mode t x86)) + ((mv ?flg x86) + (init-x86-state + nil start-address halt-address + nil nil nil 0 + *popcount-32-buggy* + x86)) + (x86 (!rgfi *rdi* #x80000000 x86)) + (count 300) + (x86 (x86-run count x86))) + x86) +(rgfi *rax* x86) + +(b* ((start-address #x400610) + (halt-address #x400643) + (x86 (!programmer-level-mode t x86)) + ((mv ?flg x86) + (init-x86-state + nil start-address halt-address + nil nil nil 0 + *popcount-32-buggy* + x86)) + (x86 (!rgfi *rdi* #xFFFFFFFF x86)) + (count 300) + (x86 (x86-run count x86))) + x86) +(rgfi *rax* x86) + +||# + +;; Succeeds! +(def-gl-thm x86-popcount-32-buggy-spec :hyp (and (natp n) (< n (expt 2 32))) - :concl (b* ((start-address #x4005c0) - (halt-address #x4005f6) + :concl (b* ((start-address #x400610) + (halt-address #x400643) (x86 (!programmer-level-mode t (create-x86))) ((mv flg x86) (init-x86-state nil start-address halt-address nil nil nil 0 - *popcount/popcount-64-bug-binary* + *popcount-32-buggy* x86)) (x86 (!rgfi *rdi* n x86)) - (x86 (!rgfi *rsp* *2^30* x86)) (count 300) (x86 (x86-run count x86))) - (and (equal (rgfi *rax* x86) + (and (equal (ash (rgfi *rax* x86) -24) (logcount n)) (equal flg nil) (equal (rip x86) - (+ 1 halt-address)) - (equal (caar (ms x86)) 'X86-HLT))) + (+ 1 halt-address)))) :g-bindings `((n (:g-number ,(gl-int 0 1 33)))) - :exec-ctrex nil - :rule-classes nil) - -;; (def-gl-thm x86-popcount-generalized-stack-pointer -;; :hyp (and (natp n) -;; (< n (expt 2 64)) -;; (not (equal n 5666001387520)) -;; (natp rsp) -;; (or (and (<= 0 rsp) -;; (< rsp #x400600)) -;; (and (< #x400686 rsp) -;; (< rsp *2^30*)))) -;; :concl (b* ((start-address #x400600) -;; (halt-address #x400686) -;; (x86 (!programmer-level-mode t (create-x86))) -;; ((mv flg x86) -;; (init-x86-state -;; nil start-address halt-address -;; nil nil nil 0 -;; *popcount/popcount-64-bug-binary* -;; x86)) -;; (x86 (!rgfi *rdi* n x86)) -;; (x86 (!rgfi *rsp* rsp x86)) -;; (count 300) -;; (x86 (x86-run count x86))) -;; (and (equal (rgfi *rax* x86) -;; (logcount n)) -;; (equal flg nil) -;; (equal (rip x86) -;; (+ 1 halt-address)) -;; (equal (caar (ms x86)) 'X86-HLT))) -;; :g-bindings -;; `((n (:g-number ,(gl-int 0 3 65))) -;; (rsp (:g-number ,(gl-int 1 3 49)))) -;; :rule-classes nil) + :n-counterexamples 3 + :abort-indeterminate t + :exec-ctrex nil) ;; ====================================================================== diff --git a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-utils.lisp b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-utils.lisp index 68d4b50b41a..b3eaeee2a0f 100644 --- a/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-utils.lisp +++ b/books/projects/x86isa/proofs/utilities/system-level-mode/marking-mode-utils.lisp @@ -857,6 +857,21 @@ ;; Lemmas about interaction of top-level memory reads and writes: +(defthm read-from-physical-memory-and-mv-nth-1-wb-disjoint + ;; Similar to rb-wb-disjoint-in-system-level-mode + (implies (and (disjoint-p + p-addrs + (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86)))) + (disjoint-p p-addrs + (all-translation-governing-addresses + (strip-cars addr-lst) (double-rewrite x86))) + (addr-byte-alistp addr-lst) + (not (programmer-level-mode x86)) + (x86p x86)) + (equal (read-from-physical-memory p-addrs (mv-nth 1 (wb addr-lst x86))) + (read-from-physical-memory p-addrs x86))) + :hints (("Goal" :in-theory (e/d* (wb) ())))) + (defthm rb-wb-disjoint-in-system-level-mode (implies (and (disjoint-p @@ -892,30 +907,17 @@ (mv-nth 0 (rb l-addrs r-w-x x86))) (equal (mv-nth 1 (rb l-addrs r-w-x (mv-nth 1 (wb addr-lst x86)))) (mv-nth 1 (rb l-addrs r-w-x x86))))) - :hints (("Goal" :do-not-induct t + :hints (("Goal" + :do-not-induct t :use ((:instance xlate-equiv-memory-and-las-to-pas (cpl (cpl x86)) (x86-1 (mv-nth 2 (las-to-pas (strip-cars addr-lst) :w (cpl x86) x86))) (x86-2 x86))) :in-theory (e/d* (disjoint-p-commutative) - (disjointness-of-all-translation-governing-addresses-from-all-translation-governing-addresses-subset-p + (wb + disjointness-of-all-translation-governing-addresses-from-all-translation-governing-addresses-subset-p mv-nth-1-las-to-pas-subset-p-disjoint-from-other-p-addrs))))) -(defthm read-from-physical-memory-and-mv-nth-1-wb-disjoint - ;; Similar to rb-wb-disjoint-in-system-level-mode - (implies (and (disjoint-p - p-addrs - (mv-nth 1 (las-to-pas (strip-cars addr-lst) :w (cpl x86) (double-rewrite x86)))) - (disjoint-p p-addrs - (all-translation-governing-addresses - (strip-cars addr-lst) (double-rewrite x86))) - (addr-byte-alistp addr-lst) - (not (programmer-level-mode x86)) - (x86p x86)) - (equal (read-from-physical-memory p-addrs (mv-nth 1 (wb addr-lst x86))) - (read-from-physical-memory p-addrs x86))) - :hints (("Goal" :in-theory (e/d* (wb) ())))) - (defthmd rb-wb-equal-in-system-level-mode (implies (and (equal ;; The physical addresses pertaining to the read