diff -Nru acl2-7.0/acl2-check.lisp acl2-7.1/acl2-check.lisp
--- acl2-7.0/acl2-check.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/acl2-check.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
diff -Nru acl2-7.0/acl2-fns.lisp acl2-7.1/acl2-fns.lisp
--- acl2-7.0/acl2-fns.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/acl2-fns.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
@@ -20,6 +20,8 @@
(in-package "ACL2")
+(proclaim-optimize)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; PRELIMINARIES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -873,7 +875,7 @@
; evaluated. One way to achieve this state of affairs, of course, is to load
; the file first.
-; Just before releasing Version_2.5 we decided to consider proclaiming for
+; Just before creating Version_2.5 we decided to consider proclaiming for
; Lisps other than GCL. However, our tests in Allegro suggested that this may
; not help. The comment below gives some details. Perhaps we will proclaim
; for MCL in the future. At any rate, CCL (OpenMCL) is supported starting with
@@ -881,7 +883,7 @@
; Section "PROCLAIMING" above.
; Here is a summary of three comparable user times from certifying all the ACL2
-; books in June 2000, just before Release 2.5 is complete. The first column,
+; books in June 2000, just before Version_2.5 is complete. The first column,
; labeled "Comp", is the one to be looked at for comparison purposes. These are
; all done on the same Sun workstation, using Allegro 5.0.1. The meanings of
; these numbers are explained below.
@@ -1758,14 +1760,6 @@
(get-os)
*the-live-state*))
-(defun cancel-dot-dots (full-pathname)
- (let ((p (search "/.." full-pathname)))
- (cond (p (cancel-dot-dots
- (qfuncall merge-using-dot-dot
- (subseq full-pathname 0 p)
- (subseq full-pathname (1+ p) (length full-pathname)))))
- (t full-pathname))))
-
(defun unix-full-pathname (name &optional extension)
; We formerly used Common Lisp function merge-pathnames. But in CCL,
@@ -1788,7 +1782,8 @@
extension)
name)
os state)))
- (cancel-dot-dots
+ (qfuncall
+ cancel-dot-dots
(cond ((qfuncall absolute-pathname-string-p name nil os)
name)
(t
@@ -1905,9 +1900,9 @@
reference such a variable than an ordinary special, which may have a
per-thread binding that needs to be locked up."
- #-Clozure
+ #-ccl
`(defparameter ,@r)
- #+Clozure
+ #+ccl
`(ccl::defstatic ,@r))
(defmacro defv (&rest r)
@@ -1921,9 +1916,9 @@
the CCL documentation string for DEFSTATICVAR: ``Like DEFVAR, the initial
value form is not evaluated if the variable is already BOUNDP.''"
- #-Clozure
+ #-ccl
`(defvar ,@r)
- #+Clozure
+ #+ccl
`(ccl::defstaticvar ,@r))
(defmacro without-interrupts (&rest forms)
@@ -2076,26 +2071,9 @@
#-(or ccl sb-thread lispworks)
`(progn ,@forms)))
-(defmacro gv (fn args val)
- (sublis `((funny-fn . ,fn)
- (funny-args . ,args))
- `(let ((gc-on (not (gc-off *the-live-state*))))
- (if (or gc-on
- (f-get-global 'safe-mode *the-live-state*))
- (throw-raw-ev-fncall
- (list 'ev-fncall-guard-er
- 'funny-fn
- ,(cons 'list 'funny-args)
- (untranslate* (guard 'funny-fn nil (w *the-live-state*))
- t
- (w *the-live-state*))
- (stobjs-in 'funny-fn (w *the-live-state*))
- (not gc-on)))
- ,val))))
-
-; Through ACL2 Version_6.5, acl2-gentemp was deined in interface-raw.lisp. But
-; since it is used in parallel-raw.lisp, we have moved it here in support of
-; the toothbrush.
+; Through ACL2 Version_6.5, acl2-gentemp was defined in interface-raw.lisp.
+; But since it is used in parallel-raw.lisp, we have moved it here in support
+; of the toothbrush.
(defvar *acl2-gentemp-counter* 0)
(defun-one-output acl2-gentemp (root)
(let ((acl2-pkg (find-package "ACL2")))
@@ -2107,3 +2085,46 @@
; See comment in intern-in-package-of-symbol for an explanation of this trick.
ans))
(incf *acl2-gentemp-counter*))))))
+
+; Subsection: type mfixnum
+
+; We use the type mfixnum for counting things that are best counted in the
+; trillions or more. Mfixnums happen to coincide with regular fixnums on
+; 64-bit CCL, and may be fixnums in other Lisps (e.g. SBCL 1.1.8 and, as
+; confirmed by Camm Maguire Sept. 2014, in 64-bit GCL where fixnums are 64 bits
+; long).
+
+(defconstant most-positive-mfixnum
+
+; Warning: In function internal-real-ticks, we rely on this value having a
+; binary representation as a sequence of ones.
+
+; This is more than 10^18, that is, more than a billion billions. It seems
+; reasonable to assume (at least in 2014 and for some years beyond) that any
+; integer quantities that we accumulate, such as call counts, are less than
+; that. This number is also more than the (2*500,000,000)^2, which is the size
+; of *memoize-call-array* when we have approximately 500 million memoized
+; functions. [Note: if a countable event, like a call, took just the time of
+; the fastest single instruction on a 100GHz (!) machine, then counting up
+; most-positive-mfixnum of them would take over 4 months.]
+
+ (1- (expt 2 60)))
+
+(deftype mfixnum ()
+ `(integer ,(- -1 most-positive-mfixnum)
+ ,most-positive-mfixnum))
+
+(defmacro the-mfixnum (x)
+
+; This silly macro may help someday in debugging, using code such as is found
+; in the comment just below. Of course, by adding an optional argument that
+; specifies some sort of location for this call, we can get more specific
+; debugging information. Debugging could also be aided by replacing this with
+; a corresponding defun, which could be traced.
+
+; `(let ((x ,x))
+; (cond ((not (typep x 'fixnum))
+; (error "OUCH")))
+; (the mfixnum x))
+
+ `(the mfixnum ,x))
diff -Nru acl2-7.0/acl2-init.lisp acl2-7.1/acl2-init.lisp
--- acl2-7.0/acl2-init.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/acl2-init.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
@@ -258,6 +258,8 @@
(load "acl2.lisp")
+(acl2::proclaim-optimize)
+
; We allow ACL2(h) code to take advantage of Ansi CL features. It's
; conceivable that we don't need this restriction (which only applies to GCL),
; but it doesn't currently seem worth the trouble to figure that out.
@@ -685,21 +687,26 @@
(defconstant *acl2-snapshot-string*
-; Note to developers (users should ignore this!): Replace this value by "" when
-; making a release.
+; Notes to developers (users should ignore this!):
+
+; (1) Replace the value below by "" when making a release.
+
+; (2) More generally, see UT file
+; /projects/acl2/devel-misc/release.cmds
+; for release instructions.
; Temporarily, for a release:
-""
+ ""
; Normally:
-; "
-; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-; + WARNING: This is NOT an ACL2 release; it is a development snapshot. +
-; + The authors of ACL2 consider such distributions to be experimental; +
-; + they may be incomplete, fragile, and unable to pass our own +
-; + regression tests. +
-; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-; "
+; "
+; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+; + WARNING: This is NOT an ACL2 release; it is a development snapshot. +
+; + The authors of ACL2 consider such distributions to be experimental; +
+; + they may be incomplete, fragile, and unable to pass our own +
+; + regression tests. +
+; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+;"
)
(defvar *saved-string*
@@ -717,6 +724,9 @@
#+hons
"~%~% Includes support for hash cons, memoization, and applicative hash~
~% tables.~%"
+ #-hons
+ "~%~% WARNING: ACL2(c) is deprecated and will likely be unsupported or~
+ ~% even eliminated in future releases.~%"
#+acl2-par
"~%~% Experimental modification for parallel evaluation. Please expect at~
~% most limited maintenance for this version~%"
@@ -863,6 +873,18 @@
nil)
#+akcl
+(defvar *gcl-large-maxpages*
+
+; This variable tells GCL to use Camm Maguire's strategy during development of
+; GCL 2.6.13 of using large maxpage limits to postpone garbage collection, and
+; thus avoid SGC. It appears that si::*code-block-reserve* was introduced at
+; the time this strategy was developed, and that si::set-log-maxpage-bound was
+; already defined at that point (but we check, since we rely on that).
+
+ (and (boundp 'si::*code-block-reserve*)
+ (fboundp 'si::set-log-maxpage-bound)))
+
+#+akcl
(defun save-acl2-in-akcl-aux (sysout-name gcl-exec-name
write-worklispext
set-optimize-maximum-pages
@@ -903,6 +925,9 @@
; 'si::*optimize-maximum-pages* to t just before the save.
(setq si::*optimize-maximum-pages* t)))
+ (when *gcl-large-maxpages*
+ (setq si::*code-block-reserve*
+ (make-array 40000000 :element-type 'character :static t)))
(chmod-executable sysout-name)
(si::save-system (concatenate 'string sysout-name "." ext))))
@@ -1040,7 +1065,8 @@
(si::gbc t) ; wfs suggestion [at least if we turn on SGC] -- formerly nil
; (don't know why...)
- (cond ((fboundp 'si::sgc-on)
+ (cond ((and (not *gcl-large-maxpages*)
+ (fboundp 'si::sgc-on))
(print "Executing (si::sgc-on t)") ;debugging GC
(funcall 'si::sgc-on t)))
@@ -1145,6 +1171,7 @@
(if *acl2-default-restart-complete*
(return-from acl2-default-restart nil))
+ (proclaim-optimize) ; see comment in proclaim-optimize
(setq *lp-ever-entered-p* nil)
(#+cltl2
common-lisp-user::acl2-set-character-encoding
@@ -1433,9 +1460,8 @@
; The user is welcome to set this value, which according to
; http://www.sbcl.org/manual/, is the "Size of the dynamic space reserved on
; startup in megabytes." It can be done either by setting this variable before
-; saving an ACL2 image, or by editing the resulting script (e.g., saved_acl2 or
-; saved_acl2h). Here we explain the defaults that we provide for this
-; variable.
+; saving an ACL2 image, or by editing the resulting script (e.g., saved_acl2).
+; Here we explain the defaults that we provide for this variable.
; We observed during development of Version_5.0 that --dynamic-space-size 2000
; is necessary in order to complete an ACL2(h) regression with SBCL 1.0.55 on a
@@ -1480,7 +1506,44 @@
#-x86-64 2000)
#+sbcl
-(defvar *sbcl-contrib-dir* nil)
+(defvar *sbcl-contrib-dir*
+ (or (getenv$-raw "SBCL_HOME")
+ (let ((suggestions
+ (and
+ (boundp 'sb-ext::*core-pathname*)
+ (ignore-errors
+ (let* ((core-dir
+ (pathname-directory
+ sb-ext::*core-pathname*))
+ (contrib-dir-pathname-new ; see comment above
+ (and (equal (car (last core-dir))
+ "output")
+ (make-pathname
+ :directory
+ (append (butlast core-dir 1)
+ (list "obj/sbcl-home")))))
+ (contrib-dir-pathname
+ (and (equal (car (last core-dir))
+ "output")
+ (make-pathname
+ :directory
+ (append (butlast core-dir 1)
+ (list "contrib"))))))
+ (append (and (probe-file contrib-dir-pathname-new)
+ (list (namestring contrib-dir-pathname-new)))
+ (and (probe-file contrib-dir-pathname)
+ (list (namestring contrib-dir-pathname)))))))))
+ (cond
+ ((consp (cdr suggestions))
+ (error "Please set environment variable SBCL_HOME. Suggestions:~%~
+ ~a or ~a"
+ (car suggestions)
+ (cadr suggestions)))
+ ((consp suggestions)
+ (error "Please set environment variable SBCL_HOME. Suggestion:~%~
+ ~a"
+ (car suggestions)))
+ (t (error "Please set environment variable SBCL_HOME."))))))
#+sbcl
(defun save-acl2-in-sbcl-aux (sysout-name core-name
@@ -1516,40 +1579,9 @@
; to include the trailing "contrib/" when using obj/sbcl-home/.
("~a~%"
- (let ((contrib-dir
- (or
- *sbcl-contrib-dir*
- (and (boundp 'sb-ext::*core-pathname*)
- (ignore-errors
- (let* ((core-dir
- (pathname-directory
- sb-ext::*core-pathname*))
- (contrib-dir-pathname-new ; see comment above
- (and (equal (car (last core-dir))
- "output")
- (make-pathname
- :directory
- (append (butlast core-dir 1)
- (list "obj/sbcl-home")))))
- (contrib-dir-pathname
- (and (equal (car (last core-dir))
- "output")
- (make-pathname
- :directory
- (append (butlast core-dir 1)
- (list "contrib"))))))
- (cond ((probe-file contrib-dir-pathname-new)
- (setq *sbcl-contrib-dir*
- (namestring contrib-dir-pathname-new)))
- ((probe-file contrib-dir-pathname)
- (setq *sbcl-contrib-dir*
- (namestring contrib-dir-pathname)))
- (t nil))))))))
- (if contrib-dir
- (format nil
- "export SBCL_HOME=~s"
- contrib-dir)
- "")))
+ (format nil
+ "export SBCL_HOME=~s"
+ *sbcl-contrib-dir*))
; We have observed with SBCL 1.0.49 that "make HTML" fails on our 64-bit linux
; system unless we start sbcl with --control-stack-size 4 [or larger]. The
@@ -1892,8 +1924,11 @@
(declare (ignore other-info))
#+akcl
- (if (boundp 'si::*optimize-maximum-pages*)
- (setq si::*optimize-maximum-pages* nil)) ; Camm Maguire suggestion
+ (when (boundp 'si::*optimize-maximum-pages*) ; Camm Maguire suggestions
+ (setq si::*optimize-maximum-pages* nil)
+ (when *gcl-large-maxpages*
+ (si::set-log-maxpage-bound
+ (1+ (integer-length most-positive-fixnum)))))
; Consider adding something like
; (ccl::save-application "acl2-image" :size (expt 2 24))
diff -Nru acl2-7.0/acl2.lisp acl2-7.1/acl2.lisp
--- acl2-7.0/acl2.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/acl2.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
@@ -142,7 +142,8 @@
; SAFETY AND PROCLAIMING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(proclaim `(optimize #+cltl2 (compilation-speed 0)
+(defvar *acl2-optimize-form*
+ `(optimize #+cltl2 (compilation-speed 0)
; The user is welcome to modify this proclaim form. Warning: Keep it in sync
; with the settings in compile-acl2 under #+sbcl.
@@ -150,10 +151,10 @@
; The following may allow more tail recursion elimination (from "Lisp
; Knowledgebase" at lispworks.com); might consider for Allegro CL too.
- #+(or lispworks ccl) (debug 0)
- #+cmu (extensions:inhibit-warnings 3)
- #+sbcl (sb-ext:inhibit-warnings 3)
- (speed 3)
+ #+(or lispworks ccl) (debug 0)
+ #+cmu (extensions:inhibit-warnings 3)
+ #+sbcl (sb-ext:inhibit-warnings 3)
+ (speed 3)
; Consider replacing cmu on the next line with (or cmu sbcl). The SBCL manual
; says the following, but a quick test with (or cmu sbcl) yielded no smaller
@@ -165,12 +166,12 @@
; so indiscriminately that the net effect is to slow the program by causing
; cache misses or even swapping.
- (space #+cmu 1 #-cmu 0)
+ (space #+cmu 1 #-cmu 0)
; WARNING: Do not proclaim (cl-user::fixnum-safety 0) for LispWorks. Any
; fixnum-safety less than 3 expects all integers to be fixnums!
- (safety
+ (safety
; Consider using (safety 3) if there is a problem with LispWorks. It enabled
; us to see a stack overflow involving collect-assumptions in the proof of
@@ -213,21 +214,23 @@
; ran out of space, saving perhaps a minute]
; 15637.669u 511.811s 52:02.78 517.1% 0+0k 0+0io 0pf+0w
- ,(let ((our-safety
- #-CLTL2
- (if (boundp 'user::*acl2-safety*)
- (symbol-value 'user::*acl2-safety*)
- nil)
- #+CLTL2
- (if (boundp 'common-lisp-user::*acl2-safety*)
- (symbol-value 'common-lisp-user::*acl2-safety*)
- nil)))
- (if our-safety
- (progn (format t "Note: Setting SAFETY to ~s."
- our-safety)
+ ,(let ((our-safety
+ #-CLTL2
+ (if (boundp 'user::*acl2-safety*)
+ (symbol-value 'user::*acl2-safety*)
+ nil)
+ #+CLTL2
+ (if (boundp 'common-lisp-user::*acl2-safety*)
+ (symbol-value 'common-lisp-user::*acl2-safety*)
+ nil)))
+ (if our-safety
+ (progn (format t "Note: Setting SAFETY to ~s."
our-safety)
- 0))
- )))
+ our-safety)
+ 0))
+ )))
+
+(proclaim *acl2-optimize-form*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; FILES
@@ -608,7 +611,7 @@
;;; perhaps include the binding (*compile-verbose* t) for ecl.
;;; Modify exit-lisp to treat ecl like akcl, except using ext::quit instead of
-;;; lisp::bye.
+;;; si::bye.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; PACKAGES
@@ -971,7 +974,7 @@
(setq acl2::*copy-of-acl2-version*
; Keep this in sync with the value of acl2-version in *initial-global-table*.
(concatenate 'string
- "ACL2 Version 7.0"
+ "ACL2 Version 7.1"
#+non-standard-analysis
"(r)"
#+(and mcl (not ccl))
@@ -984,6 +987,19 @@
(in-package "ACL2")
+(defun proclaim-optimize ()
+
+; With SBCL 1.2.10, we have seen a saved_acl2 start up without the compiler
+; optimizations that we had installed during the build. Perhaps that has been
+; true for other SBCL versions or even other Lisps. The problem appears to be
+; that (in SBCL 1.2.10 at least), proclaim forms can be local to the file in
+; which they appear, even if the file isn't explicitly compiled. So we call
+; this function in acl2-default-restart, and also at the top level when
+; building ACL2, to ensure that our compiler optimizations are in force, and we
+
+ (proclaim #+cltl2 common-lisp-user::*acl2-optimize-form*
+ #-cltl2 user::*acl2-optimize-form*))
+
(defparameter *compiled-file-extension*
; Note that for the community books, files books/Makefile-generic,
@@ -1929,6 +1945,8 @@
(not *do-proclaims*)) ; see comment above
(return-from compile-acl2 nil))
+ (proclaim-optimize)
+
(with-warnings-suppressed
#+sbcl
@@ -2047,6 +2065,8 @@
(declare (ignorable fast))
+ (proclaim-optimize)
+
(our-with-compilation-unit ; only needed when *suppress-compile-build-time*
(with-warnings-suppressed
@@ -2171,7 +2191,7 @@
#+lispworks ; Version 4.2.0; older versions have used bye
(if status-p (lispworks:quit :status status) (lispworks:quit))
#+akcl
- (if status-p (lisp::bye status) (lisp::bye))
+ (if status-p (si::bye status) (si::bye))
#+lucid
(lisp::exit) ; don't know how to handle status, but don't support lucid
#+ccl
@@ -2468,7 +2488,7 @@
(catch *quit-tag*
(setq - (locally (declare (notinline read))
(dbl-read *debug-io* nil *top-eof*)))
- (when (eq - *top-eof*) (lisp::bye -1))
+ (when (eq - *top-eof*) (si::bye -1))
(let* ( break-command
(values
(multiple-value-list
diff -Nru acl2-7.0/akcl-acl2-trace.lisp acl2-7.1/akcl-acl2-trace.lisp
--- acl2-7.0/akcl-acl2-trace.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/akcl-acl2-trace.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
diff -Nru acl2-7.0/allegro-acl2-trace.lisp acl2-7.1/allegro-acl2-trace.lisp
--- acl2-7.0/allegro-acl2-trace.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/allegro-acl2-trace.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
diff -Nru acl2-7.0/all-files.txt acl2-7.1/all-files.txt
--- acl2-7.0/all-files.txt 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/all-files.txt 2015-05-08 18:07:33.000000000 +0000
@@ -161,6 +161,7 @@
doc/manual/res/centaur:
centaur-logo.png
+cert_pl_exclude
doc/manual/res/tours:
*.gif
diff -Nru acl2-7.0/axioms.lisp acl2-7.1/axioms.lisp
--- acl2-7.0/axioms.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/axioms.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
@@ -2960,6 +2960,16 @@
(defmacro mbt (x)
`(mbe1 t ,x))
+(defmacro mbt* (x)
+
+; This macro is like mbt, except that not only is it trivial in raw Lisp, it's
+; also trivial in the logic. Its only purpose is to generate a guard proof
+; obligation.
+
+ `(mbe :logic t
+ :exec (mbe :logic ,x
+ :exec t)))
+
(defun binary-append (x y)
(declare (xargs :guard (true-listp x)))
(cond ((endp x) y)
@@ -3063,7 +3073,11 @@
; which expands here into a call of string-append. However, the :exec case is
; only called if we are executing the raw Lisp code for string-append, in which
; case we will be executing the raw Lisp code for concatenate, which of course
-; does not call the ACL2 function string-append.
+; does not call the ACL2 function string-append. (We ensure the preceding
+; sentence by calling verify-termination-boot-strap later in this file. We
+; have seen an ACL2(p) stack overflow caused in thanks-for-the-hint when this
+; function was in :program mode and we were in safe-mode because we were
+; macroexpanding.)
(concatenate 'string str1 str2)))
@@ -3500,6 +3514,13 @@
(< n (length s)))))
(nth n (coerce s 'list)))
+#+acl2-loop-only
+(defun sleep (n)
+ (declare (xargs :guard (and (rationalp n)
+ (<= 0 n))))
+ (declare (ignore n))
+ nil)
+
(defun proper-consp (x)
(declare (xargs :guard t))
(and (consp x)
@@ -3527,17 +3548,32 @@
(- (imagpart x)))
x))
+(defun add-suffix (sym str)
+ (declare (xargs :guard (and (symbolp sym)
+ (stringp str))))
+ (intern-in-package-of-symbol
+ (concatenate 'string (symbol-name sym) str)
+ sym))
+
+(defconst *inline-suffix* "$INLINE") ; also see above defun-inline-form
+
#-acl2-loop-only
(defmacro ec-call1-raw (ign x)
(declare (ignore ign))
(assert (and (consp x) (symbolp (car x)))) ; checked by translate11
- (let ((*1*fn (*1*-symbol (car x))))
- `(funcall
- (cond
- (*safe-mode-verified-p* ; see below for discussion of this case
- ',(car x))
- ((fboundp ',*1*fn) ',*1*fn)
- (t
+ (let ((*1*fn (*1*-symbol (car x)))
+ (*1*fn$inline (*1*-symbol (add-suffix (car x) *inline-suffix*))))
+ `(cond
+ (*safe-mode-verified-p* ; see below for discussion of this case
+ ,x)
+ (t
+ (funcall
+ (cond
+ ((fboundp ',*1*fn) ',*1*fn)
+ ((fboundp ',*1*fn$inline)
+ (assert$ (macro-function ',(car x)) ; sanity check; could be omitted
+ ',*1*fn$inline))
+ (t
; We should never hit this case, unless the user is employing trust tags or raw
; Lisp. For ACL2 events that might hit this case, such as a defconst using
@@ -3558,9 +3594,10 @@
; avoid the *1* function calls entirely when loading the expansion file (or its
; compilation).
- (error "Undefined function, ~s. Please contact the ACL2 implementors."
- ',*1*fn)))
- ,@(cdr x))))
+ (error "Undefined function, ~s. Please contact the ACL2 ~
+ implementors."
+ ',*1*fn)))
+ ,@(cdr x))))))
(defmacro ec-call1 (ign x)
@@ -6190,7 +6227,7 @@
',form))))
(t ,form)))))
`(state-global-let*
- ((safe-mode (not (global-val 'boot-strap-flg (w state)))))
+ ((safe-mode (not (f-get-global 'boot-strap-flg state))))
(value ,form))))))
#+acl2-loop-only
@@ -10046,18 +10083,18 @@
)
(defun the-check (guard x y)
- (declare (xargs :guard (or guard (hard-error
- nil
- "The object ~xa does not satisfy the ~
- declaration ~xb."
- (list (cons #\a y)
- (cons #\b x))))))
+
+; See call of (set-guard-msg the-check ...) later in the sources.
+
+ (declare (xargs :guard guard))
(declare (ignore x guard))
y)
(defun the-fn (x y)
(declare (xargs :guard (translate-declaration-to-guard x 'var nil)
+; Warning: Keep this in sync with the-fn-for-*1*.
+
; As noted above the definition of translate-declaration-to-guard/integer, we
; are trying to save a little space in the image.
@@ -10106,9 +10143,39 @@
#+acl2-loop-only
(defmacro the (x y)
+
+; Warning: Keep this in sync with the-for-*1*.
+
(declare (xargs :guard (translate-declaration-to-guard x 'var nil)))
(the-fn x y))
+(defun the-check-for-*1* (guard x y var)
+
+; See call of (set-guard-msg the-check-for-*1* ...) later in the sources.
+
+ (declare (xargs :guard guard))
+ (declare (ignore x guard var))
+ y)
+
+(defun the-fn-for-*1* (x y)
+
+; Warning: Keep this in sync with the-fn.
+
+ (declare (xargs :guard (and (symbolp y)
+ (translate-declaration-to-guard x y nil))
+ :mode :program))
+ (let ((guard (and (symbolp y)
+ (translate-declaration-to-guard x y nil))))
+ `(the-check-for-*1* ,guard ',x ,y ',y)))
+
+(defmacro the-for-*1* (x y)
+
+; Warning: Keep this in sync with THE.
+
+ (declare (xargs :guard (and (symbolp y)
+ (translate-declaration-to-guard x y nil))))
+ (the-fn-for-*1* x y))
+
; THEORY PROTO-PRIMITIVES
; Thus far it has been impossible to use the :in-theory hint in
@@ -10614,10 +10681,7 @@
(assert (not (assoc-equal name *package-alist*)))
(let* ((incomplete-p t)
(saved-ever-known-package-alist *ever-known-package-alist*)
- (wrld (w *the-live-state*))
- (not-boot-strap (not (getprop 'boot-strap-flg 'global-value nil
- 'current-acl2-world
- wrld))))
+ (not-boot-strap (not (f-get-global 'boot-strap-flg *the-live-state*))))
(setq *defpkg-virgins*
(remove1-equal name *defpkg-virgins*))
(unwind-protect
@@ -10636,7 +10700,8 @@
(strip-cars
(symbol-value 'acl2::*load-compiled-stack*))
(getprop 'include-book-path 'global-value
- nil 'current-acl2-world wrld)))
+ nil 'current-acl2-world
+ (w *the-live-state*))))
:defpkg-event-form event-form)
*ever-known-package-alist*))
(when proposed-imports
@@ -12504,10 +12569,13 @@
rassoc-equal remove-equal position-equal
maybe-finish-output$
symbol-in-current-package-p
+ sleep
; Found for hons after fixing note-fns-in-form just before release v4-2.
- FAST-ALIST-LEN HONS-COPY-PERSISTENT HONS-SUMMARY HONS-CLEAR HONS-WASH
+ FAST-ALIST-LEN HONS-COPY-PERSISTENT HONS-SUMMARY
+ HONS-CLEAR HONS-CLEAR!
+ HONS-WASH HONS-WASH!
FAST-ALIST-CLEAN FAST-ALIST-FORK HONS-EQUAL-LITE
CLEAR-HASH-TABLES NUMBER-SUBTREES
FAST-ALIST-SUMMARY HONS-ACONS! CLEAR-MEMOIZE-TABLES HONS-COPY HONS-ACONS
@@ -12869,7 +12937,7 @@
; The reason MCL needs special treatment is that (char-code #\Newline) = 13 in
; MCL, not 10. See also :DOC version.
-; ACL2 Version 7.0
+; ACL2 Version 7.1
; We put the version number on the line above just to remind ourselves to bump
; the value of state global 'acl2-version, which gets printed out with the
@@ -12895,7 +12963,7 @@
; reformatting :DOC comments.
,(concatenate 'string
- "ACL2 Version 7.0"
+ "ACL2 Version 7.1"
#+non-standard-analysis
"(r)"
#+(and mcl (not ccl))
@@ -12903,6 +12971,18 @@
(acl2p-checkpoints-for-summary . nil)
(axiomsp . nil)
(bddnotes . nil)
+ (boot-strap-flg .
+
+; Keep this state global in sync with world global of the same name. We expect
+; both this and the corresponding world global both to be constant, except when
+; both are changed from t to nil during evaluation of exit-boot-strap-mode.
+; The state global can be useful for avoiding potentially slow calls of
+; getprop, for example as noticed by Sol Swords in function make-event-fn2.
+; While we could probably fix many or most such calls by suitable binding of
+; the world global, it seems simple and reasonable to record the value in this
+; corresponding state global.
+
+ t)
(certify-book-info .
; Certify-book-info is non-nil when certifying a book, in which case it is a
@@ -15033,140 +15113,487 @@
(state-p1 state-state))))
(open-input-channel-any-p1 channel state-state))
-(defmacro print-case ()
- '(f-get-global 'print-case state))
+; Here we implement acl2-defaults-table, which is used for handling the default
+; defun-mode and other defaults.
-; (defmacro acl2-print-case (&optional (st 'state))
-; (declare (ignore st))
-; `(er soft 'acl2-print-case
-; "Macro ~x0 has been replaced by macro ~x1."
-; 'acl2-print-case 'print-case))
+; WARNING: If you add a new key to acl-defaults-table, and hence a new set-
+; function for smashing the acl2-defaults-table at that key, then be sure to
+; add that set- function to the list in chk-embedded-event-form! E.g., when we
+; added the :irrelevant-formals-ok key we also defined
+; set-irrelevant-formals-ok and then added it to the list in
+; chk-embedded-event-form. Also add similarly to :DOC acl2-defaults-table and
+; to primitive-event-macros.
-(defmacro acl2-print-case (&optional (st 'state))
- `(print-case ,st))
+(defun non-free-var-runes (runes free-var-runes-once free-var-runes-all acc)
+ (declare (xargs :guard (and (true-listp runes)
+ (true-listp free-var-runes-once)
+ (true-listp free-var-runes-all))))
+ (if (endp runes)
+ acc
+ (non-free-var-runes (cdr runes)
+ free-var-runes-once free-var-runes-all
+ (if (or (member-equal (car runes)
+ free-var-runes-once)
+ (member-equal (car runes)
+ free-var-runes-all))
+ acc
+ (cons (car runes) acc)))))
-(defun set-print-case (case state)
- (declare (xargs :guard (and (or (eq case :upcase) (eq case :downcase))
- (state-p state))))
- (prog2$ (or (eq case :upcase)
- (eq case :downcase)
- (illegal 'set-print-case
- "The value ~x0 is illegal as an ACL2 print-case, which ~
- must be :UPCASE or :DOWNCASE."
- (list (cons #\0 case))))
- (f-put-global 'print-case case state)))
+(defun free-var-runes (flg wrld)
+ (declare (xargs :guard (plist-worldp wrld)))
+ (cond
+ ((eq flg :once)
+ (global-val 'free-var-runes-once wrld))
+ (t ; (eq flg :all)
+ (global-val 'free-var-runes-all wrld))))
-(defmacro set-acl2-print-case (case)
- (declare (ignore case))
- '(er soft 'set-acl2-print-case
- "Macro ~x0 has been replaced by function ~x1."
- 'set-acl2-print-case 'set-print-case))
+(defthm natp-position-ac ; for admission of absolute-pathname-string-p
+ (implies (and (integerp acc)
+ (<= 0 acc))
+ (or (equal (position-ac item lst acc) nil)
+ (and (integerp (position-ac item lst acc))
+ (<= 0 (position-ac item lst acc)))))
+ :rule-classes :type-prescription)
-(defmacro print-base (&optional (st 'state))
- `(f-get-global 'print-base ,st))
+; The following constants and the next two functions, pathname-os-to-unix and
+; pathname-unix-to-os, support the use of Unix-style filenames in ACL2 as
+; described in the Essay on Pathnames in interface-raw.lisp.
-(defmacro acl2-print-base (&optional (st 'state))
- `(print-base ,st))
+; The following constants represent our decision to use Unix-style pathnames
+; within ACL2. See the Essay on Pathnames in interface-raw.lisp.
-(defmacro print-radix (&optional (st 'state))
- `(f-get-global 'print-radix ,st))
+(defconst *directory-separator*
+ #\/)
-(defmacro acl2-print-radix (&optional (st 'state))
- `(print-radix ,st))
+(defconst *directory-separator-string*
+ (string *directory-separator*))
-(defun check-print-base (print-base ctx)
+(defmacro os-er (os fnname)
+ `(illegal ,fnname
+ "The case where (os (w state)) is ~x0 has not been handled by the ~
+ ACL2 implementors for the function ~x1. Please inform them of this ~
+ problem."
+ (list (cons #\0 ,os)
+ (cons #\1 ,fnname))))
-; Warning: Keep this in sync with print-base-p, and keep the format warning
-; below in sync with princ$.
+(defun os (wrld)
+ (declare (xargs :guard (plist-worldp wrld)))
+ (global-val 'operating-system wrld))
- (declare (xargs :guard t))
- (if (print-base-p print-base)
- nil
- (hard-error ctx
- "The value ~x0 is illegal as a print-base, which must be 2, ~
- 8, 10, or 16"
- (list (cons #\0 print-base))))
- #+(and (not acl2-loop-only) (not allegro))
+(defun absolute-pathname-string-p (str directoryp os)
-; There is special handling when #+allegro in princ$ and prin1$, which is why
-; we avoid the following test for #+allegro.
+; Str is a Unix-style pathname. However, on Windows, Unix-style absolute
+; pathnames may start with a prefix such as "c:"; see mswindows-drive.
- (when (int= print-base 16)
- (let ((*print-base* 16)
- (*print-radix* nil))
- (or (equal (prin1-to-string 10) "A")
+; Directoryp is non-nil when we require str to represent a directory in ACL2
+; with Unix-style syntax, returning nil otherwise.
-; If we get here, a solution is simply to treat the underlying Lisp as we treat
-; #+allegro in the raw Lisp code for princ$ and prin1$.
+; Function expand-tilde-to-user-home-dir should already have been applied
+; before testing str with this function.
- (illegal 'check-print-base
- "ERROR: This Common Lisp does not print in radix 16 using ~
- upper-case alphabetic hex digits: for example, it prints ~
- ~x0 instead of ~x1. Such printing is consistent with the ~
- Common Lisp spec but is not reflected in ACL2's axioms ~
- about printing (function digit-to-char, in support of ~
- functions princ$ and prin1$), which in turn reflect the ~
- behavior of the majority of Common Lisp implementations of ~
- which we are aware. If the underlying Common Lisp's ~
- implementors can make a patch available to remedy this ~
- situation, please let the ACL2 implementors know and we ~
- will incorporate a patch for that Common Lisp. In the ~
- meantime, we do not see any way that this situation can ~
- cause any unsoundness, so here is a workaround that you ~
- can use at your own (minimal) risk. In raw Lisp, execute ~
- the following form:~|~%~x2~|"
- (list (cons #\0 (prin1-to-string 10))
- (cons #\1 "A")
- (cons #\2 '(defun check-print-base (print-base ctx)
- (declare (ignore print-base ctx))
- nil))))))
- nil)
- #-acl2-loop-only nil)
+ (declare (xargs :guard (stringp str)))
+ (let ((len (length str)))
+ (and (< 0 len)
+ (cond ((and (eq os :mswindows) ; hence os is not nil
+ (let ((pos-colon (position #\: str))
+ (pos-sep (position *directory-separator* str)))
+ (and pos-colon
+ (eql pos-sep (1+ pos-colon))))
+ t))
+ ((eql (char str 0) *directory-separator*)
+ t)
+ (t ; possible hard error for ~ or ~/...
+ (and (eql (char str 0) #\~)
-(defun set-print-base (base state)
- (declare (xargs :guard (and (print-base-p base)
- (state-p state))))
- (prog2$ (check-print-base base 'set-print-base)
- (f-put-global 'print-base base state)))
+; Note that a leading character of `~' need not get special treatment by
+; Windows. See also expand-tilde-to-user-home-dir.
-(defmacro set-acl2-print-base (base)
- (declare (ignore base))
- '(er soft 'set-acl2-print-base
- "Macro ~x0 has been replaced by function ~x1."
- 'set-acl2-print-base 'set-print-base))
+ (not (eq os :mswindows))
+ (prog2$ (and (or (eql 1 len)
+ (eql (char str 1)
+ *directory-separator*))
+ (hard-error 'absolute-pathname-string-p
+ "Implementation error: Forgot ~
+ to apply ~
+ expand-tilde-to-user-home-dir ~
+ before calling ~
+ absolute-pathname-string-p. ~
+ Please contact the ACL2 ~
+ implementors."
+ nil))
+ t))))
+ (if directoryp
+ (eql (char str (1- len)) *directory-separator*)
+ t))))
-(defun set-print-circle (x state)
- (declare (xargs :guard (state-p state)))
- (f-put-global 'print-circle x state))
+(defun illegal-ruler-extenders-values (x wrld)
+ (declare (xargs :guard (and (symbol-listp x)
+ (plist-worldp wrld))))
+ (cond ((endp x) nil)
+ ((or (eq (car x) :lambdas)
+ (function-symbolp (car x) wrld))
+ (illegal-ruler-extenders-values (cdr x) wrld))
+ (t (cons (car x)
+ (illegal-ruler-extenders-values (cdr x) wrld)))))
-(defun set-print-escape (x state)
- (declare (xargs :guard (state-p state)))
- (f-put-global 'print-escape x state))
+(defun table-alist (name wrld)
-(defun set-print-pretty (x state)
- (declare (xargs :guard (state-p state)))
- (f-put-global 'print-pretty x state))
+; Return the named table as an alist.
-(defun set-print-radix (x state)
- (declare (xargs :guard (state-p state)))
- (f-put-global 'print-radix x state))
+ (declare (xargs :guard (and (symbolp name)
+ (plist-worldp wrld))))
+ (getprop name 'table-alist nil 'current-acl2-world wrld))
-(defun set-print-readably (x state)
- (declare (xargs :guard (state-p state)))
- (f-put-global 'print-readably x state))
+(defun ruler-extenders-msg-aux (vals return-last-table)
-(defun check-null-or-natp (n fn)
- (declare (xargs :guard t))
- (or (null n)
- (natp n)
- (hard-error fn
- "The argument of ~x0 must be ~x1 or a positive integer, but ~
- ~x2 is neither."
- (list (cons #\0 fn)
- (cons #\1 nil)
- (cons #\2 n)))))
+; We return the intersection of vals with the symbols in the cdr of
+; return-last-table.
-(defun set-print-length (n state)
+ (declare (xargs :guard (and (symbol-listp vals)
+ (symbol-alistp return-last-table))))
+ (cond ((endp return-last-table) nil)
+ (t (let* ((first-cdr (cdar return-last-table))
+ (sym (if (consp first-cdr) (car first-cdr) first-cdr)))
+ (cond ((member-eq sym vals)
+ (cons sym
+ (ruler-extenders-msg-aux vals
+ (cdr return-last-table))))
+ (t (ruler-extenders-msg-aux vals
+ (cdr return-last-table))))))))
+
+(defun ruler-extenders-msg (x wrld)
+
+; This message, if not nil, is passed to chk-ruler-extenders.
+
+ (declare (xargs :guard (and (plist-worldp wrld)
+ (symbol-alistp (fgetprop 'return-last-table
+ 'table-alist
+ nil wrld)))))
+ (cond ((member-eq x '(:ALL :BASIC :LAMBDAS))
+ nil)
+ ((and (consp x)
+ (eq (car x) 'quote))
+ (msg "~x0 has a superfluous QUOTE, which you may wish to remove"
+ x))
+ ((not (symbol-listp x))
+ (msg "~x0 is not a true list of symbols" x))
+ (t (let* ((vals (illegal-ruler-extenders-values x wrld))
+ (suspects (ruler-extenders-msg-aux
+ vals
+ (table-alist 'return-last-table wrld))))
+ (cond (vals
+ (msg "~&0 ~#0~[is not a~/are not~] legal ruler-extenders ~
+ value~#0~[~/s~].~@1"
+ vals
+ (cond (suspects
+ (msg " Note in particular that ~&0 ~#0~[is a ~
+ macro~/are macros~] that may expand to ~
+ calls of ~x1, which you may want to ~
+ specify instead."
+ suspects 'return-last))
+ (t ""))))
+ (t nil))))))
+
+(defmacro chk-ruler-extenders (x soft ctx wrld)
+ (let ((err-str "The proposed ruler-extenders is illegal because ~@0."))
+ `(let ((ctx ,ctx)
+ (err-str ,err-str)
+ (msg (ruler-extenders-msg ,x ,wrld)))
+ (cond (msg ,(cond ((eq soft 'soft) `(er soft ctx err-str msg))
+ (t `(illegal ctx err-str (list (cons #\0 msg))))))
+ (t ,(cond ((eq soft 'soft) '(value t))
+ (t t)))))))
+
+(defmacro fixnum-bound () ; most-positive-fixnum in Allegro CL and many others
+ (1- (expt 2 29)))
+
+(defconst *default-step-limit*
+
+; The defevaluator event near the top of community book
+; books/meta/meta-plus-equal.lisp, submitted at the top level without any
+; preceding events, takes over 40,000 steps. Set the following to 40000 in
+; order to make that event quickly exceed the default limit.
+
+ (fixnum-bound))
+
+(defun include-book-dir-alist-entry-p (key val os)
+ (declare (xargs :guard t))
+ (and (keywordp key)
+ (stringp val)
+ (absolute-pathname-string-p val t os)))
+
+(defun include-book-dir-alistp (x os)
+ (declare (xargs :guard t))
+ (cond ((atom x) (null x))
+ (t (and (consp (car x))
+ (include-book-dir-alist-entry-p (caar x) (cdar x) os)
+ (include-book-dir-alistp (cdr x) os)))))
+
+(table acl2-defaults-table nil nil
+
+; Warning: If you add or delete a new key, there will probably be a change you
+; should make to a list in chk-embedded-event-form. (Search there for
+; add-include-book-dir, and consider keeping that list alphabetical, just for
+; convenience.)
+
+; Developer suggestion: The following form provides an example of how to add a
+; new key to the table guard, in this case,
+
+; (setf (cadr (assoc-eq 'table-guard
+; (get 'acl2-defaults-table *current-acl2-world-key*)))
+; `(if (eq key ':new-key)
+; (if (eq val 't) 't (symbol-listp val))
+; ,(cadr (assoc-eq 'table-guard
+; (get 'acl2-defaults-table
+; *current-acl2-world-key*)))))
+
+ :guard
+ (cond
+ ((eq key :defun-mode)
+ (member-eq val '(:logic :program)))
+ ((eq key :verify-guards-eagerness)
+ (member val '(0 1 2)))
+ ((eq key :enforce-redundancy)
+ (member-eq val '(t nil :warn)))
+ #+acl2-legacy-doc
+ ((eq key :ignore-doc-string-error)
+ (member-eq val '(t nil :warn)))
+ ((eq key :compile-fns)
+ (member-eq val '(t nil)))
+ ((eq key :measure-function)
+ (and (symbolp val)
+ (function-symbolp val world)
+
+; The length expression below is just (arity val world) but we don't have arity
+; yet.
+
+ (= (length (getprop val 'formals t 'current-acl2-world world))
+ 1)))
+ ((eq key :well-founded-relation)
+ (and (symbolp val)
+ (assoc-eq val (global-val 'well-founded-relation-alist world))))
+ ((eq key :bogus-defun-hints-ok)
+ (member-eq val '(t nil :warn)))
+ ((eq key :bogus-mutual-recursion-ok)
+ (member-eq val '(t nil :warn)))
+ ((eq key :irrelevant-formals-ok)
+ (member-eq val '(t nil :warn)))
+ ((eq key :ignore-ok)
+ (member-eq val '(t nil :warn)))
+ ((eq key :bdd-constructors)
+
+; We could insist that the symbols are function symbols by using
+; (all-function-symbolps val world),
+; but perhaps one wants to set the bdd-constructors even before defining the
+; functions.
+
+ (symbol-listp val))
+ ((eq key :ttag)
+ (or (null val)
+ (and (keywordp val)
+ (not (equal (symbol-name val) "NIL")))))
+ ((eq key :state-ok)
+ (member-eq val '(t nil)))
+
+; Rockwell Addition: See the doc string associated with
+; set-let*-abstractionp.
+
+ ((eq key :let*-abstractionp)
+ (member-eq val '(t nil)))
+
+ ((eq key :backchain-limit)
+ (and (true-listp val)
+ (equal (length val) 2)
+ (or (null (car val))
+ (natp (car val)))
+ (or (null (cadr val))
+ (natp (cadr val)))))
+ ((eq key :step-limit)
+ (and (natp val)
+ (<= val *default-step-limit*)))
+ ((eq key :default-backchain-limit)
+ (and (true-listp val)
+ (equal (length val) 2)
+ (or (null (car val))
+ (natp (car val)))
+ (or (null (cadr val))
+ (natp (cadr val)))))
+ ((eq key :rewrite-stack-limit)
+ (unsigned-byte-p 29 val))
+ ((eq key :case-split-limitations)
+
+; In set-case-split-limitations we permit val to be nil and default that
+; to (nil nil).
+
+ (and (true-listp val)
+ (equal (length val) 2)
+ (or (null (car val))
+ (natp (car val)))
+ (or (null (cadr val))
+ (natp (cadr val)))))
+ ((eq key :match-free-default)
+ (member-eq val '(:once :all nil)))
+ ((eq key :match-free-override)
+ (or (eq val :clear)
+ (null (non-free-var-runes val
+ (free-var-runes :once world)
+ (free-var-runes :all world)
+ nil))))
+ ((eq key :match-free-override-nume)
+ (integerp val))
+ ((eq key :non-linearp)
+ (booleanp val))
+ ((eq key :tau-auto-modep)
+ (booleanp val))
+ ((eq key :include-book-dir-alist)
+ (and (include-book-dir-alistp val (os world))
+ (null (assoc-eq :SYSTEM val))))
+ ((eq key :ruler-extenders)
+ (or (eq val :all)
+ (chk-ruler-extenders val hard 'acl2-defaults-table world)))
+ #+hons
+ ((eq key :memoize-ideal-okp)
+ (or (eq val :warn)
+ (booleanp val)))
+ (t nil)))
+
+; (set-state-ok t)
+(table acl2-defaults-table :state-ok t)
+
+(defmacro print-case ()
+ '(f-get-global 'print-case state))
+
+; (defmacro acl2-print-case (&optional (st 'state))
+; (declare (ignore st))
+; `(er soft 'acl2-print-case
+; "Macro ~x0 has been replaced by macro ~x1."
+; 'acl2-print-case 'print-case))
+
+(defmacro acl2-print-case (&optional (st 'state))
+ `(print-case ,st))
+
+(defun set-print-case (case state)
+ (declare (xargs :guard (and (or (eq case :upcase) (eq case :downcase))
+ (state-p state))))
+ (prog2$ (or (eq case :upcase)
+ (eq case :downcase)
+ (illegal 'set-print-case
+ "The value ~x0 is illegal as an ACL2 print-case, which ~
+ must be :UPCASE or :DOWNCASE."
+ (list (cons #\0 case))))
+ (f-put-global 'print-case case state)))
+
+(defmacro set-acl2-print-case (case)
+ (declare (ignore case))
+ '(er soft 'set-acl2-print-case
+ "Macro ~x0 has been replaced by function ~x1."
+ 'set-acl2-print-case 'set-print-case))
+
+(defmacro print-base (&optional (st 'state))
+ `(f-get-global 'print-base ,st))
+
+(defmacro acl2-print-base (&optional (st 'state))
+ `(print-base ,st))
+
+(defmacro print-radix (&optional (st 'state))
+ `(f-get-global 'print-radix ,st))
+
+(defmacro acl2-print-radix (&optional (st 'state))
+ `(print-radix ,st))
+
+(defun check-print-base (print-base ctx)
+
+; Warning: Keep this in sync with print-base-p, and keep the format warning
+; below in sync with princ$.
+
+ (declare (xargs :guard t))
+ (if (print-base-p print-base)
+ nil
+ (hard-error ctx
+ "The value ~x0 is illegal as a print-base, which must be 2, ~
+ 8, 10, or 16"
+ (list (cons #\0 print-base))))
+ #+(and (not acl2-loop-only) (not allegro))
+
+; There is special handling when #+allegro in princ$ and prin1$, which is why
+; we avoid the following test for #+allegro.
+
+ (when (int= print-base 16)
+ (let ((*print-base* 16)
+ (*print-radix* nil))
+ (or (equal (prin1-to-string 10) "A")
+
+; If we get here, a solution is simply to treat the underlying Lisp as we treat
+; #+allegro in the raw Lisp code for princ$ and prin1$.
+
+ (illegal 'check-print-base
+ "ERROR: This Common Lisp does not print in radix 16 using ~
+ upper-case alphabetic hex digits: for example, it prints ~
+ ~x0 instead of ~x1. Such printing is consistent with the ~
+ Common Lisp spec but is not reflected in ACL2's axioms ~
+ about printing (function digit-to-char, in support of ~
+ functions princ$ and prin1$), which in turn reflect the ~
+ behavior of the majority of Common Lisp implementations of ~
+ which we are aware. If the underlying Common Lisp's ~
+ implementors can make a patch available to remedy this ~
+ situation, please let the ACL2 implementors know and we ~
+ will incorporate a patch for that Common Lisp. In the ~
+ meantime, we do not see any way that this situation can ~
+ cause any unsoundness, so here is a workaround that you ~
+ can use at your own (minimal) risk. In raw Lisp, execute ~
+ the following form:~|~%~x2~|"
+ (list (cons #\0 (prin1-to-string 10))
+ (cons #\1 "A")
+ (cons #\2 '(defun check-print-base (print-base ctx)
+ (declare (ignore print-base ctx))
+ nil))))))
+ nil)
+ #-acl2-loop-only nil)
+
+(defun set-print-base (base state)
+ (declare (xargs :guard (and (print-base-p base)
+ (state-p state))))
+ (prog2$ (check-print-base base 'set-print-base)
+ (f-put-global 'print-base base state)))
+
+(defmacro set-acl2-print-base (base)
+ (declare (ignore base))
+ '(er soft 'set-acl2-print-base
+ "Macro ~x0 has been replaced by function ~x1."
+ 'set-acl2-print-base 'set-print-base))
+
+(defun set-print-circle (x state)
+ (declare (xargs :guard (state-p state)))
+ (f-put-global 'print-circle x state))
+
+(defun set-print-escape (x state)
+ (declare (xargs :guard (state-p state)))
+ (f-put-global 'print-escape x state))
+
+(defun set-print-pretty (x state)
+ (declare (xargs :guard (state-p state)))
+ (f-put-global 'print-pretty x state))
+
+(defun set-print-radix (x state)
+ (declare (xargs :guard (state-p state)))
+ (f-put-global 'print-radix x state))
+
+(defun set-print-readably (x state)
+ (declare (xargs :guard (state-p state)))
+ (f-put-global 'print-readably x state))
+
+(defun check-null-or-natp (n fn)
+ (declare (xargs :guard t))
+ (or (null n)
+ (natp n)
+ (hard-error fn
+ "The argument of ~x0 must be ~x1 or a positive integer, but ~
+ ~x2 is neither."
+ (list (cons #\0 fn)
+ (cons #\1 nil)
+ (cons #\2 n)))))
+
+(defun set-print-length (n state)
(declare (xargs :guard (and (or (null n) (natp n))
(state-p state))))
(prog2$ (check-null-or-natp n 'set-print-length)
@@ -16207,6 +16634,10 @@
'(assert$ ,test ,form)))
,form))
+(defmacro assert* (test form)
+ `(and (mbt* ,test)
+ ,form))
+
(defun fmt-to-comment-window (str alist col evisc-tuple)
; WARNING: Keep this in sync with fmt-to-comment-window!.
@@ -17444,31 +17875,6 @@
(true-listp (subseq seq start end)))
:rule-classes :type-prescription)
-; The following constants and the next two functions, pathname-os-to-unix and
-; pathname-unix-to-os, support the use of Unix-style filenames in ACL2 as
-; described in the Essay on Pathnames in interface-raw.lisp.
-
-; The following constants represent our decision to use Unix-style pathnames
-; within ACL2. See the Essay on Pathnames in interface-raw.lisp.
-
-(defconst *directory-separator*
- #\/)
-
-(defconst *directory-separator-string*
- (string *directory-separator*))
-
-(defmacro os-er (os fnname)
- `(illegal ,fnname
- "The case where (os (w state)) is ~x0 has not been handled by the ~
- ACL2 implementors for the function ~x1. Please inform them of this ~
- problem."
- (list (cons #\0 ,os)
- (cons #\1 ,fnname))))
-
-(defun os (wrld)
- (declare (xargs :guard (plist-worldp wrld)))
- (global-val 'operating-system wrld))
-
(local (in-theory (enable boundp-global1)))
(verify-guards w)
@@ -20010,122 +20416,24 @@
(list 'mv-let
mv-vars
body
- (cons 'mv
- (cons (list 'the type (car mv-vars))
- (cdr mv-vars))))))
-
-#-acl2-loop-only
-(defmacro the-mv (vars type body &optional state-pos)
- (declare (ignore #-acl2-mv-as-values vars
- state-pos))
- #+acl2-mv-as-values (list 'the
- `(values ,type ,@(make-list (if (integerp vars)
- (1- vars)
- (length (cdr vars)))
- :initial-element t))
- body)
- #-acl2-mv-as-values (list 'the type body))
-
-(defmacro the2s (x y)
- (list 'the-mv 2 x y 1))
-
-; Here we implement acl2-defaults-table, which is used for handling the default
-; defun-mode and other defaults.
-
-; WARNING: If you add a new key to acl-defaults-table, and hence a new set-
-; function for smashing the acl2-defaults-table at that key, then be sure to
-; add that set- function to the list in chk-embedded-event-form! E.g., when we
-; added the :irrelevant-formals-ok key we also defined
-; set-irrelevant-formals-ok and then added it to the list in
-; chk-embedded-event-form. Also add similarly to :DOC acl2-defaults-table and
-; to primitive-event-macros.
-
-(defun non-free-var-runes (runes free-var-runes-once free-var-runes-all acc)
- (declare (xargs :guard (and (true-listp runes)
- (true-listp free-var-runes-once)
- (true-listp free-var-runes-all))))
- (if (endp runes)
- acc
- (non-free-var-runes (cdr runes)
- free-var-runes-once free-var-runes-all
- (if (or (member-equal (car runes)
- free-var-runes-once)
- (member-equal (car runes)
- free-var-runes-all))
- acc
- (cons (car runes) acc)))))
-
-(defun free-var-runes (flg wrld)
- (declare (xargs :guard (plist-worldp wrld)))
- (cond
- ((eq flg :once)
- (global-val 'free-var-runes-once wrld))
- (t ; (eq flg :all)
- (global-val 'free-var-runes-all wrld))))
-
-(defthm natp-position-ac ; for admission of absolute-pathname-string-p
- (implies (and (integerp acc)
- (<= 0 acc))
- (or (equal (position-ac item lst acc) nil)
- (and (integerp (position-ac item lst acc))
- (<= 0 (position-ac item lst acc)))))
- :rule-classes :type-prescription)
-
-(defun absolute-pathname-string-p (str directoryp os)
-
-; Str is a Unix-style pathname. However, on Windows, Unix-style absolute
-; pathnames may start with a prefix such as "c:"; see mswindows-drive.
-
-; Directoryp is non-nil when we require str to represent a directory in ACL2
-; with Unix-style syntax, returning nil otherwise.
-
-; Function expand-tilde-to-user-home-dir should already have been applied
-; before testing str with this function.
-
- (declare (xargs :guard (stringp str)))
- (let ((len (length str)))
- (and (< 0 len)
- (cond ((and (eq os :mswindows) ; hence os is not nil
- (let ((pos-colon (position #\: str))
- (pos-sep (position *directory-separator* str)))
- (and pos-colon
- (eql pos-sep (1+ pos-colon))))
- t))
- ((eql (char str 0) *directory-separator*)
- t)
- (t ; possible hard error for ~ or ~/...
- (and (eql (char str 0) #\~)
-
-; Note that a leading character of `~' need not get special treatment by
-; Windows. See also expand-tilde-to-user-home-dir.
-
- (not (eq os :mswindows))
- (prog2$ (and (or (eql 1 len)
- (eql (char str 1)
- *directory-separator*))
- (hard-error 'absolute-pathname-string-p
- "Implementation error: Forgot ~
- to apply ~
- expand-tilde-to-user-home-dir ~
- before calling ~
- absolute-pathname-string-p. ~
- Please contact the ACL2 ~
- implementors."
- nil))
- t))))
- (if directoryp
- (eql (char str (1- len)) *directory-separator*)
- t))))
+ (cons 'mv
+ (cons (list 'the type (car mv-vars))
+ (cdr mv-vars))))))
-(defun illegal-ruler-extenders-values (x wrld)
- (declare (xargs :guard (and (symbol-listp x)
- (plist-worldp wrld))))
- (cond ((endp x) nil)
- ((or (eq (car x) :lambdas)
- (function-symbolp (car x) wrld))
- (illegal-ruler-extenders-values (cdr x) wrld))
- (t (cons (car x)
- (illegal-ruler-extenders-values (cdr x) wrld)))))
+#-acl2-loop-only
+(defmacro the-mv (vars type body &optional state-pos)
+ (declare (ignore #-acl2-mv-as-values vars
+ state-pos))
+ #+acl2-mv-as-values (list 'the
+ `(values ,type ,@(make-list (if (integerp vars)
+ (1- vars)
+ (length (cdr vars)))
+ :initial-element t))
+ body)
+ #-acl2-mv-as-values (list 'the type body))
+
+(defmacro the2s (x y)
+ (list 'the-mv 2 x y 1))
; Intersection$
@@ -20218,227 +20526,6 @@
(t ; (equal test 'equal)
`(xxxjoin 'intersection-equal ,args))))))))
-(defun table-alist (name wrld)
-
-; Return the named table as an alist.
-
- (declare (xargs :guard (and (symbolp name)
- (plist-worldp wrld))))
- (getprop name 'table-alist nil 'current-acl2-world wrld))
-
-(defun ruler-extenders-msg-aux (vals return-last-table)
-
-; We return the intersection of vals with the symbols in the cdr of
-; return-last-table.
-
- (declare (xargs :guard (and (symbol-listp vals)
- (symbol-alistp return-last-table))))
- (cond ((endp return-last-table) nil)
- (t (let* ((first-cdr (cdar return-last-table))
- (sym (if (consp first-cdr) (car first-cdr) first-cdr)))
- (cond ((member-eq sym vals)
- (cons sym
- (ruler-extenders-msg-aux vals
- (cdr return-last-table))))
- (t (ruler-extenders-msg-aux vals
- (cdr return-last-table))))))))
-
-(defun ruler-extenders-msg (x wrld)
-
-; This message, if not nil, is passed to chk-ruler-extenders.
-
- (declare (xargs :guard (and (plist-worldp wrld)
- (symbol-alistp (fgetprop 'return-last-table
- 'table-alist
- nil wrld)))))
- (cond ((member-eq x '(:ALL :BASIC :LAMBDAS))
- nil)
- ((and (consp x)
- (eq (car x) 'quote))
- (msg "~x0 has a superfluous QUOTE, which you may wish to remove"
- x))
- ((not (symbol-listp x))
- (msg "~x0 is not a true list of symbols" x))
- (t (let* ((vals (illegal-ruler-extenders-values x wrld))
- (suspects (ruler-extenders-msg-aux
- vals
- (table-alist 'return-last-table wrld))))
- (cond (vals
- (msg "~&0 ~#0~[is not a~/are not~] legal ruler-extenders ~
- value~#0~[~/s~].~@1"
- vals
- (cond (suspects
- (msg " Note in particular that ~&0 ~#0~[is a ~
- macro~/are macros~] that may expand to ~
- calls of ~x1, which you may want to ~
- specify instead."
- suspects 'return-last))
- (t ""))))
- (t nil))))))
-
-(defmacro chk-ruler-extenders (x soft ctx wrld)
- (let ((err-str "The proposed ruler-extenders is illegal because ~@0."))
- `(let ((ctx ,ctx)
- (err-str ,err-str)
- (msg (ruler-extenders-msg ,x ,wrld)))
- (cond (msg ,(cond ((eq soft 'soft) `(er soft ctx err-str msg))
- (t `(illegal ctx err-str (list (cons #\0 msg))))))
- (t ,(cond ((eq soft 'soft) '(value t))
- (t t)))))))
-
-(defmacro fixnum-bound () ; most-positive-fixnum in Allegro CL and many others
- (1- (expt 2 29)))
-
-(defconst *default-step-limit*
-
-; The defevaluator event near the top of community book
-; books/meta/meta-plus-equal.lisp, submitted at the top level without any
-; preceding events, takes over 40,000 steps. Set the following to 40000 in
-; order to make that event quickly exceed the default limit.
-
- (fixnum-bound))
-
-(defun include-book-dir-alist-entry-p (key val os)
- (declare (xargs :guard t))
- (and (keywordp key)
- (stringp val)
- (absolute-pathname-string-p val t os)))
-
-(defun include-book-dir-alistp (x os)
- (declare (xargs :guard t))
- (cond ((atom x) (null x))
- (t (and (consp (car x))
- (include-book-dir-alist-entry-p (caar x) (cdar x) os)
- (include-book-dir-alistp (cdr x) os)))))
-
-(table acl2-defaults-table nil nil
-
-; Warning: If you add or delete a new key, there will probably be a change you
-; should make to a list in chk-embedded-event-form. (Search there for
-; add-include-book-dir, and consider keeping that list alphabetical, just for
-; convenience.)
-
-; Developer suggestion: The following form provides an example of how to add a
-; new key to the table guard, in this case,
-
-; (setf (cadr (assoc-eq 'table-guard
-; (get 'acl2-defaults-table *current-acl2-world-key*)))
-; `(if (eq key ':new-key)
-; (if (eq val 't) 't (symbol-listp val))
-; ,(cadr (assoc-eq 'table-guard
-; (get 'acl2-defaults-table
-; *current-acl2-world-key*)))))
-
- :guard
- (cond
- ((eq key :defun-mode)
- (member-eq val '(:logic :program)))
- ((eq key :verify-guards-eagerness)
- (member val '(0 1 2)))
- ((eq key :enforce-redundancy)
- (member-eq val '(t nil :warn)))
- #+acl2-legacy-doc
- ((eq key :ignore-doc-string-error)
- (member-eq val '(t nil :warn)))
- ((eq key :compile-fns)
- (member-eq val '(t nil)))
- ((eq key :measure-function)
- (and (symbolp val)
- (function-symbolp val world)
-
-; The length expression below is just (arity val world) but we don't have arity
-; yet.
-
- (= (length (getprop val 'formals t 'current-acl2-world world))
- 1)))
- ((eq key :well-founded-relation)
- (and (symbolp val)
- (assoc-eq val (global-val 'well-founded-relation-alist world))))
- ((eq key :bogus-defun-hints-ok)
- (member-eq val '(t nil :warn)))
- ((eq key :bogus-mutual-recursion-ok)
- (member-eq val '(t nil :warn)))
- ((eq key :irrelevant-formals-ok)
- (member-eq val '(t nil :warn)))
- ((eq key :ignore-ok)
- (member-eq val '(t nil :warn)))
- ((eq key :bdd-constructors)
-
-; We could insist that the symbols are function symbols by using
-; (all-function-symbolps val world),
-; but perhaps one wants to set the bdd-constructors even before defining the
-; functions.
-
- (symbol-listp val))
- ((eq key :ttag)
- (or (null val)
- (and (keywordp val)
- (not (equal (symbol-name val) "NIL")))))
- ((eq key :state-ok)
- (member-eq val '(t nil)))
-
-; Rockwell Addition: See the doc string associated with
-; set-let*-abstractionp.
-
- ((eq key :let*-abstractionp)
- (member-eq val '(t nil)))
-
- ((eq key :backchain-limit)
- (and (true-listp val)
- (equal (length val) 2)
- (or (null (car val))
- (natp (car val)))
- (or (null (cadr val))
- (natp (cadr val)))))
- ((eq key :step-limit)
- (and (natp val)
- (<= val *default-step-limit*)))
- ((eq key :default-backchain-limit)
- (and (true-listp val)
- (equal (length val) 2)
- (or (null (car val))
- (natp (car val)))
- (or (null (cadr val))
- (natp (cadr val)))))
- ((eq key :rewrite-stack-limit)
- (unsigned-byte-p 29 val))
- ((eq key :case-split-limitations)
-
-; In set-case-split-limitations we permit val to be nil and default that
-; to (nil nil).
-
- (and (true-listp val)
- (equal (length val) 2)
- (or (null (car val))
- (natp (car val)))
- (or (null (cadr val))
- (natp (cadr val)))))
- ((eq key :match-free-default)
- (member-eq val '(:once :all nil)))
- ((eq key :match-free-override)
- (or (eq val :clear)
- (null (non-free-var-runes val
- (free-var-runes :once world)
- (free-var-runes :all world)
- nil))))
- ((eq key :match-free-override-nume)
- (integerp val))
- ((eq key :non-linearp)
- (booleanp val))
- ((eq key :tau-auto-modep)
- (booleanp val))
- ((eq key :include-book-dir-alist)
- (and (include-book-dir-alistp val (os world))
- (null (assoc-eq :SYSTEM val))))
- ((eq key :ruler-extenders)
- (or (eq val :all)
- (chk-ruler-extenders val hard 'acl2-defaults-table world)))
- #+hons
- ((eq key :memoize-ideal-okp)
- (or (eq val :warn)
- (booleanp val)))
- (t nil)))
-
#+acl2-loop-only
(defmacro set-enforce-redundancy (x)
`(state-global-let*
@@ -20940,7 +21027,7 @@
(defun default-backchain-limit (wrld flg)
(declare (xargs :guard
- (and (member-eq flg '(:ts :rewrite))
+ (and (member-eq flg '(:ts :rewrite :meta))
(plist-worldp wrld)
(alistp (table-alist 'acl2-defaults-table wrld))
(true-listp (assoc-eq :default-backchain-limit
@@ -21237,7 +21324,9 @@
(binary-logxor logxor . t)
(binary-logeqv logeqv . t)
(binary-por por . t)
- (binary-pand pand . t))
+ (binary-pand pand . t)
+ (unary-- -)
+ (unary-/ /))
:clear)
(defmacro add-macro-fn (macro macro-fn &optional right-associate-p)
@@ -21412,8 +21501,8 @@
nil)
(defmacro add-include-book-dir (keyword dir)
- `(change-include-book-dir ,keyword
- ,dir
+ `(change-include-book-dir ',keyword
+ ',dir
'add-include-book-dir
; We use state in the loop but the live state outside it. This could be a
@@ -21456,8 +21545,8 @@
:ignore)))
(defmacro add-include-book-dir! (keyword dir)
- `(change-include-book-dir ,keyword
- ,dir
+ `(change-include-book-dir ',keyword
+ ',dir
'add-include-book-dir!
; We use state in the loop but the live state outside it. This could be a
@@ -22770,12 +22859,11 @@
; The following variables implement prover time limits. The variable
; *acl2-time-limit* is nil by default, but is set to a positive time limit (in
; units of internal-time-units-per-second) by with-prover-time-limit, and is
-; set to 0 to indicate that a proof with a time limit has been interrupted (see
-; our-abort).
+; set to 0 to indicate that a proof has been interrupted (see our-abort).
; The variable *acl2-time-limit-boundp* is used in bind-acl2-time-limit, which
-; provides the only legal way to bind bind *acl2-time-limit*. For more
-; information about these variables, see bind-acl2-time-limit.
+; provides the only legal way to bind *acl2-time-limit*. For more information
+; about these variables, see bind-acl2-time-limit.
(defparameter *acl2-time-limit* nil)
@@ -23051,8 +23139,8 @@
; However, the description above is a bit flawed if we enter a wormhole. We
; really want a fresh binding of *acl2-time-limit* in that case, as illustrated
-; by the following example, which explains the call of bind-acl2-time-limit in
-; wormhole1.
+; by the following example, which explains the call of bind-acl2-time-limit
+; around ld-fn in wormhole1.
; (defun foo (x) (cons x x))
; (brr t)
@@ -23068,7 +23156,8 @@
; ; error due to being out of time!
; (thm (equal (append (append x y) z)
; (append x y z)))
-; ; The following fails after enough THM calls just above, but that's not
+; ; Without the call of bind-acl2-time-limit around ld-fn in wormhole1,
+; ; the following fails after enough THM calls just above. But that's not
; ; surprising, since time-limits are based on total cpu time, which includes
; ; time in the wormhole.
; :go
@@ -24034,6 +24123,10 @@
(verify-termination-boot-strap nonnegative-integer-quotient)
(verify-termination-boot-strap floor)
(verify-termination-boot-strap symbol-listp)
+ (verify-termination-boot-strap binary-append) ; for string-append
+; The following avoids an ACL2(p) loop in thanks-for-the-hint; see
+; string-append.
+ (verify-termination-boot-strap string-append)
)
@@ -24932,6 +25025,13 @@
)
#-acl2-loop-only
+(defmacro heap-bytes-allocated ()
+ '(the-mfixnum #+ccl (ccl::total-bytes-allocated)
+ #+sbcl (sb-ext:get-bytes-consed)
+ #-(or ccl sbcl)
+ (error "Heap-bytes-allocated is unknown for this host Lisp.")))
+
+#-acl2-loop-only
(defmacro our-time (x &key real-mintime run-mintime minalloc msg args)
(let ((g-real-mintime (gensym))
(g-run-mintime (gensym))
@@ -24940,7 +25040,7 @@
(g-args (gensym))
(g-start-real-time (gensym))
(g-start-run-time (gensym))
- #+ccl
+ #+(or ccl sbcl)
(g-start-alloc (gensym)))
`(let ((,g-real-mintime ,real-mintime)
(,g-run-mintime ,run-mintime)
@@ -24991,8 +25091,8 @@
(,g-start-run-time
#-gcl (get-internal-run-time)
#+gcl (multiple-value-list (get-internal-run-time)))
- #+ccl
- (,g-start-alloc (CCL::total-bytes-allocated)))
+ #+(or ccl sbcl)
+ (,g-start-alloc (heap-bytes-allocated)))
(our-multiple-value-prog1
,x
,(protect-mv
@@ -25000,8 +25100,8 @@
#-gcl (get-internal-run-time)
#+gcl (multiple-value-list (get-internal-run-time)))
(end-real-time (get-internal-real-time))
- #+ccl ; evaluate before doing computations below:
- (allocated (- (ccl::total-bytes-allocated)
+ #+(or ccl sbcl) ; evaluate before computations below:
+ (allocated (- (heap-bytes-allocated)
,g-start-alloc))
(float-units-sec (float internal-time-units-per-second))
(real-elapsed (/ (- end-real-time ,g-start-real-time)
@@ -25029,7 +25129,7 @@
(< real-elapsed (float ,g-real-mintime)))
(and ,g-run-mintime
(< run-elapsed (float ,g-run-mintime)))
- #+ccl
+ #+(or ccl sbcl)
(and ,g-minalloc
(< allocated ,g-minalloc))))
(let* ((alist (list* (cons #\t (format nil "~,2F"
@@ -25049,9 +25149,9 @@
nil "~,2F"
child-sys-elapsed)))
(cons #\a
- #+ccl
+ #+(or ccl sbcl)
(format nil "~:D" allocated)
- #-ccl
+ #-(or ccl sbcl)
"[unknown]")
(cons #\f ',x)
(cons #\e (evisc-tuple
@@ -25064,7 +25164,7 @@
#\5 #\6 #\7 #\8 #\9)
,g-args))))
(,g-msg (or ,g-msg
- #+ccl
+ #+(or ccl sbcl)
"; ~Xfe took ~|; ~st seconds realtime, ~
~sc seconds runtime~|; (~sa bytes ~
allocated).~%"
@@ -25267,7 +25367,7 @@
(declare (xargs :guard t))
#-acl2-loop-only
- (when (global-val 'boot-strap-flg (w *the-live-state*))
+ (when (f-get-global 'boot-strap-flg *the-live-state*)
; We don't know why SBCL 1.0.37 hung during guard verification of
; maybe-print-call-history during the boot-strap. But we sidestep that issue
@@ -25888,7 +25988,9 @@
; Each cdr is either nil or a msg.
- `((open-output-channel!)
+ `((hons-wash!)
+ (hons-clear!)
+ (open-output-channel!)
(progn!) ; protected because it is legal in books; it's OK to omit progn-fn
(remove-untouchable-fn
.
@@ -26470,3 +26572,13 @@
\"~s1\"."
pos s)
0)))))))
+
+(defun check-dcl-guardian (val term)
+
+; See call of (set-guard-msg check-dcl-guardian ...) later in the sources. The
+; term argument is included in support of the call (set-guard-msg
+; check-dcl-guardian ...) in these sources.
+
+ (declare (xargs :guard val))
+ (declare (ignore val term))
+ t)
diff -Nru acl2-7.0/basis-a.lisp acl2-7.1/basis-a.lisp
--- acl2-7.0/basis-a.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/basis-a.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
@@ -4805,7 +4805,7 @@
; Warning: Keep this in sync with default-state-vars.
- ((safe-mode . temp-touchable-vars)
+ ((safe-mode boot-strap-flg . temp-touchable-vars)
.
(guard-checking-on ld-skip-proofsp
temp-touchable-fns . parallel-execution-enabled))
@@ -4814,6 +4814,7 @@
(defmacro default-state-vars
(state-p &key
(safe-mode 'nil safe-mode-p)
+ (boot-strap-flg 'nil boot-strap-flg-p)
(temp-touchable-vars 'nil temp-touchable-vars-p)
(guard-checking-on 't guard-checking-on-p)
(ld-skip-proofsp 'nil ld-skip-proofsp-p)
@@ -4833,6 +4834,10 @@
,(if safe-mode-p
safe-mode
'(f-get-global 'safe-mode state))
+ :boot-strap-flg
+ ,(if boot-strap-flg-p
+ boot-strap-flg
+ '(f-get-global 'boot-strap-flg state))
:temp-touchable-vars
,(if temp-touchable-vars-p
temp-touchable-vars
@@ -6076,6 +6081,13 @@
(defvar ,the-live-name)
#+hons ,@(and (null congruent-to)
+
+; It has occurred to us that this defg form might be avoidable when
+; non-memoizable is true, since the purpose of st-lst is probably only to
+; support memoize-flush. However, it seems harmless enough to lay down this
+; form even when non-memoizable is true, so we go ahead and do so rather than
+; think carefully about avoiding it.
+
`((defg ,(st-lst name) nil)))
; Now we lay down the defuns of the recognizers, accessors and updaters as
@@ -6888,3 +6900,122 @@
return-from-lp init-forms)
`(save-exec-fn ,exec-filename ,extra-startup-string ,host-lisp-args
,toplevel-args ,inert-args ,return-from-lp ,init-forms))
+
+(defconst *slash-dot-dot*
+ (concatenate 'string *directory-separator-string* ".."))
+
+(defconst *length-slash-dot-dot*
+ (length *slash-dot-dot*))
+
+(defun find-dot-dot (full-pathname i)
+
+; Termination and even guard-verification are proved in community book
+; books/system/extend-pathname.lisp.
+
+ (declare (xargs :guard (and (stringp full-pathname)
+ (natp i)
+ (<= i (length full-pathname)))
+ :measure (nfix (- (length full-pathname) i))))
+ (let ((pos (search *slash-dot-dot* full-pathname :start2 i)))
+ (and pos
+ (let ((pos+3 (+ pos *length-slash-dot-dot*)))
+ (cond
+ ((or (eql pos+3 (length full-pathname))
+ (eql (char full-pathname pos+3) *directory-separator*))
+ pos)
+ ((mbt (<= pos+3 (length full-pathname)))
+ (find-dot-dot full-pathname pos+3)))))))
+
+(mutual-recursion
+
+; The :measure declarations in this mutual-recursion nest are in support of
+; community book books/system/extend-pathname.lisp. The :guard declarations
+; below are intended to be correct, but we won't really know until guards have
+; been verified; it seems quite possible that the guards will need to be
+; adjusted.
+
+(defun cancel-dot-dots (full-pathname)
+ (declare (xargs :guard (stringp full-pathname)
+ :measure (* 2 (length full-pathname))))
+ (let ((p (find-dot-dot full-pathname 0)))
+ (cond ((and p
+ (mbt ; termination help
+ (and (natp p)
+ (stringp full-pathname)
+ (< p (length full-pathname)))))
+ (let ((new-p
+ (merge-using-dot-dot
+ (subseq full-pathname 0 p)
+ (subseq full-pathname (1+ p) (length full-pathname)))))
+ (and (mbt ; termination help
+ (and (stringp new-p)
+ (< (length new-p) (length full-pathname))))
+ (cancel-dot-dots new-p))))
+ (t full-pathname))))
+
+(defun get-parent-directory (p0)
+
+; P is an absolute pathname for a directory, not a file, where p does not end
+; in "/". We return an absolute pathname for its parent directory, not
+; including the trailing "/". See also get-directory-of-file, which is a
+; related function for files.
+
+ (declare (xargs :guard (stringp p0)
+ :measure (1+ (* 2 (length p0)))))
+ (let* ((p (and (mbt (stringp p0))
+ (cancel-dot-dots p0)))
+ (posn (search *directory-separator-string* p :from-end t)))
+ (cond
+ (posn (subseq p 0 posn))
+ (t (er hard? 'get-parent-directory
+ "Implementation error! Unable to get parent directory for ~
+ directory ~x0."
+ p0)))))
+
+(defun merge-using-dot-dot (p s)
+
+; P is the absolute pathname of a directory without the final "/". S is a
+; pathname (for a file or a directory) that may start with any number of
+; sequences "../" and "./". We want to "cancel" the leading "../"s in s
+; against directories at the end of p, and eliminate leading "./"s from s
+; (including leading "." if that is all of s). The result should syntactically
+; represent a directory (end with a "/" or "." or be "") if and only if s
+; syntactically represents a directory.
+
+; This code is intended to be simple, not necessarily efficient.
+
+ (declare (xargs :guard (and (stringp p)
+ (stringp s)
+ (not (equal s "")))
+ :measure (+ 1 (* 2 (+ (length p) (length s))))))
+ (cond
+ ((not (mbt ; termination help
+ (and (stringp p)
+ (stringp s)
+ (not (equal s "")))))
+ nil)
+ ((equal p "") s)
+ ((equal s "..")
+ (concatenate 'string
+ (get-parent-directory p)
+ *directory-separator-string*))
+ ((equal s ".")
+ (concatenate 'string
+ p
+ *directory-separator-string*))
+ ((and (>= (length s) 3)
+ (eql (char s 0) #\.)
+ (eql (char s 1) #\.)
+ (eql (char s 2) #\/)
+ (mbt (<= (length (get-parent-directory p)) ; termination help
+ (length p))))
+ (merge-using-dot-dot (get-parent-directory p)
+ (subseq s 3 (length s))))
+ ((and (>= (length s) 2)
+ (eql (char s 0) #\.)
+ (eql (char s 1) #\/))
+ (merge-using-dot-dot p (subseq s 2 (length s))))
+ (t
+ (concatenate 'string p *directory-separator-string* s))))
+
+)
diff -Nru acl2-7.0/basis-b.lisp acl2-7.1/basis-b.lisp
--- acl2-7.0/basis-b.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/basis-b.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
@@ -3438,6 +3438,12 @@
(defun chk-ld-error-action (val ctx state)
(cond ((member-eq val '(:continue :return :return! :error))
(value nil))
+ ((and (consp val)
+ (eq (car val) :exit)
+ (consp (cdr val))
+ (natp (cadr val))
+ (null (cddr val)))
+ (value nil))
(t (er soft ctx *ld-special-error* 'ld-error-action val))))
(defun set-ld-error-action (val state)
diff -Nru acl2-7.0/bdd.lisp acl2-7.1/bdd.lisp
--- acl2-7.0/bdd.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/bdd.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -1,4 +1,4 @@
-; ACL2 Version 7.0 -- A Computational Logic for Applicative Common Lisp
+; ACL2 Version 7.1 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2015, Regents of the University of Texas
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
@@ -2708,7 +2708,8 @@
(set-difference-eq term-vars
input-vars)))))))
#+(and (not acl2-loop-only) akcl)
- (cond ((and (fboundp 'si::sgc-on)
+ (cond ((and (not *gcl-large-maxpages*)
+ (fboundp 'si::sgc-on)
(funcall 'si::sgc-on))
(fms "NOTE: Turning off SGC. If you wish to turn SGC ~
back on again, execute (SI::SGC-ON T) in raw Lisp.~|"
diff -Nru acl2-7.0/bin/make-fancy-manual.sh acl2-7.1/bin/make-fancy-manual.sh
--- acl2-7.0/bin/make-fancy-manual.sh 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/bin/make-fancy-manual.sh 2015-05-08 18:07:33.000000000 +0000
@@ -7,11 +7,11 @@
# The normal usage of this program, at UT CS, is first to ensure that
# /projects/acl2/devel/books/doc/manual/ exists and is up to date,
# say, after running (in /projects/acl2/devel/):
-# make -j 8 regression-everything USE_QUICKLISP=1 ACL2=/projects/acl2/devel/ccl-saved_acl2h
+# make -j 8 regression-everything USE_QUICKLISP=1 ACL2=/projects/acl2/devel/ccl-saved_acl2
# and to ensure that
# /projects/acl2/devel/books/system/doc/rendered-doc-combined.lsp is
# up to date, for example after running (in /projects/acl2/devel/):
-# make -j 8 DOC ACL2=/projects/acl2/devel/ccl-saved_acl2h
+# make -j 8 DOC ACL2=/projects/acl2/devel/ccl-saved_acl2
# Then, we typically execute the following in /projects/acl2/devel/:
# bin/make-fancy-manual.sh
# But optional arguments may be given:
diff -Nru acl2-7.0/bin/purity.sh acl2-7.1/bin/purity.sh
--- acl2-7.0/bin/purity.sh 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/bin/purity.sh 2015-05-08 18:07:33.000000000 +0000
@@ -12,7 +12,7 @@
export PAGER=cat
# Matt might update this when confident of purity since the indicated date.
-export SINCE=2014-10-12
+export SINCE=2015-04-10
export basecmd="\
git log \
@@ -29,6 +29,7 @@
--author='Matt Kaufmann In order to see how the CCG analysis works, consider the following
definition of Ackermann's function from exercise 6.15 in the ACL2
diff -Nru acl2-7.0/books/acl2s/cgen/acl2s-parameter.lisp acl2-7.1/books/acl2s/cgen/acl2s-parameter.lisp
--- acl2-7.0/books/acl2s/cgen/acl2s-parameter.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/cgen/acl2s-parameter.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -5,7 +5,7 @@
(in-package "ACL2S")
;(include-book "utilities")
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
; [2014-11-25 Tue] Make key package agnostic by always putting it into
; keyword package. Thus we look only at symbol-name of the original
diff -Nru acl2-7.0/books/acl2s/cgen/basis.lisp acl2-7.1/books/acl2s/cgen/basis.lisp
--- acl2-7.0/books/acl2s/cgen/basis.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/cgen/basis.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -5,7 +5,7 @@
(in-package "CGEN")
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
;;;;naming convention (only for readability):
;;;; function: end with $ for each stobj updating/creating function
diff -Nru acl2-7.0/books/acl2s/cgen/build-enumcalls.lisp acl2-7.1/books/acl2s/cgen/build-enumcalls.lisp
--- acl2-7.0/books/acl2s/cgen/build-enumcalls.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/cgen/build-enumcalls.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -8,7 +8,7 @@
(in-package "CGEN")
;Useful Macros for concise/convenient code.
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
(include-book "basis")
(include-book "utilities")
(include-book "type")
diff -Nru acl2-7.0/books/acl2s/cgen/callback.lisp acl2-7.1/books/acl2s/cgen/callback.lisp
--- acl2-7.0/books/acl2s/cgen/callback.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/cgen/callback.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -8,7 +8,7 @@
(in-package "CGEN")
;Useful Macros for concise/convenient code.
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
;(include-book "basis")
(include-book "type")
diff -Nru acl2-7.0/books/acl2s/cgen/cgen-search.lisp acl2-7.1/books/acl2s/cgen/cgen-search.lisp
--- acl2-7.0/books/acl2s/cgen/cgen-search.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/cgen/cgen-search.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -8,7 +8,7 @@
(in-package "CGEN")
;Useful Macros for concise/convenient code.
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
(include-book "basis")
(include-book "type")
diff -Nru acl2-7.0/books/acl2s/cgen/prove-cgen.lisp acl2-7.1/books/acl2s/cgen/prove-cgen.lisp
--- acl2-7.0/books/acl2s/cgen/prove-cgen.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/cgen/prove-cgen.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -534,7 +534,7 @@
(ttree (acl2::prove ',term
;; TODO: Matt's code doesnt work through induction and forcing rds
;; Also the OTF flag is set to true, to test all initial subgoals.
- (acl2::make-pspv ens wrld
+ (acl2::make-pspv ens wrld state
:displayed-goal ',form
:otf-flg t)
hints ens wrld "( THM ...)" state)))
diff -Nru acl2-7.0/books/acl2s/cgen/type.lisp acl2-7.1/books/acl2s/cgen/type.lisp
--- acl2-7.0/books/acl2s/cgen/type.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/cgen/type.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -6,7 +6,7 @@
(in-package "CGEN"
)
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
(include-book "basis")
(include-book "../defdata/defdata-util")
diff -Nru acl2-7.0/books/acl2s/cgen/utilities.lisp acl2-7.1/books/acl2s/cgen/utilities.lisp
--- acl2-7.0/books/acl2s/cgen/utilities.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/cgen/utilities.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -11,7 +11,7 @@
(in-package "CGEN")
(set-verify-guards-eagerness 2)
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
;(include-book "basis")
;;-- create a new symbol with prefix or suffix appended
diff -Nru acl2-7.0/books/acl2s/defdata/alistof.lisp acl2-7.1/books/acl2s/defdata/alistof.lisp
--- acl2-7.0/books/acl2s/defdata/alistof.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/defdata/alistof.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -67,14 +67,12 @@
(str-alist `(("_PRED_" . ,(symbol-name pred)) ("_KEYPRED_" . ,(symbol-name keypred))))
(local-events (template-subst local-events-template
:features features
- :subtree-alist nil
:splice-alist splice-alist
:atom-alist atom-alist
:str-alist str-alist
:pkg-sym 'acl2::asdf))
(export-defthms (template-subst export-defthms-template
:features features
- :subtree-alist nil
:splice-alist splice-alist
:atom-alist atom-alist
:str-alist str-alist
diff -Nru acl2-7.0/books/acl2s/defdata/builtin-combinators.lisp acl2-7.1/books/acl2s/defdata/builtin-combinators.lisp
--- acl2-7.0/books/acl2s/defdata/builtin-combinators.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/defdata/builtin-combinators.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -13,7 +13,7 @@
(in-package "DEFDATA")
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
(table defdata-defaults-table nil
'((:debug . nil)
diff -Nru acl2-7.0/books/acl2s/defdata/defdata-util.lisp acl2-7.1/books/acl2s/defdata/defdata-util.lisp
--- acl2-7.0/books/acl2s/defdata/defdata-util.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/defdata/defdata-util.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -9,7 +9,7 @@
(in-package "DEFDATA")
(set-verify-guards-eagerness 2)
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
;; (defun modify-symbol (prefix sym postfix)
;; (declare (xargs :guard (and (symbolp sym)
diff -Nru acl2-7.0/books/acl2s/defdata/listof.lisp acl2-7.1/books/acl2s/defdata/listof.lisp
--- acl2-7.0/books/acl2s/defdata/listof.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/defdata/listof.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -54,14 +54,12 @@
(str-alist `(("_PRED_" . ,(symbol-name pred)) ("_CPRED_" . ,(symbol-name cpred))))
(local-events (template-subst local-events-template
:features features
- :subtree-alist nil
:splice-alist splice-alist
:atom-alist atom-alist
:str-alist str-alist
:pkg-sym 'acl2::asdf))
(export-defthms (template-subst export-defthms-template
:features features
- :subtree-alist nil
:splice-alist splice-alist
:atom-alist atom-alist
:str-alist str-alist
diff -Nru acl2-7.0/books/acl2s/defdata/map.lisp acl2-7.1/books/acl2s/defdata/map.lisp
--- acl2-7.0/books/acl2s/defdata/map.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/defdata/map.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -141,14 +141,12 @@
(str-alist `(("_PRED_" . ,(symbol-name pred)) ("_KEYPRED_" . ,(symbol-name keypred)) ("_VALPRED_" . ,(symbol-name valpred))))
(local-events (template-subst local-events-template
:features features
- :subtree-alist nil
:splice-alist splice-alist
:atom-alist atom-alist
:str-alist str-alist
:pkg-sym 'acl2::asdf))
(export-defthms (template-subst export-defthms-template
:features features
- :subtree-alist nil
:splice-alist splice-alist
:atom-alist atom-alist
:str-alist str-alist
diff -Nru acl2-7.0/books/acl2s/defdata/random-state-basis1.lisp acl2-7.1/books/acl2s/defdata/random-state-basis1.lisp
--- acl2-7.0/books/acl2s/defdata/random-state-basis1.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/defdata/random-state-basis1.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -6,7 +6,7 @@
(in-package "DEFDATA")
(set-verify-guards-eagerness 2)
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
(local (include-book "arithmetic-3/floor-mod/floor-mod" :dir :system))
;(local (include-book "arithmetic-5/top" :dir :system))
diff -Nru acl2-7.0/books/acl2s/defdata/sig.lisp acl2-7.1/books/acl2s/defdata/sig.lisp
--- acl2-7.0/books/acl2s/defdata/sig.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/acl2s/defdata/sig.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -617,7 +617,6 @@
(str-alist (acons "_PRED_" (symbol-name pred) '())))
(template-subst templ
:features nil
- :subtree-alist nil
:splice-alist splice-alist
:atom-alist atom-alist
:str-alist str-alist
diff -Nru acl2-7.0/books/arithmetic-3/README acl2-7.1/books/arithmetic-3/README
--- acl2-7.0/books/arithmetic-3/README 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/arithmetic-3/README 2015-05-08 18:07:33.000000000 +0000
@@ -358,7 +358,7 @@
book, which (at least initially) can use defaxiom or skip-proofs as
shown in order to defer the proofs of the main lemmas.
-(include-book ``lib'') ; 3. Support
+(include-book "lib") ; 3. Support
(defaxiom A ...) ; 2. Main Reduction
(defaxiom B ...)
diff -Nru acl2-7.0/books/arithmetic-5/lib/basic-ops/building-blocks.lisp acl2-7.1/books/arithmetic-5/lib/basic-ops/building-blocks.lisp
--- acl2-7.0/books/arithmetic-5/lib/basic-ops/building-blocks.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/arithmetic-5/lib/basic-ops/building-blocks.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -930,12 +930,22 @@
; Intersection-equal was added to ACL2 in Version 4.0.
-(defun set-equal (x y)
- (declare (xargs :guard t))
- (and (true-listp x)
- (true-listp y)
- (subsetp-equal x y)
- (subsetp-equal y x)))
+;; [Jared] Modified 2015-04-30 to agree with the definition in data-structures.
+;; FYI, this is why we need to use packages.
+
+;; (defun set-equal (x y)
+;; (declare (xargs :guard t))
+;; (and (true-listp x)
+;; (true-listp y)
+;; (subsetp-equal x y)
+;; (subsetp-equal y x)))
+
+(defun set-equal (a b)
+ (declare (xargs :guard (and (true-listp a)
+ (true-listp b))))
+ (and (subsetp-equal a b)
+ (subsetp-equal b a)))
+
(defun common-factors (factors sum)
(declare (xargs :measure (acl2-count sum)
diff -Nru acl2-7.0/books/arithmetic-5/lib/basic-ops/normalize.lisp acl2-7.1/books/arithmetic-5/lib/basic-ops/normalize.lisp
--- acl2-7.0/books/arithmetic-5/lib/basic-ops/normalize.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/arithmetic-5/lib/basic-ops/normalize.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -205,7 +205,10 @@
(true-list-listp (find-denominators-with-sums addend denominator-list n)))))
(defun remainder-aaa (sum factors to-be-found remainder)
- (declare (xargs :guard t))
+
+ ;; Modified by Jared 2015-04-30 to add true-listp guard, due to
+ ;; set-equal changes.
+ (declare (xargs :guard (true-listp factors)))
;; Consider that the term
;; (+ (* a x (/ (+ a b))) (* b x (/ (+ a b))) c),
diff -Nru acl2-7.0/books/arithmetic-5/README acl2-7.1/books/arithmetic-5/README
--- acl2-7.0/books/arithmetic-5/README 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/arithmetic-5/README 2015-05-08 18:07:33.000000000 +0000
@@ -443,7 +443,7 @@
book, which (at least initially) can use defaxiom or skip-proofs as
shown in order to defer the proofs of the main lemmas.
-(include-book ``lib'') ; 3. Support
+(include-book "lib") ; 3. Support
(defaxiom A ...) ; 2. Main Reduction
(defaxiom B ...)
diff -Nru acl2-7.0/books/build/certlib.pl acl2-7.1/books/build/certlib.pl
--- acl2-7.0/books/build/certlib.pl 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/certlib.pl 2015-05-08 18:07:33.000000000 +0000
@@ -802,7 +802,7 @@
my ($base,$the_line,$events) = @_;
# Check for ADD-INCLUDE-BOOK-DIR commands
- my $regexp = "^[^;]*\\(add-include-book-dir!?[\\s]+:([^\\s]*)[\\s]*\"([^\"]*[^\"/])/?\"";
+ my $regexp = "^[^;]*\\([\\s]*add-include-book-dir!?[\\s]+:([^\\s]*)[\\s]*\"([^\"]*[^\"/])/?\"";
my @res = $the_line =~ m/$regexp/i;
if (@res) {
my $name = uc($res[0]);
@@ -845,7 +845,7 @@
sub get_include_book {
my ($base,$the_line,$events) = @_;
- my $regexp = "^[^;]*\\(include-book[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
+ my $regexp = "^[^;]*\\([\\s]*include-book[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
my @res = $the_line =~ m/$regexp/i;
if (@res) {
debug_print_event($base, "include_book", \@res);
@@ -858,7 +858,7 @@
sub get_depends_on {
my ($base,$the_line,$events) = @_;
- my $regexp = "\\(depends-on[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
+ my $regexp = "\\([\\s]*depends-on[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
my @res = $the_line =~ m/$regexp/i;
if (@res) {
debug_print_event($base, "depends_on", \@res);
@@ -871,7 +871,7 @@
sub get_depends_rec {
my ($base,$the_line,$events) = @_;
- my $regexp = "\\(depends-rec[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
+ my $regexp = "\\([\\s]*depends-rec[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
my @res = $the_line =~ m/$regexp/i;
if (@res) {
debug_print_event($base, "depends_rec", \@res);
@@ -884,7 +884,7 @@
sub get_loads {
my ($base,$the_line,$events) = @_;
- my $regexp = "\\(loads[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
+ my $regexp = "\\([\\s]*loads[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
my @res = $the_line =~ m/$regexp/i;
if (@res) {
debug_print_event($base, "loads", \@res);
@@ -922,7 +922,7 @@
sub get_cert_param {
my ($base,$the_line,$events) = @_;
- my $regexp = "cert[-_]param:?[\\s]*\\(?([^)]*)\\)?";
+ my $regexp = "cert[-_]param[\\s]*:?[\\s]*\\(?([^)]*)\\)?";
my @match = $the_line =~ m/$regexp/;
if (@match) {
debug_print_event($base, "cert_param", \@match);
@@ -947,7 +947,7 @@
push (@$events, [$cert_param_event, "acl2x", 1]);
return 1;
}
- $regexp = "\\(check-hons-enabled[\\s]+\\(:book";
+ $regexp = "\\([\\s]*check-hons-enabled[\\s]+\\(:book";
if ($the_line =~ m/$regexp/) {
push (@$events, [$cert_param_event, "hons-only", 1]);
return 1;
@@ -973,7 +973,7 @@
my ($base,$the_line,$events) = @_;
# Check for LD commands
- my $regexp = "^[^;]*\\(ld[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
+ my $regexp = "^[^;]*\\([\\s]*ld[\\s]*\"([^\"]*)\"(?:.*:dir[\\s]*:([^\\s)]*))?";
my @res = $the_line =~ m/$regexp/i;
if (@res) {
debug_print_event($base, "ld", \@res);
diff -Nru acl2-7.0/books/build/clean.pl acl2-7.1/books/build/clean.pl
--- acl2-7.0/books/build/clean.pl 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/clean.pl 2015-05-08 18:07:33.000000000 +0000
@@ -92,7 +92,7 @@
".bin" => 1, # ???
".sbin" => 1, # ???
".lbin" => 1, # ???
- ".fasl" => 1, # Compiled Lisp files for ???
+ ".fasl" => 1, # Compiled Lisp files for SBCL
".ufsl" => 1, # ???
".64ufasl" => 1, # ???
".pfsl" => 1, # ???
@@ -188,6 +188,12 @@
push(@rm, $what);
return;
}
+
+ if ($file eq "worklispext") {
+ # Generated by ACL2 during save-exec, see Issue 305.
+ push(@rm, $what);
+ return;
+ }
if ($file =~ /^workxxx.*$/) {
push(@rm, $what);
diff -Nru acl2-7.0/books/build/doc.lisp acl2-7.1/books/build/doc.lisp
--- acl2-7.0/books/build/doc.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/doc.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -169,7 +169,7 @@
We assume you have ACL2
or one of its variants like ACL2(h), ACL2(p), or ACL2(r) installed, and that
you know how to launch ACL2—usually with a script named @('saved_acl2')
-or @('saved_acl2h') or similar.
We assume you have a copy of the ACL2 Community Books for your
@@ -235,7 +235,7 @@
@({
$ cert.pl
- ACL2 executable is /home/jared/acl2/saved_acl2h
+ ACL2 executable is /home/jared/acl2/saved_acl2
System books directory is /home/jared/acl2/books
...
})
diff -Nru acl2-7.0/books/build/goto-ccl-version.sh acl2-7.1/books/build/goto-ccl-version.sh
--- acl2-7.0/books/build/goto-ccl-version.sh 1970-01-01 00:00:00.000000000 +0000
+++ acl2-7.1/books/build/goto-ccl-version.sh 2015-05-08 18:07:33.000000000 +0000
@@ -0,0 +1,32 @@
+# This is provided to the community by the community, with no claims
+# of ownership -- it is in the public domain, as found on a pastebin
+# site.
+
+#!/bin/sh
+
+# Usage: goto-ccl-version.sh [REVISION]
+#
+# Example: goto-ccl-version.sh 16345
+
+set -e
+
+# cd ccl-linux
+
+REV=$1
+
+EXTERNALS=`svn propget svn:externals . | awk '{print $2}'`
+echo "Switching " `pwd` "to revision $1"
+echo "Externals = $EXTERNALS"
+echo "Note that all subdirectories of svn will first be updated to the most"
+echo "recent revision, and then they will be updated to the specific revision."
+
+HERE=`pwd`
+
+svn update -r $REV
+for f in $EXTERNALS
+do
+ echo "Switching to $REV in $HERE/$f"
+ cd $HERE/$f; svn update -r $REV
+done
+
+echo "I think that's it?"
diff -Nru acl2-7.0/books/build/jenkins/build-multi.sh acl2-7.1/books/build/jenkins/build-multi.sh
--- acl2-7.0/books/build/jenkins/build-multi.sh 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/jenkins/build-multi.sh 2015-05-08 18:07:33.000000000 +0000
@@ -45,12 +45,12 @@
if [ "${LISP:0:3}" == "gcl" ]; then
USE_QUICKLISP="";
else
- USE_QUICKLISP="t";
+ USE_QUICKLISP="1";
fi
set ACL2_SUFFIX=""
-if [ "$ACL2_HONS" != "" ]; then
- ACL2_SUFFIX="${ACL2_SUFFIX}h"
+if [ "$ACL2_HONS" == "" ]; then
+ ACL2_SUFFIX="${ACL2_SUFFIX}c"
fi
if [ "$ACL2_PAR" != "" ]; then
diff -Nru acl2-7.0/books/build/jenkins/build-single.sh acl2-7.1/books/build/jenkins/build-single.sh
--- acl2-7.0/books/build/jenkins/build-single.sh 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/jenkins/build-single.sh 2015-05-08 18:07:33.000000000 +0000
@@ -3,7 +3,7 @@
# Cause the script to exit immediately upon failure
set -e
echo "acl2dir is $ACL2DIR"
-echo "Starting build-ccl-acl2h.sh"
+echo "Starting build-single.sh"
echo " -- Running in `pwd`"
echo " -- Running on `hostname`"
echo " -- PATH is $PATH"
@@ -28,14 +28,14 @@
echo "Making TARGET = $TARGET"
echo "Using STARTJOB = `which startjob`"
-echo "Making ACL2(h)"
-startjob -c "nice make acl2h -f books/build/jenkins/Makefile LISP=$LISP &> make.log" \
- --name "J_CCL_ACL2H" \
+echo "Making ACL2"
+startjob -c "nice make acl2 -f books/build/jenkins/Makefile LISP=$LISP &> make.log" \
+ --name "J_CCL_ACL2" \
--limits "pmem=4gb,nodes=1:ppn=1,walltime=10:00"
echo "Building the books."
cd books
-startjob -c "nice -n 5 make $TARGET ACL2=$WORKSPACE/saved_acl2h -j $BOOK_PARALLELISM_LEVEL $MAKEOPTS USE_QUICKLISP=1"
+startjob -c "nice -n 5 make $TARGET ACL2=$WORKSPACE/saved_acl2 -j $BOOK_PARALLELISM_LEVEL $MAKEOPTS USE_QUICKLISP=1"
echo "Build was successful."
diff -Nru acl2-7.0/books/build/jenkins/deprecated/build-ccl-acl2h.sh acl2-7.1/books/build/jenkins/deprecated/build-ccl-acl2h.sh
--- acl2-7.0/books/build/jenkins/deprecated/build-ccl-acl2h.sh 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/jenkins/deprecated/build-ccl-acl2h.sh 2015-05-08 18:07:33.000000000 +0000
@@ -27,10 +27,10 @@
echo "Building the books."
cd books
-make all ACL2=$WORKSPACE/saved_acl2h -j1 $MAKEOPTS USE_QUICKLISP=1
+make all ACL2=$WORKSPACE/saved_acl2 -j1 $MAKEOPTS USE_QUICKLISP=1
#cd acl2-devel/books
-#make ACL2=$ACL2DIR/acl2-devel/saved_acl2h all $MAKEOPTS USE_QUICKLISP=1
+#make ACL2=$ACL2DIR/acl2-devel/saved_acl2 all $MAKEOPTS USE_QUICKLISP=1
echo "Build was successful."
diff -Nru acl2-7.0/books/build/jenkins/deprecated/build-gcl-ansi-acl2h.sh acl2-7.1/books/build/jenkins/deprecated/build-gcl-ansi-acl2h.sh
--- acl2-7.0/books/build/jenkins/deprecated/build-gcl-ansi-acl2h.sh 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/jenkins/deprecated/build-gcl-ansi-acl2h.sh 2015-05-08 18:07:33.000000000 +0000
@@ -22,7 +22,7 @@
echo "Building the books."
cd acl2-devel/books
-make ACL2=$ACL2DIR/acl2-devel/saved_acl2h all $MAKEOPTS
+make ACL2=$ACL2DIR/acl2-devel/saved_acl2 all $MAKEOPTS
echo "Build was successful."
diff -Nru acl2-7.0/books/build/jenkins/deprecated/build-gcl-cltl1-acl2.sh acl2-7.1/books/build/jenkins/deprecated/build-gcl-cltl1-acl2.sh
--- acl2-7.0/books/build/jenkins/deprecated/build-gcl-cltl1-acl2.sh 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/jenkins/deprecated/build-gcl-cltl1-acl2.sh 2015-05-08 18:07:33.000000000 +0000
@@ -22,7 +22,7 @@
echo "Building the books."
cd acl2-devel/books
-make ACL2=$ACL2DIR/acl2-devel/saved_acl2 all $MAKEOPTS
+make ACL2=$ACL2DIR/acl2-devel/saved_acl2c all $MAKEOPTS
echo "Build was successful."
diff -Nru acl2-7.0/books/build/jenkins/deprecated/build-sbcl-acl2h.sh acl2-7.1/books/build/jenkins/deprecated/build-sbcl-acl2h.sh
--- acl2-7.0/books/build/jenkins/deprecated/build-sbcl-acl2h.sh 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/jenkins/deprecated/build-sbcl-acl2h.sh 2015-05-08 18:07:33.000000000 +0000
@@ -22,7 +22,7 @@
echo "Building the books."
cd acl2-devel/books
-make ACL2=$ACL2DIR/acl2-devel/saved_acl2h all $MAKEOPTS USE_QUICKLISP=1
+make ACL2=$ACL2DIR/acl2-devel/saved_acl2 all $MAKEOPTS USE_QUICKLISP=1
echo "Build was successful."
diff -Nru acl2-7.0/books/build/jenkins/Makefile acl2-7.1/books/build/jenkins/Makefile
--- acl2-7.0/books/build/jenkins/Makefile 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/jenkins/Makefile 2015-05-08 18:07:33.000000000 +0000
@@ -11,7 +11,7 @@
# Example usages:
#
# make -f books/build/jenkins/Makefile acl2 LISP=ccl
-# make -f books/build/jenkins/Makefile acl2hr LISP=ccl
+# make -f books/build/jenkins/Makefile acl2r LISP=ccl
# make -f books/build/jenkins/Makefile saved_acl2p LISP=ccl
ACL2_ALL_SOURCES := $(wildcard *.lisp)
@@ -19,79 +19,85 @@
ACL2_SOURCES := $(filter-out $(ACL2_FAKE_SOURCES), $(ACL2_ALL_SOURCES))
ACL2_DEPS := $(ACL2_SOURCES) GNUmakefile
-.PHONY: acl2 acl2h acl2p acl2r acl2hp acl2hr acl2pr acl2hpr
+.PHONY: acl2c acl2cp acl2cr acl2cpr
+.PHONY: acl2 acl2p acl2r acl2pr
-acl2: saved_acl2
-acl2h: saved_acl2h
-acl2p: saved_acl2p
-acl2r: saved_acl2r
-acl2hp: saved_acl2hp
-acl2hr: saved_acl2hr
-acl2pr: saved_acl2pr
-acl2hpr: saved_acl2hpr
+acl2c: saved_acl2c
+acl2cp: saved_acl2cp
+acl2cr: saved_acl2cr
+acl2cpr: saved_acl2cpr
# Note that we don't use &>, because otherwise the process goes on
# immediately, and waiting 100 seconds isn't enough for SBCL builds.
-saved_acl2: $(ACL2_DEPS)
- echo "Making ACL2() on $(LISP)"
+
+saved_acl2c: $(ACL2_DEPS)
+ echo "Making ACL2(c) on $(LISP)"
time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS= > make-acl2.log
./books/build/wait.pl make-acl2.log
cat make-acl2.log
- ./books/build/wait.pl saved_acl2
- ls -lah saved_acl2
+ ./books/build/wait.pl saved_acl2c
+ ls -lah saved_acl2c
-saved_acl2h: $(ACL2_DEPS)
- echo "Making ACL2(h) on $(LISP)"
- time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS=h > make-acl2.log
+saved_acl2cp: $(ACL2_DEPS)
+ echo "Making ACL2(cp) on $(LISP)"
+ time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS= ACL2_PAR=p > make-acl2.log
./books/build/wait.pl make-acl2.log
cat make-acl2.log
- ./books/build/wait.pl saved_acl2h
- ls -lah saved_acl2h
+ ./books/build/wait.pl saved_acl2cp
+ ls -lah saved_acl2cp
-saved_acl2p: $(ACL2_DEPS)
- echo "Making ACL2(p) on $(LISP)"
- time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS= ACL2_PAR=p > make-acl2.log
+saved_acl2cr: $(ACL2_DEPS)
+ echo "Making ACL2(cr) on $(LISP)"
+ time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS= ACL2_REAL=r > make-acl2.log
./books/build/wait.pl make-acl2.log
cat make-acl2.log
- ./books/build/wait.pl saved_acl2p
- ls -lah saved_acl2p
+ ./books/build/wait.pl saved_acl2cr
+ ls -lah saved_acl2cr
-saved_acl2r: $(ACL2_DEPS)
- echo "Making ACL2(r) on $(LISP)"
- time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS= ACL2_REAL=r > make-acl2.log
+saved_acl2cpr: $(ACL2_DEPS)
+ echo "Making ACL2(cpr) on $(LISP)"
+ time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS= ACL2_PAR=p ACL2_REAL=r > make-acl2.log
./books/build/wait.pl make-acl2.log
cat make-acl2.log
- ./books/build/wait.pl saved_acl2r
- ls -lah saved_acl2r
+ ./books/build/wait.pl saved_acl2cpr
+ ls -lah saved_acl2cpr
+
+
+
+
+acl2: saved_acl2
+acl2p: saved_acl2p
+acl2r: saved_acl2r
+acl2pr: saved_acl2pr
-saved_acl2hp: $(ACL2_DEPS)
+saved_acl2: $(ACL2_DEPS)
+ echo "Making ACL2(h) on $(LISP)"
+ time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS=h > make-acl2.log
+ ./books/build/wait.pl make-acl2.log
+ cat make-acl2.log
+ ./books/build/wait.pl saved_acl2
+ ls -lah saved_acl2
+
+saved_acl2p: $(ACL2_DEPS)
echo "Making ACL2(hp) on $(LISP)"
time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS=h ACL2_PAR=p > make-acl2.log
./books/build/wait.pl make-acl2.log
cat make-acl2.log
- ./books/build/wait.pl saved_acl2hp
- ls -lah saved_acl2hp
+ ./books/build/wait.pl saved_acl2p
+ ls -lah saved_acl2p
-saved_acl2hr: $(ACL2_DEPS)
+saved_acl2r: $(ACL2_DEPS)
echo "Making ACL2(hr) on $(LISP)"
time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS=h ACL2_REAL=r > make-acl2.log
./books/build/wait.pl make-acl2.log
cat make-acl2.log
- ./books/build/wait.pl saved_acl2hr
- ls -lah saved_acl2hr
+ ./books/build/wait.pl saved_acl2r
+ ls -lah saved_acl2r
saved_acl2pr: $(ACL2_DEPS)
- echo "Making ACL2(pr) on $(LISP)"
- time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS= ACL2_PAR=p ACL2_REAL=r > make-acl2.log
- ./books/build/wait.pl make-acl2.log
- cat make-acl2.log
- ./books/build/wait.pl saved_acl2pr
- ls -lah saved_acl2pr
-
-saved_acl2hpr: $(ACL2_DEPS)
echo "Making ACL2(hpr) on $(LISP)"
time make --file=GNUmakefile LISP=$(LISP) ACL2_HONS=h ACL2_PAR=p ACL2_REAL=r > make-acl2.log
./books/build/wait.pl make-acl2.log
cat make-acl2.log
- ./books/build/wait.pl saved_acl2hpr
- ls -lah saved_acl2hpr
+ ./books/build/wait.pl saved_acl2pr
+ ls -lah saved_acl2pr
diff -Nru acl2-7.0/books/build/make_cert_help.pl acl2-7.1/books/build/make_cert_help.pl
--- acl2-7.0/books/build/make_cert_help.pl 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/build/make_cert_help.pl 2015-05-08 18:07:33.000000000 +0000
@@ -504,6 +504,7 @@
$instrs .= "(acl2::lp)\n";
# $instrs .= "(set-debugger-enable :bt)\n";
$instrs .= "(acl2::in-package \"ACL2\")\n\n";
+$instrs .= "(set-ld-error-action (quote (:exit 1)) state)\n";
$instrs .= "(set-write-acl2x t state)\n" if ($STEP eq "acl2x");
$instrs .= "(set-write-acl2x '(t) state)\n" if ($STEP eq "acl2xskip");
$instrs .= "$INHIBIT\n" if ($INHIBIT);
@@ -525,6 +526,9 @@
# Don't hideously underapproximate timings in event summaries
$instrs .= "(acl2::assign acl2::get-internal-time-as-realtime acl2::t)\n";
+# Don't hide GC messages -- except for CMUCL, which dumps them to the terminal.
+$instrs .= "#-cmucl (acl2::gc-verbose t)\n";
+
$instrs .= "; instructions from .acl2 file $acl2file:\n";
$instrs .= "$usercmds\n\n";
@@ -544,6 +548,8 @@
}
}
+$instrs .= "#!ACL2 (set-ld-error-action (quote :continue) state)\n";
+
my $cert_flags = parse_certify_flags($acl2file, $usercmds);
$instrs .= "\n; certify-book command flags: $cert_flags\n";
diff -Nru acl2-7.0/books/centaur/4v-sexpr/portcullis.acl2 acl2-7.1/books/centaur/4v-sexpr/portcullis.acl2
--- acl2-7.0/books/centaur/4v-sexpr/portcullis.acl2 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/centaur/4v-sexpr/portcullis.acl2 2015-05-08 18:07:33.000000000 +0000
@@ -29,8 +29,9 @@
; Original author: Sol Swords The (combinational) semantics of an AIGNET network is given by the function
-@({'(lit-eval lit vals aignet)').})
-Net-eval is simply an array of bits holding a value for each node in the
-network. However, lit-eval only uses the values that are stored for primary
-input and register output nodes to compute evaluations. Furthermore, lit-eval
-does no memoization, so it is not intended to be used in execution. Rather, it
-is a simple specification for the semantics of nodes. To actually execute evaluations of nodes, use the functions
-@({(aignet-eval n vals aignet)})
-and
-@({(aignet-eval-frame n k vals frames aignet)})
-both of which return aignet-vals. Instead of giving the evaluation of
-one literal, these record the evaluations of every node (starting at
-n) in the aignet-vals table. Then,
-@({(get-bit id vals)})
-or
-@({(aignet-eval-lit lit vals)})
-may be used to retrieve them. These values are then provably equal to,
-respectively,
-@({(lit-eval (mk-lit id 0) vals aignet)})
-and
-@({(lit-eval lit vals aignet),})
-by the following theorem:
-@(thm aignet-eval-lit-of-aignet-eval) The (combinational) semantics of an AIGNET network is given by the function Invals and regvals are bit arrays containing a value for each (respectively)
+primary input and register node in the network. But because this function is a
+simple recursive specification for the semantics of a node and not written for
+performance, it is likely to perform badly (worst-case exponential time in the
+size of the network). To actually execute evaluations of nodes, instead do the following: (Note: invals and regvals have a different layout than vals; they include
+only one entry per (respectively) primary input or register instead of one
+entry per node, so they are indexed by I/O number whereas vals is indexed by
+node ID.) The following theorem shows the correspondence between a literal looked up
+in @('vals') after running aignet-eval and the @('lit-eval') of that
+literal: These theorems resolve the copying between invals/regvals and @('vals'): See @(see aignet-seq-eval) for discussion of sequential evaluation. The difference between @('aignet-eval') and @('aignet-eval-frame') is that
aignet-eval-frame is designed to be used as part of a sequential simulation.
@@ -63,7 +82,7 @@
of @('aignet-vals') after first copying the RI values to the corresponding ROs
and the inputs from the appropriate frame. For higher-level functions for simulation, see the book \"aignet-sim.lisp\". For higher-level functions for simulation, see the book \"aig-sim.lisp\". The sequential semantics of aignets is given by the function
-ID-EVAL-SEQ. This takes an aignet, a time frame number, a node ID, a 2D bit
+LIT-EVAL-SEQ. This takes an aignet, a time frame number, a literal, a 2D bit
array assigning values to the primary inputs on each frame, and an initial
-assignment to the registers. It produces the value of that ID under those
-sequential assignments.
The following theorem describes @('lit-eval-seq') in terms of combinational evaluation: + @(thm lit-eval-seq-in-terms-of-lit-eval)
+ +Here, @('frame-regvals') is a function that creates a register value array +from the previous frame's sequential evaluations of the next-state nodes +corresponding to each register. That is, to get the value of a literal at a +particular timeframe, first evaluate the register next-states at the previous +timeframe, then combinationally evaluate the literal with the resulting +register values and the current frame's input values.
" (local (in-theory (disable acl2::bfix-when-not-1 acl2::nfix-when-not-natp))) @@ -1075,9 +1085,10 @@ (defthm bitp-of-id-eval-seq (bitp (id-eval-seq k id frames initsts aignet)) - :hints (("goal" :expand ((id-eval-seq k id frames initsts aignet) - (:free (id) - (id-eval-seq (+ -1 k) id frames initsts aignet)))))) + :hints (("goal" :induct (id-eval-seq-ind k id aignet) + :expand ((id-eval-seq k id frames initsts aignet) + (:free (id) + (id-eval-seq (+ -1 k) id frames initsts aignet)))))) (verify-guards id-eval-seq) @@ -1127,7 +1138,8 @@ (defthm lookup-reg->nxst-of-non-nxst-extension (implies (and (aignet-extension-binding) (equal (stype-count :nxst new) - (stype-count :nxst orig))) + (stype-count :nxst orig)) + (<= (nfix id) (node-count orig))) (equal (lookup-reg->nxst id new) (lookup-reg->nxst id orig))) :hints(("Goal" :in-theory (enable aignet-extension-p @@ -1533,20 +1545,35 @@ aignet)))) (aignet-print-outs (1+ (lnfix n)) aignet))) + (defthm ctype-of-aignet-lit + (implies (aignet-litp lit aignet) + (not (equal (CTYPE + (STYPE + (CAR + (LOOKUP-ID + (LIT-ID lit) + AIGNET)))) + :OUTPUT))) + :hints(("Goal" :in-theory (enable aignet-litp)))) + (defund aignet-print-regs (n aignet) (declare (Xargs :stobjs aignet :guard (and (natp n) (<= n (num-regs aignet))) - :guard-hints (("goal" :in-theory (e/d (lookup-stype-in-bounds)))) + :guard-hints (("goal" :in-theory (e/d (lookup-stype-in-bounds + aignet-litp)))) :measure (nfix (- (nfix (num-regs aignet)) (nfix n))))) (b* (((when (mbe :logic (zp (- (nfix (num-regs aignet)) (nfix n))) :exec (= (num-regs aignet) n))) nil) - (ri (reg-id->nxst (regnum->id n aignet) aignet)) + (id (regnum->id n aignet)) + (ri (reg-id->nxst id aignet)) ((when (int= ri 0)) (aignet-print-regs (1+ (lnfix n)) aignet)) (- (cw "r~x0 = ~@1~%" n - (aignet-print-lit (co-id->fanin ri aignet) aignet)))) + (if (int= ri id) + (aignet-print-lit (mk-lit id 0) aignet) + (aignet-print-lit (co-id->fanin ri aignet) aignet))))) (aignet-print-regs (1+ (lnfix n)) aignet))) (defund aignet-print (aignet) diff -Nru acl2-7.0/books/centaur/aignet/snodes.lisp acl2-7.1/books/centaur/aignet/snodes.lisp --- acl2-7.0/books/centaur/aignet/snodes.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/aignet/snodes.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -124,13 +124,13 @@ (equal (snode->regp (mv-nth 1 (mk-snode type regp phase fanin0 fanin1))) (bfix regp)) :hints(("Goal" :in-theory (e/d (snode->regp - acl2::loghead-of-ash))))) + bitops::loghead-of-ash))))) (defthm snode->phase-of-mk-snode (equal (snode->phase (mv-nth 1 (mk-snode type regp phase fanin0 fanin1))) (bfix phase)) :hints(("Goal" :in-theory (e/d (snode->phase - acl2::loghead-of-ash))))) + bitops::loghead-of-ash))))) (defthm snode->fanin-of-mk-snode (and (equal (snode->fanin (mv-nth 0 (mk-snode type regp phase fanin0 fanin1))) diff -Nru acl2-7.0/books/centaur/aignet/to-hons-aig.lisp acl2-7.1/books/centaur/aignet/to-hons-aig.lisp --- acl2-7.0/books/centaur/aignet/to-hons-aig.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/aignet/to-hons-aig.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -32,6 +32,7 @@ (include-book "semantics") (include-book "centaur/aig/aig-base" :dir :system) (include-book "centaur/vl/util/cwtime" :dir :system) +(include-book "std/alists/alist-keys" :dir :system) (local (include-book "arithmetic/top-with-meta" :dir :system)) (local (in-theory (disable nth update-nth set::double-containment))) @@ -252,6 +253,8 @@ :measure (nfix (- (nfix (num-outs aignet)) (nfix n))) :verify-guards nil + :returns (outs (equal (len outs) + (nfix (- (num-outs aignet) (nfix n))))) (mbe :logic (b* (((when (mbe :logic (zp (- (num-outs aignet) (nfix n))) @@ -331,6 +334,12 @@ (equal (len regnames) (num-regs aignet)) (true-listp innames) (true-listp regnames)) + :prepwork ((local (defthm alistp-of-pairlis$ + (alistp (pairlis$ x y))))) + :returns (mv (outs (equal (len outs) (num-outs aignet))) + (regs (and (alistp regs) + (equal (acl2::alist-keys regs) + (acl2::list-fix regnames))))) (b* (((local-stobjs aigtrans) (mv outlist regalist aigtrans)) (aigtrans (resize-aigs (num-nodes aignet) aigtrans)) diff -Nru acl2-7.0/books/centaur/aignet/vecsim.lisp acl2-7.1/books/centaur/aignet/vecsim.lisp --- acl2-7.0/books/centaur/aignet/vecsim.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/aignet/vecsim.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -504,7 +504,7 @@ aignet)) (reg-vals (aignet-vals->regvals nil vals aignet))) (id-eval m in-vals reg-vals aignet)))) - :hints(("Goal" :in-theory (disable acl2::logbit-to-logbitp + :hints(("Goal" :in-theory (disable bitops::logbit-to-logbitp aignet-vecsim-iter)))) @@ -528,7 +528,7 @@ (nth id (aignet-eval (vecsim-to-eval slot bit s61v vals aignet) aignet)))) :hints (("goal" :in-theory (e/d (aignet-idp) - (acl2::logbit-to-logbitp + (bitops::logbit-to-logbitp aignet-vecsim)) :cases ((aignet-idp id aignet))))) diff -Nru acl2-7.0/books/centaur/bitops/ash-bounds.lisp acl2-7.1/books/centaur/bitops/ash-bounds.lisp --- acl2-7.0/books/centaur/bitops/ash-bounds.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/bitops/ash-bounds.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -31,7 +31,7 @@ ; ; Original author: Jared DavisThis unusual (but occasionally useful) proof strategy is similar to the
pick-a-point proofs found in the ordered sets or
There are a couple of ways to invoke the hint. First, you might manually appeal to the theorem using a hint such as:
@@ -734,17 +734,17 @@ '(and stable-under-simplificationp '(:computed-hint-replacement ((and stable-under-simplificationp - '(:in-theory (e/d* (acl2::logbitp-of-const-split)))) + '(:in-theory (e/d* (logbitp-of-const-split)))) (and stable-under-simplificationp '(:in-theory (e/d* (logbitp-case-splits logbitp-when-bit - acl2::logbitp-of-const-split)))) + logbitp-of-const-split)))) (and stable-under-simplificationp (equal-by-logbitp-hint)) (and stable-under-simplificationp '(:in-theory (e/d* (logbitp-case-splits logbitp-when-bit - acl2::logbitp-of-const-split + logbitp-of-const-split b-xor b-ior b-and))))) :no-thanks t)))) @@ -819,9 +819,9 @@ (std::defaggregate eqbylbp-config ((restriction pseudo-termp) - (witness-rule wcp-witness-rule-p) - (instance-rule (and (wcp-instance-rule-p instance-rule) - (equal (len (wcp-instance-rule->vars instance-rule)) 1))) + (witness-rule acl2::wcp-witness-rule-p) + (instance-rule (and (acl2::wcp-instance-rule-p instance-rule) + (equal (len (acl2::wcp-instance-rule->vars instance-rule)) 1))) (prune-examples) (passes posp) (simp-hint) @@ -838,29 +838,29 @@ (b* (((when (atom x)) (mv nil nil)) ((eqbylbp-config config) config) (rule config.witness-rule) - ((wcp-witness-rule rule) rule) + ((acl2::wcp-witness-rule rule) rule) (restriction-term config.restriction) ((mv rest-apply rest-terms) (eqbylbp-check-witnesses (cdr x) config state)) ((unless (mbt (and (pseudo-termp (car x)) - (wcp-witness-rule-p rule)))) + (acl2::wcp-witness-rule-p rule)))) (mv (cons nil rest-apply) rest-terms)) ((mv unify-ok alist) - (simple-one-way-unify rule.term (car x) nil)) + (acl2::simple-one-way-unify rule.term (car x) nil)) ((unless unify-ok) (mv (cons nil rest-apply) rest-terms)) ((mv er val) (if (equal restriction-term ''t) (mv nil t) - (witness-eval-restriction restriction-term alist state))) + (acl2::witness-eval-restriction restriction-term alist state))) (- (and er (raise "Restriction term evaluation failed! ~x0" er))) ((when (or er (not val))) (mv (cons nil rest-apply) rest-terms)) - (new-term (substitute-into-term rule.expr alist))) + (new-term (acl2::substitute-into-term rule.expr alist))) (mv (cons t rest-apply) (cons new-term rest-terms))) /// (defthm eqbylbp-check-witnesses-len-of-apply-list @@ -874,7 +874,7 @@ :mode :program (b* (((eqbylbp-config config) config) ((mv erp rw state) - (easy-simplify-term1-fn + (acl2::easy-simplify-term1-fn x nil config.simp-hint equiv t t 1000 1000 state)) ((when erp) (raise "Logbitp-reasoning: error simplifying ~x0: ~x1" x erp) @@ -989,7 +989,7 @@ examples config state))) -(define eqbylbp-eval-example ((alist pseudo-term-substp) +(define eqbylbp-eval-example ((alist acl2::pseudo-term-substp) (example pseudo-termp) (config eqbylbp-config-p) state) @@ -998,10 +998,11 @@ ;; Returns the list of logbitp args present in the simplification of the result. (b* (((eqbylbp-config config) config) (rule config.instance-rule) - ((wcp-instance-rule rule) rule) + ((acl2::wcp-instance-rule rule) rule) (alist1 (append (pairlis$ rule.vars (list example)) alist)) - (newterm (wcp-beta-reduce-term (substitute-into-term rule.expr alist1))) + (newterm (acl2::wcp-beta-reduce-term + (acl2::substitute-into-term rule.expr alist1))) ; (- (cw "Term: ~x0~%" newterm)) ((mv newterm-rw state) (eqbylbp-simplify newterm config 'iff state)) @@ -1010,9 +1011,9 @@ ) ) (mv includep (eqbylbp-collect-terms newterm-rw) state))) - -(define eqbylbp-try-example ((alist pseudo-term-substp) + +(define eqbylbp-try-example ((alist acl2::pseudo-term-substp) (example pseudo-termp) (target-logbitp-args pseudo-term-list-listp) (config eqbylbp-config-p) state) @@ -1034,12 +1035,13 @@ (cw "Rejected: ~x0 (produced: ~x1)~%" example new-logbitp-args)) (mv nil target-logbitp-args state)) (new-targets (set-difference-equal new-logbitp-args intersection))) - (mv (list (make-wcp-example-app :instrule config.instance-rule - :bindings (list example))) + (mv (list (acl2::make-wcp-example-app + :instrule config.instance-rule + :bindings (list example))) (append new-targets target-logbitp-args) state))) -(define eqbylbp-try-examples ((alist pseudo-term-substp) +(define eqbylbp-try-examples ((alist acl2::pseudo-term-substp) (examples pseudo-term-listp) (target-logbitp-args pseudo-term-list-listp) (config eqbylbp-config-p) @@ -1060,8 +1062,8 @@ ((mv rest-examples target-logbitp-args state) (eqbylbp-try-examples alist (cdr examples) target-logbitp-args config state))) (mv (append first-examples rest-examples) target-logbitp-args state))) - - + + (define eqbylbp-decide-examples-lit ((lit pseudo-termp) @@ -1075,15 +1077,15 @@ (mv nil target-logbitp-args state)) ((eqbylbp-config config) config) (rule config.instance-rule) - ((wcp-instance-rule rule) rule) + ((acl2::wcp-instance-rule rule) rule) ((mv unify-ok alist) - (simple-one-way-unify rule.pred lit nil)) + (acl2::simple-one-way-unify rule.pred lit nil)) ((unless unify-ok) (mv nil target-logbitp-args state)) (restriction-term config.restriction) ((mv er res) (if (equal restriction-term ''t) (mv nil t) - (witness-eval-restriction restriction-term alist state))) + (acl2::witness-eval-restriction restriction-term alist state))) (- (and er (raise "Restriction term evaluation failed! ~x0" er))) ((unless (and (not er) res)) @@ -1102,9 +1104,9 @@ ; (- (cw "Pruned examples: ~x0~%" examples)) ((when examples) (mv examples target-logbitp-args state))) - ;; Include the example consisting of just var itself, - (mv (list (make-wcp-example-app :instrule rule - :bindings (list var))) + ;; Include the example consisting of just var itself, + (mv (list (acl2::make-wcp-example-app :instrule rule + :bindings (list var))) (union-equal avail-logbitp-args target-logbitp-args) state))) @@ -1142,10 +1144,10 @@ (define wcp-example-apps-listp (x) (if (atom x) (eq x nil) - (and (wcp-example-appsp (car x)) + (and (acl2::wcp-example-appsp (car x)) (wcp-example-apps-listp (cdr x)))) /// - (defopen wcp-example-apps-listp-when-consp + (acl2::defopen wcp-example-apps-listp-when-consp (wcp-example-apps-listp x) :hyp (consp x) :hint (:expand ((wcp-example-apps-listp x))) @@ -1155,16 +1157,17 @@ (examples wcp-example-apps-listp) (config eqbylbp-config-p)) :guard (eql (len witness-apps) (len examples)) - :returns (actions wcp-lit-actions-listp) + :returns (actions acl2::wcp-lit-actions-listp) (if (atom witness-apps) nil - (cons (make-wcp-lit-actions :witnesses (and (car witness-apps) - (mbt (eqbylbp-config-p config)) - (list (eqbylbp-config->witness-rule config))) - :examples (and (mbt (wcp-example-appsp (car examples))) - (car examples))) + (cons (acl2::make-wcp-lit-actions + :witnesses (and (car witness-apps) + (mbt (eqbylbp-config-p config)) + (list (eqbylbp-config->witness-rule config))) + :examples (and (mbt (acl2::wcp-example-appsp (car examples))) + (car examples))) (eqbylbp-pair-hints (cdr witness-apps) (cdr examples) config)))) - + (define eqbylbp-witness-hints ((clause pseudo-term-listp) (config eqbylbp-config-p) @@ -1176,7 +1179,7 @@ ; (- (cw "Apply-witnesses: ~x0~%New-lits: ~x1~%" apply-witnesses new-lits)) ((mv new-lits-simp state) (eqbylbp-simplify-each - (wcp-beta-reduce-list new-lits) config 'iff state)) + (acl2::wcp-beta-reduce-list new-lits) config 'iff state)) (targets (eqbylbp-collect-terms-list (append new-lits-simp clause))) (- (and config.verbosep (cw "Targets: ~x0~%" targets))) @@ -1195,11 +1198,11 @@ verbosep stablep state) - + :mode :program (b* (((unless stablep) (value nil)) ((er restrict-term) - (translate restrict t nil t 'logbitp-reasoning (w state) state)) + (acl2::translate restrict t nil t 'logbitp-reasoning (w state) state)) (witness-rule (cdr (assoc 'unequal-by-logbitp-witnessing (table-alist 'witness-cp-witness-rules (w state))))) @@ -1349,7 +1352,7 @@ ") -(defmacro logbitp-reasoning (&key +(defmacro logbitp-reasoning (&key (restrict 't) (passes '1) (verbosep 'nil) @@ -1406,6 +1409,3 @@ (equal (logand mask (ash a1 n)) (logand mask (ash a2 n)))) :hints ((logbitp-reasoning)))) - - - diff -Nru acl2-7.0/books/centaur/bitops/extra-defs.lisp acl2-7.1/books/centaur/bitops/extra-defs.lisp --- acl2-7.0/books/centaur/bitops/extra-defs.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/bitops/extra-defs.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -28,7 +28,7 @@ ; ; Original author: Jared DavisWe leave this enabled; we would usually not expect to try to reason +about it.
" + :enabled t + :inline t + (mbe :logic + (logand (ash (ifix x) (* (nfix n) -128)) (1- (expt 2 128))) + :exec + (the (unsigned-byte 128) + (logand (ash x (* n -128)) + #ux_FFFFFFFF_FFFFFFFF_FFFFFFFF_FFFFFFFF))) + /// + (defcong nat-equiv equal (nth-slice128 n x) 1) + (defcong int-equiv equal (nth-slice128 n x) 2) + (defthm unsigned-byte-p-128-of-nth-slice128 + (unsigned-byte-p 128 (nth-slice128 n x)))) + + + (define negate-slice8 ((x :type (unsigned-byte 8))) :returns (~x natp :rule-classes :type-prescription) :parents (bitops/extra-defs) @@ -246,7 +269,7 @@ :returns (ans natp :rule-classes :type-prescription) :parents (bitops/extra-defs) :short "@(call abs-diff) is just @('(abs (- (ifix a) (ifix b)))'), but -optimized for @(see gl)." +optimized for @(see gl::gl)." :long "@('abs-diff') is similar to @('(abs (- a b))') but has better
performance for symbolic simulations with GL: it decides whether the
diff -Nru acl2-7.0/books/centaur/bitops/fast-logext.lisp acl2-7.1/books/centaur/bitops/fast-logext.lisp
--- acl2-7.0/books/centaur/bitops/fast-logext.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/centaur/bitops/fast-logext.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -29,7 +29,7 @@
; Original authors: Jared Davis These merge operations may be useful for describing SIMD style
-operations, byte swapping operations, and so forth. Each function here is logically simple, but we go to some lengths to make
-them execute more efficiently. For instance, We now introduce many operations that concatenate together bit
+vectors of some fixed size to create a new, merged bit vector. For example,
+@(see merge-4-u8s) joins together four 8-bit vectors into a 32-bit result. In general, the function @(see logapp) is a more flexible alternative to the
+operations below—it can be used to merge bit vectors of different sizes.
+However, since it can only merge two bit-vectors at a time, using @('logapp')
+directly can become quite tedious when you have a lot of vectors to merge. For
+instance, these merging operations may be especially useful for describing SIMD
+style operations, byte swapping operations, and so forth. Each of our merging operations is logically simple. However, we go to some
+lengths to make them execute more efficiently. This is accomplished by
+providing ample @(see acl2::type-spec) declarations and arranging the order of
+operations to use fixnums for as long as possible. This provides significant
+speedups, for instance: Note that when designing these functions, we typically assume that fixnums
+are large enough to hold 56-bit results. Our definitions should therefore
+perform well on 64-bit Lisps including at least CCL and SBCL. We prove that each merge produces a result of the correct size (expressed as
+a theorem about @(see unsigned-byte-p)), and that it has a @(see nat-equiv)
+@(see acl2::congruence) for each of its arguments. The efficiency improvement here is especially pronounced. The efficiency improvement here is especially pronounced. The executable version is considerably more efficient than the
+logic-mode definition.Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-8-u2s a7 a6 a5 a4 a3 a2 a1 a0) 8))
+
+
;; Merging Bytes --------------------------------------------------------------
@@ -89,12 +173,12 @@
(logior (the (unsigned-byte 16) (ash a1 8))
(the (unsigned-byte 16) a0))))
///
- (defcong nat-equiv equal (merge-2-u8s a1 a0) 1)
- (defcong nat-equiv equal (merge-2-u8s a1 a0) 2)
(defthm unsigned-byte-p-16-of-merge-2-u8s
(implies (and (unsigned-byte-p 8 a1)
(unsigned-byte-p 8 a0))
- (unsigned-byte-p 16 (merge-2-u8s a1 a0)))))
+ (unsigned-byte-p 16 (merge-2-u8s a1 a0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-2-u8s a1 a0) 2))
(define merge-4-u8s (a3 a2 a1 a0)
(declare (type (unsigned-byte 8) a3 a2 a1 a0))
@@ -122,16 +206,14 @@
(logior (the (unsigned-byte 32) a3)
(the (unsigned-byte 32) ans)))))
///
- (defcong nat-equiv equal (merge-4-u8s a3 a2 a1 a0) 1)
- (defcong nat-equiv equal (merge-4-u8s a3 a2 a1 a0) 2)
- (defcong nat-equiv equal (merge-4-u8s a3 a2 a1 a0) 3)
- (defcong nat-equiv equal (merge-4-u8s a3 a2 a1 a0) 4)
(defthm unsigned-byte-p-32-of-merge-4-u8s
(implies (and (unsigned-byte-p 8 a3)
(unsigned-byte-p 8 a2)
(unsigned-byte-p 8 a1)
(unsigned-byte-p 8 a0))
- (unsigned-byte-p 32 (merge-4-u8s a3 a2 a1 a0)))))
+ (unsigned-byte-p 32 (merge-4-u8s a3 a2 a1 a0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-4-u8s a3 a2 a1 a0) 4))
(define merge-8-u8s (a7 a6 a5 a4 a3 a2 a1 a0)
(declare (type (unsigned-byte 8) a7 a6 a5 a4 a3 a2 a1 a0))
@@ -182,14 +264,6 @@
(logior (the (unsigned-byte 64) a7)
(the (unsigned-byte 56) ans)))))
///
- (defcong nat-equiv equal (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 1)
- (defcong nat-equiv equal (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 2)
- (defcong nat-equiv equal (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 3)
- (defcong nat-equiv equal (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 4)
- (defcong nat-equiv equal (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 5)
- (defcong nat-equiv equal (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 6)
- (defcong nat-equiv equal (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 7)
- (defcong nat-equiv equal (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 8)
(defthm unsigned-byte-p-64-of-merge-8-u8s
(implies (and (unsigned-byte-p 8 a7)
(unsigned-byte-p 8 a6)
@@ -199,7 +273,9 @@
(unsigned-byte-p 8 a2)
(unsigned-byte-p 8 a1)
(unsigned-byte-p 8 a0))
- (unsigned-byte-p 64 (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0)))))
+ (unsigned-byte-p 64 (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-8-u8s a7 a6 a5 a4 a3 a2 a1 a0) 8))
(define merge-16-u8s (h7 h6 h5 h4 h3 h2 h1 h0
l7 l6 l5 l4 l3 l2 l1 l0)
@@ -210,30 +286,28 @@
:short "Concatenate sixteen bytes together to form a single 128-bit result."
:long "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-16-u8s h7 h6 h5 h4 h3 h2 h1 h0
+ l7 l6 l5 l4 l3 l2 l1 l0)
+ 16))
+
+
+(define merge-32-u8s (a7 a6 a5 a4 a3 a2 a1 a0
+ b7 b6 b5 b4 b3 b2 b1 b0
+ c7 c6 c5 c4 c3 c2 c1 c0
+ d7 d6 d5 d4 d3 d2 d1 d0)
+ (declare (type (unsigned-byte 8)
+ a7 a6 a5 a4 a3 a2 a1 a0
+ b7 b6 b5 b4 b3 b2 b1 b0
+ c7 c6 c5 c4 c3 c2 c1 c0
+ d7 d6 d5 d4 d3 d2 d1 d0))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate 32 bytes together to form a single 256-bit result."
+ :guard-hints(("Goal" :in-theory (enable merge-16-u8s)))
+
+ :long "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-32-u8s a7 a6 a5 a4 a3 a2 a1 a0
+ b7 b6 b5 b4 b3 b2 b1 b0
+ c7 c6 c5 c4 c3 c2 c1 c0
+ d7 d6 d5 d4 d3 d2 d1 d0)
+ 32))
;; Merging Words --------------------------------------------------------------
@@ -387,12 +580,12 @@
(logior (the (unsigned-byte 32) (ash a1 16))
a0)))
///
- (defcong nat-equiv equal (merge-2-u16s a1 a0) 1)
- (defcong nat-equiv equal (merge-2-u16s a1 a0) 2)
(defthm unsigned-byte-p-32-of-merge-2-u16s
(implies (and (unsigned-byte-p 16 a1)
(unsigned-byte-p 16 a0))
- (unsigned-byte-p 32 (merge-2-u16s a1 a0)))))
+ (unsigned-byte-p 32 (merge-2-u16s a1 a0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-2-u16s a1 a0) 2))
(define merge-4-u16s (a3 a2 a1 a0)
(declare (type (unsigned-byte 16) a3 a2 a1 a0))
@@ -420,16 +613,14 @@
(logior (the (unsigned-byte 64) a3)
(the (unsigned-byte 56) ans)))))
///
- (defcong nat-equiv equal (merge-4-u16s a3 a2 a1 a0) 1)
- (defcong nat-equiv equal (merge-4-u16s a3 a2 a1 a0) 2)
- (defcong nat-equiv equal (merge-4-u16s a3 a2 a1 a0) 3)
- (defcong nat-equiv equal (merge-4-u16s a3 a2 a1 a0) 4)
(defthm unsigned-byte-p-64-of-merge-4-u16s
(implies (and (unsigned-byte-p 16 a3)
(unsigned-byte-p 16 a2)
(unsigned-byte-p 16 a1)
(unsigned-byte-p 16 a0))
- (unsigned-byte-p 64 (merge-4-u16s a3 a2 a1 a0)))))
+ (unsigned-byte-p 64 (merge-4-u16s a3 a2 a1 a0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-4-u16s a3 a2 a1 a0) 4))
(define merge-8-u16s (h3 h2 h1 h0 l3 l2 l1 l0)
(declare (type (unsigned-byte 16) h3 h2 h1 h0 l3 l2 l1 l0))
@@ -499,14 +690,6 @@
(logior (the (unsigned-byte 128) high)
(the (unsigned-byte 64) low)))))
///
- (defcong nat-equiv equal (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 1)
- (defcong nat-equiv equal (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 2)
- (defcong nat-equiv equal (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 3)
- (defcong nat-equiv equal (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 4)
- (defcong nat-equiv equal (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 5)
- (defcong nat-equiv equal (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 6)
- (defcong nat-equiv equal (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 7)
- (defcong nat-equiv equal (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 8)
(defthm unsigned-byte-p-128-of-merge-8-u16s
(implies (and (unsigned-byte-p 16 h3)
(unsigned-byte-p 16 h2)
@@ -516,7 +699,72 @@
(unsigned-byte-p 16 l2)
(unsigned-byte-p 16 l1)
(unsigned-byte-p 16 l0))
- (unsigned-byte-p 128 (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0)))))
+ (unsigned-byte-p 128 (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-8-u16s h3 h2 h1 h0 l3 l2 l1 l0) 8))
+
+
+(define merge-16-u16s (h7 h6 h5 h4 h3 h2 h1 h0
+ l7 l6 l5 l4 l3 l2 l1 l0)
+ (declare (type (unsigned-byte 16)
+ h7 h6 h5 h4 h3 h2 h1 h0
+ l7 l6 l5 l4 l3 l2 l1 l0))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate sixteen 16-bit values together to form a single 256-bit
+result."
+ :long "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-16-u16s h7 h6 h5 h4 h3 h2 h1 h0
+ l7 l6 l5 l4 l3 l2 l1 l0)
+ 16))
+
;; Merging Dwords -------------------------------------------------------------
@@ -534,12 +782,12 @@
(logior (the (unsigned-byte 64) (ash a1 32))
a0)))
///
- (defcong nat-equiv equal (merge-2-u32s a1 a0) 1)
- (defcong nat-equiv equal (merge-2-u32s a1 a0) 2)
(defthm unsigned-byte-p-64-of-merge-2-u32s
(implies (and (unsigned-byte-p 32 a1)
(unsigned-byte-p 32 a0))
- (unsigned-byte-p 64 (merge-2-u32s a1 a0)))))
+ (unsigned-byte-p 64 (merge-2-u32s a1 a0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-2-u32s a1 a0) 2))
(define merge-4-u32s (h1 h0 l1 l0)
(declare (type (unsigned-byte 32) h1 h0 l1 l0))
@@ -565,16 +813,108 @@
(logior (the (unsigned-byte 128) high)
(the (unsigned-byte 64) low)))))
///
- (defcong nat-equiv equal (merge-4-u32s h1 h0 l1 l0) 1)
- (defcong nat-equiv equal (merge-4-u32s h1 h0 l1 l0) 2)
- (defcong nat-equiv equal (merge-4-u32s h1 h0 l1 l0) 3)
- (defcong nat-equiv equal (merge-4-u32s h1 h0 l1 l0) 4)
- (defthm unsigned-byte-p-64-of-merge-4-u32s
+ (defthm unsigned-byte-p-128-of-merge-4-u32s
(implies (and (unsigned-byte-p 32 h1)
(unsigned-byte-p 32 h0)
(unsigned-byte-p 32 l1)
(unsigned-byte-p 32 l0))
- (unsigned-byte-p 128 (merge-4-u32s h1 h0 l1 l0)))))
+ (unsigned-byte-p 128 (merge-4-u32s h1 h0 l1 l0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-4-u32s h1 h0 l1 l0) 4))
+
+(define merge-8-u32s (h3 h2 h1 h0 l3 l2 l1 l0)
+ (declare (type (unsigned-byte 32) h3 h2 h1 h0 l3 l2 l1 l0))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate eight 32-bit values together to form a single 256-bit
+result."
+ :guard-hints(("Goal" :in-theory (enable merge-4-u32s)))
+ (mbe :logic
+ (logior (ash (nfix h3) (* 7 32))
+ (ash (nfix h2) (* 6 32))
+ (ash (nfix h1) (* 5 32))
+ (ash (nfix h0) (* 4 32))
+ (ash (nfix l3) (* 3 32))
+ (ash (nfix l2) (* 2 32))
+ (ash (nfix l1) (* 1 32))
+ (nfix l0))
+ :exec
+ (b* (((the (unsigned-byte 128) high) (merge-4-u32s h3 h2 h1 h0))
+ ((the (unsigned-byte 128) low) (merge-4-u32s l3 l2 l1 l0)))
+ (the (unsigned-byte 256)
+ (logior
+ (the (unsigned-byte 256) (ash (the (unsigned-byte 128) high) 128))
+ (the (unsigned-byte 128) low)))))
+ ///
+ (defthm unsigned-byte-p-256-of-merge-8-u32s
+ (implies (and (unsigned-byte-p 32 h3)
+ (unsigned-byte-p 32 h2)
+ (unsigned-byte-p 32 h1)
+ (unsigned-byte-p 32 h0)
+ (unsigned-byte-p 32 l3)
+ (unsigned-byte-p 32 l2)
+ (unsigned-byte-p 32 l1)
+ (unsigned-byte-p 32 l0))
+ (unsigned-byte-p 256 (merge-8-u32s h3 h2 h1 h0 l3 l2 l1 l0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-8-u32s h3 h2 h1 h0 l3 l2 l1 l0) 8))
+
+(define merge-16-u32s (h7 h6 h5 h4 h3 h2 h1 h0
+ l7 l6 l5 l4 l3 l2 l1 l0)
+ (declare (type (unsigned-byte 32)
+ h7 h6 h5 h4 h3 h2 h1 h0
+ l7 l6 l5 l4 l3 l2 l1 l0))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate sixteen 32-bit values together to form a single 512-bit
+result."
+ :guard-hints(("Goal" :in-theory (enable merge-8-u32s)))
+ (mbe :logic
+ (logior (ash (nfix h7) (* 15 32))
+ (ash (nfix h6) (* 14 32))
+ (ash (nfix h5) (* 13 32))
+ (ash (nfix h4) (* 12 32))
+ (ash (nfix h3) (* 11 32))
+ (ash (nfix h2) (* 10 32))
+ (ash (nfix h1) (* 9 32))
+ (ash (nfix h0) (* 8 32))
+ (ash (nfix l7) (* 7 32))
+ (ash (nfix l6) (* 6 32))
+ (ash (nfix l5) (* 5 32))
+ (ash (nfix l4) (* 4 32))
+ (ash (nfix l3) (* 3 32))
+ (ash (nfix l2) (* 2 32))
+ (ash (nfix l1) (* 1 32))
+ (nfix l0))
+ :exec
+ (b* (((the (unsigned-byte 256) high) (merge-8-u32s h7 h6 h5 h4 h3 h2 h1 h0))
+ ((the (unsigned-byte 256) low) (merge-8-u32s l7 l6 l5 l4 l3 l2 l1 l0)))
+ (the (unsigned-byte 512)
+ (logior
+ (the (unsigned-byte 512) (ash (the (unsigned-byte 256) high) 256))
+ (the (unsigned-byte 256) low)))))
+ ///
+ (defthm unsigned-byte-p-512-of-merge-16-u32s
+ (implies (and (unsigned-byte-p 32 h7)
+ (unsigned-byte-p 32 h6)
+ (unsigned-byte-p 32 h5)
+ (unsigned-byte-p 32 h4)
+ (unsigned-byte-p 32 h3)
+ (unsigned-byte-p 32 h2)
+ (unsigned-byte-p 32 h1)
+ (unsigned-byte-p 32 h0)
+ (unsigned-byte-p 32 l7)
+ (unsigned-byte-p 32 l6)
+ (unsigned-byte-p 32 l5)
+ (unsigned-byte-p 32 l4)
+ (unsigned-byte-p 32 l3)
+ (unsigned-byte-p 32 l2)
+ (unsigned-byte-p 32 l1)
+ (unsigned-byte-p 32 l0))
+ (unsigned-byte-p 512 (merge-16-u32s h7 h6 h5 h4 h3 h2 h1 h0
+ l7 l6 l5 l4 l3 l2 l1 l0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-16-u32s h7 h6 h5 h4 h3 h2 h1 h0
+ l7 l6 l5 l4 l3 l2 l1 l0)
+ 16))
;; Merging Qwords -------------------------------------------------------------
@@ -597,10 +937,161 @@
l))))
///
- (defcong nat-equiv equal (merge-2-u64s h l) 1)
- (defcong nat-equiv equal (merge-2-u64s h l) 2)
(defthm unsigned-byte-p-128-of-merge-2-u64s
(implies (and (unsigned-byte-p 64 h)
(unsigned-byte-p 64 l))
- (unsigned-byte-p 128 (merge-2-u64s h l)))))
+ (unsigned-byte-p 128 (merge-2-u64s h l))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-2-u64s h l) 2))
+
+(define merge-4-u64s (h1 h0 l1 l0)
+ (declare (type (unsigned-byte 64) h1 h0 l1 l0))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate four 64-bit values together to form a single 256-bit
+result."
+ :guard-hints(("Goal" :in-theory (enable merge-2-u64s)))
+ (mbe :logic
+ (logior (ash (nfix h1) (* 3 64))
+ (ash (nfix h0) (* 2 64))
+ (ash (nfix l1) (* 1 64))
+ (nfix l0))
+ :exec
+ (b* (((the (unsigned-byte 128) high) (merge-2-u64s h1 h0))
+ ((the (unsigned-byte 128) low) (merge-2-u64s l1 l0)))
+ (the (unsigned-byte 256)
+ (logior
+ (the (unsigned-byte 256) (ash (the (unsigned-byte 128) high) 128))
+ (the (unsigned-byte 128) low)))))
+ ///
+ (defthm unsigned-byte-p-256-of-merge-4-u64s
+ (implies (and (unsigned-byte-p 64 h1)
+ (unsigned-byte-p 64 h0)
+ (unsigned-byte-p 64 l1)
+ (unsigned-byte-p 64 l0))
+ (unsigned-byte-p 256 (merge-4-u64s h1 h0 l1 l0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-4-u64s h1 h0 l1 l0) 4))
+
+(define merge-8-u64s (h3 h2 h1 h0 l3 l2 l1 l0)
+ (declare (type (unsigned-byte 64) h3 h2 h1 h0 l3 l2 l1 l0))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate eight 64-bit values together to form a single 512-bit
+result."
+ :guard-hints(("Goal" :in-theory (enable merge-4-u64s)))
+ (mbe :logic
+ (logior (ash (nfix h3) (* 7 64))
+ (ash (nfix h2) (* 6 64))
+ (ash (nfix h1) (* 5 64))
+ (ash (nfix h0) (* 4 64))
+ (ash (nfix l3) (* 3 64))
+ (ash (nfix l2) (* 2 64))
+ (ash (nfix l1) (* 1 64))
+ (nfix l0))
+ :exec
+ (b* (((the (unsigned-byte 256) high) (merge-4-u64s h3 h2 h1 h0))
+ ((the (unsigned-byte 256) low) (merge-4-u64s l3 l2 l1 l0)))
+ (the (unsigned-byte 512)
+ (logior
+ (the (unsigned-byte 512) (ash (the (unsigned-byte 256) high) 256))
+ (the (unsigned-byte 256) low)))))
+ ///
+ (defthm unsigned-byte-p-512-of-merge-8-u64s
+ (implies (and (unsigned-byte-p 64 h3)
+ (unsigned-byte-p 64 h2)
+ (unsigned-byte-p 64 h1)
+ (unsigned-byte-p 64 h0)
+ (unsigned-byte-p 64 l3)
+ (unsigned-byte-p 64 l2)
+ (unsigned-byte-p 64 l1)
+ (unsigned-byte-p 64 l0))
+ (unsigned-byte-p 512 (merge-8-u64s h3 h2 h1 h0 l3 l2 l1 l0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-8-u64s h3 h2 h1 h0 l3 l2 l1 l0) 8))
+
+
+
+;; Merging 128s -------------------------------------------------------------
+(define merge-2-u128s (h l)
+ (declare (type (unsigned-byte 128) h l))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate two 128-bit values together to form a single 256-bit
+result."
+ :inline t
+ (mbe :logic
+ (logior (ash (nfix h) 128)
+ (nfix l))
+ :exec
+ (the (unsigned-byte 256)
+ (logior (the (unsigned-byte 256)
+ (ash (the (unsigned-byte 128) h)
+ 128))
+ (the (unsigned-byte 128)
+ l))))
+
+ ///
+ (defthm unsigned-byte-p-256-of-merge-2-u128s
+ (implies (and (unsigned-byte-p 128 h)
+ (unsigned-byte-p 128 l))
+ (unsigned-byte-p 256 (merge-2-u128s h l))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-2-u128s h l) 2))
+
+
+(define merge-4-u128s (h1 h0 l1 l0)
+ (declare (type (unsigned-byte 128) h1 h0 l1 l0))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate four 128-bit values together to form a single 512-bit
+result."
+ :guard-hints(("Goal" :in-theory (enable merge-2-u128s)))
+ :inline t
+ (mbe :logic
+ (logior (ash (nfix h1) (* 3 128))
+ (ash (nfix h0) (* 2 128))
+ (ash (nfix l1) (* 1 128))
+ (nfix l0))
+ :exec
+ (b* ((high (merge-2-u128s h1 h0))
+ (low (merge-2-u128s l1 l0)))
+ (the (unsigned-byte 512)
+ (logior (the (unsigned-byte 512)
+ (ash (the (unsigned-byte 256) high)
+ 256))
+ (the (unsigned-byte 256) low)))))
+
+ ///
+ (defthm unsigned-byte-p-512-of-merge-4-u128s
+ (implies (and (unsigned-byte-p 128 h1)
+ (unsigned-byte-p 128 h0)
+ (unsigned-byte-p 128 l1)
+ (unsigned-byte-p 128 l0))
+ (unsigned-byte-p 512 (merge-4-u128s h1 h0 l1 l0))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-4-u128s h1 h0 l1 l0) 4))
+
+
+
+;; Merging 256s -------------------------------------------------------------
+
+(define merge-2-u256s (h l)
+ (declare (type (unsigned-byte 256) h l))
+ :returns (result natp :rule-classes :type-prescription)
+ :short "Concatenate two 256-bit values together to form a single 512-bit
+result."
+ :inline t
+ (mbe :logic
+ (logior (ash (nfix h) 256)
+ (nfix l))
+ :exec
+ (the (unsigned-byte 512)
+ (logior (the (unsigned-byte 512)
+ (ash (the (unsigned-byte 256) h)
+ 256))
+ (the (unsigned-byte 256) l))))
+ ///
+ (defthm unsigned-byte-p-512-of-merge-2-u256s
+ (implies (and (unsigned-byte-p 256 h)
+ (unsigned-byte-p 256 l))
+ (unsigned-byte-p 512 (merge-2-u256s h l))))
+ "Basic @(see nat-equiv) congruences.
"
+ (congruences-for-merge (merge-2-u256s h l) 2))
diff -Nru acl2-7.0/books/centaur/bitops/package.lsp acl2-7.1/books/centaur/bitops/package.lsp
--- acl2-7.0/books/centaur/bitops/package.lsp 1970-01-01 00:00:00.000000000 +0000
+++ acl2-7.1/books/centaur/bitops/package.lsp 2015-05-08 18:07:33.000000000 +0000
@@ -0,0 +1,208 @@
+; Centaur Bitops Library
+; Copyright (C) 2010-2015 Centaur Technology
+;
+; Contact:
+; Centaur Technology Formal Verification Group
+; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA.
+; http://www.centtech.com/
+;
+; License: (An MIT/X11-style license)
+;
+; Permission is hereby granted, free of charge, to any person obtaining a
+; copy of this software and associated documentation files (the "Software"),
+; to deal in the Software without restriction, including without limitation
+; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+; and/or sell copies of the Software, and to permit persons to whom the
+; Software is furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+; DEALINGS IN THE SOFTWARE.
+;
+; Original author: Jared Davis
BOZO document me.
") (defthm basic-unsigned-byte-p-of-+ @@ -321,7 +322,7 @@ (expt 2 (+ -1 n n)))) :rule-classes ((:rewrite) (:linear)) :hints(("Goal" - :in-theory (disable exponents-add) + :in-theory (disable acl2::exponents-add) :nonlinearp t :use ((:instance step1b) (:instance step2) @@ -390,7 +391,7 @@ (expt 2 (+ -2 n n)))) :rule-classes ((:rewrite) (:linear)) :hints(("Goal" - :in-theory (disable exponents-add) + :in-theory (disable acl2::exponents-add) :nonlinearp t :use ((:instance step1c) (:instance step2) @@ -789,7 +790,7 @@ (natp n)) (< (- x) (expt 2 n))) :hints(("Goal" - :in-theory (disable expt-is-increasing-for-base>1) + :in-theory (disable acl2::expt-is-increasing-for-base>1) :use ((:instance l1) (:instance l2)))))) @@ -1050,4 +1051,4 @@ (defthm signed-byte-p-of-loghead (implies (and (integerp m) (< (nfix size) m)) - (signed-byte-p m (loghead size x))))) \ No newline at end of file + (signed-byte-p m (loghead size x))))) diff -Nru acl2-7.0/books/centaur/bitops/top.lisp acl2-7.1/books/centaur/bitops/top.lisp --- acl2-7.0/books/centaur/bitops/top.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/bitops/top.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -28,7 +28,7 @@ ; ; Original author: Jared DavisBitops definitions are typically compatible with @(see gl), a framework for -bit-blasting ACL2 theorems. GL is mainly applicable to bounded problems, but -is highly automatic. This nicely complements Bitops, which is a more +
Bitops definitions are typically compatible with @(see gl::gl), a framework +for bit-blasting ACL2 theorems. GL is mainly applicable to bounded problems, +but is highly automatic. This nicely complements Bitops, which is a more traditional library of lemmas that can be applied to unbounded problems.
@@ -189,8 +190,9 @@ @('n')-bit signed numbers, you get an @('n+1')-bit signed number.These rules can be very helpful when you are trying to write optimized -functions using Common Lisp @(see type-spec)s and need to satisfy the guard -obligations that come from terms such as @('(the (unsigned-byte 16) x)').
+functions using Common Lisp @(see acl2::type-spec)s and need to satisfy the +guard obligations that come from terms such as @('(the (unsigned-byte 16) +x)').You can use this book independently of the rest of the library. It currently has some support for reasoning about +, -, *, lognot, ash, logcdr, @@ -356,10 +358,10 @@ 1)') or similar.
2. The book @('arithmetic/top-with-meta') is only slightly stronger; -it adds some @(see meta) rules that can more effectively cancel out summands -and factors that can arise in various equalities and inequalities. It's a fine -choice that is about on par with @('arithmetic/top'), but which is superior in -some cases.
+it adds some @(see acl2::meta) rules that can more effectively cancel out +summands and factors that can arise in various equalities and inequalities. +It's a fine choice that is about on par with @('arithmetic/top'), but which is +superior in some cases.This book is also very compatible with Bitops and may be a good choice for @@ -382,7 +384,8 @@ machine models), you might want to start with @('arithmetic/top-with-meta') instead of @('arithmetic-3'), but only because @('arithmetic-3')'s more powerful rules are perhaps somewhat slower—it has a lot of @(see -type-prescription) rules, for instance, and these can sometimes get slow.
+acl2::type-prescription) rules, for instance, and these can sometimes get +slow.2. The @('arithmetic-3/floor-mod/floor-mod') book extends @('bind-free/top') with rules about @(see floor) and @(see mod). It also gets @@ -422,8 +425,8 @@
We usually prefer not to use @('arithmetic-5'). The library can sometimes be quite slow; many rules case split and there are, for instance, a great -number of @(see type-prescription) rules that can become very expensive in some -cases. For instance, an extreme case was @('lemma-4-1-30') from +number of @(see acl2::type-prescription) rules that can become very expensive +in some cases. For instance, an extreme case was @('lemma-4-1-30') from @('rtl/rel9/seed.lisp')—we were able to speed this proof up from 651 seconds to 1 second by mostly just disabling these type-prescription rules; see SVN revision 2160 for details.
@@ -444,7 +447,7 @@ rules may sometimes work against you. For instance, rules like these are likely not what you want: -@(def |(logand 1 x)|) +@(def acl2::|(logand 1 x)|)And generally @('arithmetic-5') likes to reason about @('(integerp (* 1/2
x))') instead of @('(logcar x)'), which is messy because it introduces rational
diff -Nru acl2-7.0/books/centaur/bridge/acl2-customization.lsp acl2-7.1/books/centaur/bridge/acl2-customization.lsp
--- acl2-7.0/books/centaur/bridge/acl2-customization.lsp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/centaur/bridge/acl2-customization.lsp 2015-05-08 18:07:33.000000000 +0000
@@ -31,7 +31,9 @@
(in-package "ACL2")
(ld "~/acl2-customization.lsp" :ld-missing-input-ok t)
(ld "package.lsp")
-(ld "tools/flag-package.lsp" :dir :system)
+; Matt K. mod: Replace with a form that does not cause an error.
+; (ld "tools/flag-package.lsp" :dir :system)
+(include-book "std/portcullis" :dir :system)
(include-book "str/portcullis" :dir :system)
(include-book "xdoc/portcullis" :dir :system)
diff -Nru acl2-7.0/books/centaur/bridge/portcullis.acl2 acl2-7.1/books/centaur/bridge/portcullis.acl2
--- acl2-7.0/books/centaur/bridge/portcullis.acl2 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/centaur/bridge/portcullis.acl2 2015-05-08 18:07:33.000000000 +0000
@@ -31,6 +31,7 @@
(in-package "ACL2")
(ld "package.lsp")
-(ld "tools/flag-package.lsp" :dir :system)
(include-book "std/portcullis" :dir :system)
+; Matt K. mod: The following is redundant with the line above.
+; (ld "tools/flag-package.lsp" :dir :system)
; cert-flags: ? t :ttags :all
diff -Nru acl2-7.0/books/centaur/bridge/to-json.lisp acl2-7.1/books/centaur/bridge/to-json.lisp
--- acl2-7.0/books/centaur/bridge/to-json.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/centaur/bridge/to-json.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -193,11 +193,11 @@
(<= (acl2::loghead 4 code) 15)
:rule-classes ((:rewrite) (:linear))
:hints(("Goal"
- :in-theory (disable acl2::unsigned-byte-p-of-loghead)
- :use ((:instance acl2::unsigned-byte-p-of-loghead
- (acl2::size 4)
- (acl2::size1 4)
- (acl2::i code)))))))
+ :in-theory (disable bitops::unsigned-byte-p-of-loghead)
+ :use ((:instance bitops::unsigned-byte-p-of-loghead
+ (bitops::size 4)
+ (bitops::size1 4)
+ (bitops::i code)))))))
(local (defthm crock2
(implies (and (integerp code)
@@ -206,11 +206,11 @@
(<= (acl2::logtail 4 code) 15))
:rule-classes ((:rewrite) (:linear))
:hints(("Goal"
- :in-theory (disable acl2::unsigned-byte-p-of-logtail)
- :use ((:instance acl2::unsigned-byte-p-of-logtail
- (acl2::size 4)
- (acl2::size1 4)
- (acl2::i code))))))))
+ :in-theory (disable bitops::unsigned-byte-p-of-logtail)
+ :use ((:instance bitops::unsigned-byte-p-of-logtail
+ (bitops::size 4)
+ (bitops::size1 4)
+ (bitops::i code))))))))
(b* ((lo (logand code #xF))
(hi (logand (ash code -4) #xF))
diff -Nru acl2-7.0/books/centaur/defrstobj/defrstobj.lisp acl2-7.1/books/centaur/defrstobj/defrstobj.lisp
--- acl2-7.0/books/centaur/defrstobj/defrstobj.lisp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/centaur/defrstobj/defrstobj.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -32,7 +32,7 @@
(include-book "def-typed-record")
(include-book "generic")
(include-book "misc/records" :dir :system)
-(include-book "tools/bstar" :dir :system)
+(include-book "std/util/bstar" :dir :system)
(include-book "centaur/misc/arith-equivs" :dir :system)
(include-book "centaur/misc/absstobjs" :dir :system)
(include-book "std/lists/nth" :dir :system)
diff -Nru acl2-7.0/books/centaur/esim/acl2-customization.lsp acl2-7.1/books/centaur/esim/acl2-customization.lsp
--- acl2-7.0/books/centaur/esim/acl2-customization.lsp 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/centaur/esim/acl2-customization.lsp 2015-05-08 18:07:33.000000000 +0000
@@ -1,5 +1,5 @@
; ESIM Symbolic Hardware Simulator
-; Copyright (C) 2010-2012 Centaur Technology
+; Copyright (C) 2008-2015 Centaur Technology
;
; Contact:
; Centaur Technology Formal Verification Group
diff -Nru acl2-7.0/books/centaur/esim/cert.acl2 acl2-7.1/books/centaur/esim/cert.acl2
--- acl2-7.0/books/centaur/esim/cert.acl2 2015-01-13 21:12:30.000000000 +0000
+++ acl2-7.1/books/centaur/esim/cert.acl2 2015-05-08 18:07:33.000000000 +0000
@@ -1,5 +1,5 @@
; ESIM Symbolic Hardware Simulator
-; Copyright (C) 2010-2012 Centaur Technology
+; Copyright (C) 2008-2015 Centaur Technology
;
; Contact:
; Centaur Technology Formal Verification Group
@@ -29,4 +29,4 @@
; cert.acl2
(include-book "portcullis")
-; cert-flags: ? t :ttags :all
\ No newline at end of file
+; cert-flags: ? t :ttags :all
diff -Nru acl2-7.0/books/centaur/esim/defmodules.lisp acl2-7.1/books/centaur/esim/defmodules.lisp
--- acl2-7.0/books/centaur/esim/defmodules.lisp 1970-01-01 00:00:00.000000000 +0000
+++ acl2-7.1/books/centaur/esim/defmodules.lisp 2015-05-08 18:07:33.000000000 +0000
@@ -0,0 +1,387 @@
+; ESIM Symbolic Hardware Simulator
+; Copyright (C) 2008-2015 Centaur Technology
+;
+; Contact:
+; Centaur Technology Formal Verification Group
+; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA.
+; http://www.centtech.com/
+;
+; License: (An MIT/X11-style license)
+;
+; Permission is hereby granted, free of charge, to any person obtaining a
+; copy of this software and associated documentation files (the "Software"),
+; to deal in the Software without restriction, including without limitation
+; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+; and/or sell copies of the Software, and to permit persons to whom the
+; Software is furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+; DEALINGS IN THE SOFTWARE.
+;
+; Original author: Jared Davis Note: if you are new to VL and are trying to load some Verilog
+modules, you might want to start with the ESIM Hardware Verification
+Tutorial located in @({ books/centaur/esim/tutorial/intro.lisp }), which
+shows some examples of using @('defmodules') and working with the resulting
+translation. The @('defmodules') macro allows you to load Verilog files into your ACL2
+session \"on the fly.\" General Form: The required @('loadconfig') is @(see vl-loadconfig-p) that says which files
+to load, which directories to search for modules in, etc. For very simple
+cases where you just want to load a few self-contained Verilog files, you can
+just do something like this: After submitting this event, @('*foo*') will be an ACL2 @(see defconst) that
+holds a @(see vl-translation-p) object. This object contains the parsed,
+simplified Verilog modules, their corresponding E modules, etc. The @(see vl-loadconfig-p) has many options for setting up include paths,
+search paths, search extensions, initial @('`define') settings, etc. For
+instance, to parse a larger project that makes use of library modules, you
+might need a command like: Aside from the load configuration, you can also control certain aspects of
+how simplification is done with the @('simpconfig') option; see @(see
+vl-simpconfig-p). In many cases, the defaults will probably be fine. The patterns used for the :i and :o ports here might look strange.
For instance, why do we use @('((|a|) (|b|))') as the input pattern for an AND
gate instead of @('(|a| |b|)')? This allows our primitives to be directly
-compatible with VL's primitives, as far as @(see vl::vl-portdecls-to-i/o) is
+compatible with VL's primitives, as far as @(see vl2014::vl-portdecls-to-i/o) is
concerned. BOZO Things to consider: We use this to implement @(see vl::*vl-1-bit-t*). We use this to implement @(see vl2014::*vl-1-bit-t*). We use this to implement @(see vl::*vl-1-bit-f*). We use this to implement @(see vl2014::*vl-1-bit-f*). We use this to implement @(see vl::*vl-1-bit-x*). We use this to implement @(see vl2014::*vl-1-bit-x*). We use this to implement @(see vl::*vl-1-bit-z*). We use this to implement @(see vl2014::*vl-1-bit-z*). We use this to implement @(see vl::*vl-1-bit-assign*). This
+ :long " We use this to implement @(see vl2014::*vl-1-bit-assign*). This
differs from a BUF in that it does not coerce Z into X. There is probably not
any way to actually implement this in hardware. We use this to implement @(see vl::*vl-1-bit-delay-1*). However,
+ :long " We use this to implement @(see vl2014::*vl-1-bit-delay-1*). However,
really esim has no concept of delays and this is no different @(see
*esim-id*). We use this to implement @(see vl::*vl-1-bit-buf*). This is used
+ :long " We use this to implement @(see vl2014::*vl-1-bit-buf*). This is used
for real BUF gates, not for ordinary assignments; see also @(see
*esim-id*). We use this to implement @(see vl::*vl-1-bit-not*). We use this to implement @(see vl2014::*vl-1-bit-not*). We use this to implement @(see vl::*vl-1-bit-and*). We use this to implement @(see vl2014::*vl-1-bit-and*). We use this to implement @(see vl::*vl-1-bit-or*). We use this to implement @(see vl2014::*vl-1-bit-or*). We use this to implement @(see vl::*vl-1-bit-xor*). We use this to implement @(see vl2014::*vl-1-bit-xor*). We use this to implement @(see vl::*vl-1-bit-nand*). We use this to implement @(see vl2014::*vl-1-bit-nand*). We use this to implement @(see vl::*vl-1-bit-nor*). We use this to implement @(see vl2014::*vl-1-bit-nor*). We use this to implement @(see vl::*vl-1-bit-xnor*). We use this to implement @(see vl2014::*vl-1-bit-xnor*). We use this to implement @(see vl::*vl-1-bit-ceq*). We use this to implement @(see vl2014::*vl-1-bit-ceq*). However, the @('===') operator is inherently unsound and cannot be modeled
in esim because it is violates @(see 4v-monotonicity). We just conservatively
@@ -205,14 +205,14 @@
(def-esim-primitive *esim-safe-mux*
:short "Primitive E module for a (more conservative) mux."
- :long " We use this to implement @(see vl::*vl-1-bit-approx-mux*). We use this to implement @(see vl2014::*vl-1-bit-approx-mux*). We use this to implement @(see vl::*vl-1-bit-mux*). We use this to implement @(see vl2014::*vl-1-bit-mux*). We use this to implement @(see vl::*vl-1-bit-zmux*). We use this to implement @(see vl2014::*vl-1-bit-zmux*). We use this to implement @(see vl::*vl-1-bit-flop*). We use this to implement @(see vl2014::*vl-1-bit-flop*). We use this to implement @(see vl::*vl-1-bit-latch*). We use this to implement @(see vl2014::*vl-1-bit-latch*). We use this to implement @(see vl::*vl-1-bit-bufif0*). We use this to implement @(see vl2014::*vl-1-bit-bufif0*). We use this to implement @(see vl::*vl-1-bit-bufif1*). We use this to implement @(see vl2014::*vl-1-bit-bufif1*). We use this to implement @(see vl::*vl-1-bit-notif0*). We use this to implement @(see vl2014::*vl-1-bit-notif0*). We use this to implement @(see vl::*vl-1-bit-notif1*). We use this to implement @(see vl2014::*vl-1-bit-notif1*). We use this to implement @(see vl::*vl-1-bit-nmos*). We use this to implement @(see vl2014::*vl-1-bit-nmos*). We use this to implement @(see vl::*vl-1-bit-pmos*). We use this to implement @(see vl2014::*vl-1-bit-pmos*). We use this to implement @(see vl::*vl-1-bit-cmos*). We use this to implement @(see vl2014::*vl-1-bit-cmos*). Note: ESIM is no longer being actively developed. You
+will probably want to instead see its successor, @(see svex). ESIM is a bit-level ``back-end'' for carrying out hardware verification with
+ACL2. It consists of: There is a @(see esim-tutorial) that provides a hands-on guide for how to
+use @(see vl), @(see esim), and @(see gl) together to verify some simple
+hardware designs. Aside from the tutorial, ESIM is not very well documented. An early version
+of E is described somewhat in: Warren A. Hunt, Jr. and Sol Swords. Centaur technology media
+unit verification. Case study: Floating point addition. in Computer Aided
+Verification (CAV '09), June 2009. The ESIM tutorial walks through the verification of some very
+simple hardware designs using Centaur's ESIM books. These hardware designs are
+all contrived and are far simpler than real hardware. But this makes them easy
+to understand and verify. The ESIM tutorial is meant to be followed along with interactively. To
+begin, please go to this file: in your ACL2 books directory (sometimes called @(':dir :system')). Unfortunately E is not well documented. An early version of E is
-described in: Warren A. Hunt, Jr. and Sol Swords. Centaur technology media
-unit verification. Case study: Floating point addition. in Computer Aided
-Verification (CAV '09), June 2009. E modules are typically produced from Verilog designs using @(see vl). A full-adder is a one-bit adder that produces a sum and carry. We
+use the following definition: This is only a \"core.\" It doesn't quite correspond to an addition like
+@('assign {carry, sum} = a + b + cin') in Verilog because of X handling. See
+@(see vl-make-n-bit-plusminus) for the real module generator. We generate a gate-based module with the following interface: This is a basic ripple-carry adder formed by chaining together several
+full-adders; see @(see *vl-1-bit-adder-core*). This module does NOT correspond to a full addition in Verilog. It computes
+something akin to @('assign {cout, sum} = a + b + cin'), but it does not handle
+X's like Verilog does. See @(see vl-make-n-bit-plusminus) for the full
+addition and subtraction modules. We could probably make a leaner module by using a half-adder for the first
+bit (which does not have a carry-in) and by dropping the wires on the carry for
+the last bit, but we think it's best to keep things simple. Depending on the @('type'), which should be either
+@(':vl-binary-plus') or @(':vl-binary-minus'), we generate a gate-based
+addition or subtraction module that is semantically equivalent to: These modules capture the behavior specified by Verilog for addition and
+subtraction, including the requirement that if any bit of @('a') or @('b') is
+X/Z then the entire output is entirely X. We basically combine a simple ripple-carry adder with some additional
+X-detection and propagation circuitry. This makes our adder rather bulky and
+unlike the actual hardware that would probably be synthesized or
+implemented. We generate a gate-based module that is semantically equivalent
+to: Note that in @(see oprewrite) we canonicalize any @('<'), @('<='), and
+@('>') operators into the @('>=') form, so this module actually handles all
+inequality comparisons. The basic idea is to compute @('a + ~b + 1') and look at the carry chain.
+We do this by directly instantiating an adder. This might be somewhat
+inefficient since we really don't need to be computing the sum. On the other
+hand, there are really not very many comparison operators so we suspect we do
+not need to be particularly efficient, and hopefully in any AIG or S-Expression
+based representations the extra work will be automatically thrown away. Note that the Verilog semantics require that if @('a') or @('b') have any
+X/Z bits, then the answer should be X. This is true even when the X occurs in
+an insignificant place, e.g., @('1000 > 000x') is considered to be X even
+though no matter what the X digit is, we can see that the mathematical answer
+ought to be 1. (This behavior might be intended to give synthesis tools as
+much freedom as possible when implementing the operation.) This is a gate-based module that is semantically equivalent to: Since Verilog uses 2's complement as its representation of signed numbers,
+in the degenerate world of sign-bits we should have \"0 means 0 and 1 means
+-1\". So, counterintuitively, @('a >= b') holds except when @('a = 1')
+and @('b = 0'). Warning: The above is indeed the behavior implemented by NCVerilog.
+But Verilog-XL appears to be buggy and instead produces results that are
+consistent with an unsigned interpretation; see tests/test-scomp.v. Our actual module is: We generate a gate-based module that is semantically equivalent
+to: We just do the stupidest thing possible and do cases on the sign bit: The middle two cases would ordinarily fool an unsigned comparison, e.g., if
+A is positive and B is negative, then their leading bits are 0 and 1,
+respectively, so B \"looks bigger\" even though A is actually bigger. But
+ordinary unsigned comparisons work in the other cases. This module exactly implements the Verilog semantics for one-bit
+division and remainder. Dividing one-bit wires isn't a very useful thing to do. Division by zero is
+generally an error (in Verilog it produces X), and division by one is just a
+copy. But, if for some reason we do see a @('/') and @('%') operator being
+applied to single-bit wires, we still need to implement it somehow. The actual definition of this module is pretty weird and I don't think it's
+really worth studying. I basically just piled on X detection stuff until it
+matched the Verilog semantics. We generate the module @('VL_N_BIT_DIV_STEP') in terms of @(see
+primitives). This module carries out a single step in a simple restoring
+division algorithm. To understand this code you will need to understand restoring division. We
+sketch our implementation here, but to understand why it works you should see
+a textbook on computer arithmetic. Imagine a double-wide register, sometimes called AQ, whose halves we will
+treat independently as A and Q. Initially, A is zeroed and Q is set to the dividend. Then we take N
+steps (described below). After these steps, A will contain the remainder and Q
+will contain the quotient. In each step, we are going to: Note that, except for the shifting step, we don't touch Q besides its bottom
+bit. Since Q eventually becomes the quotient, what we're really doing here is
+computing the quotient one bit at a time. During the first iteration, we
+compute its most significant bit. During the next iteration, we compute its
+next most significant bit, and so on. The details of each step are as follows. After shifting AQ, we compare the
+divisor (which remains fixed throughout all iterations) against A. If the
+divisor \"fits\" into A, i.e., when @('divisor <= A'), we reduce A by the
+divisor and set the low bit of Q to 1. Otherwise, we leave A alone and set the
+low bit of Q to 0. How does @('VL_N_BIT_DIV_STEP') fit into this? It computes the next value
+of AQ, given the current value of AQ and the divisor. For example, in the 5-bit
+case, the general idea is something like this: The only twists are the following, basic optimizations: Note that the semantics of Verilog require that if any bit of the dividend
+or divisor is @('X') or @('Z'), then every bit of the output is @('X'). We do
+not deal with this requirement in the individual steps; it's part of the
+wrapper. We generate the module @('VL_N_BIT_DIV_CORE') which implements a
+basic restoring division algorithm in terms of @(see primitives). The core modules we produce here do not properly handle zero divides
+or detect X/Z values on the dividend and divisor. To see how we correct for
+these cases, see @(see vl-make-n-bit-div-rem). Aside from these special cases, the core module does produce the right
+answer by chaining together N division steps; for details about these steps and
+for an overview of the algorithm, see @(see vl-make-n-bit-div-step). As an example, here's what we generate in the four-bit case: We generate the module @('VL_N_BIT_DIV_REM') which exactly
+implements the Verilog semantics for division and remainder using @(see
+primitives). The actual division is carried out by a core module; see @(see
+vl-make-n-bit-div-core). But this core doesn't properly handle the cases where
+the divisor is zero, or when there is an X/Z value on either the dividend or
+the divisor. In these cases, the Verilog semantics say that the entire result
+must be X. This module just wraps up the core module with zero- and x-detection
+circuitry to achieve the desired behavior. We generate @('VL_N_BIT_UNSIGNED_DIV') for the given @('n'), which is
+written using @(see primitives) but is semantically equal to: This is a thin wrapper around @(see vl-make-n-bit-div-rem). It uses a naive
+N-step restoring division algorithm. We generate @('VL_N_BIT_UNSIGNED_REM') for the given @('n'), which is
+written using @(see primitives) but is semantically equal to: This is a thin wrapper around @(see vl-make-n-bit-div-rem). It uses a naive
+N-step restoring division algorithm. This module implements a one-bit multiply. Normally you would
+think of this as an @('and') gate, but the X-detection semantics are slightly
+different: a multiply must emit X whenever either argument is X or Z, whereas,
+e.g., @('X & 0') yields @('0'). The actual Verilog definition of this module is as follows. These gates
+precisely implement the Verilog semantics for @('o = a * b') when @('o'),
+@('a'), and @('b') are one-bit wide. We produce @('VL_N_BIT_MULT') for the given @('n'), which is
+written using @(see primitives) but is semantically equal to: We use a naive, sum-of-partial-products style multiplier. It computes
+N (shifted) partial products (using N gates apiece), then sums them together
+with @('n-1') instances of an N-bit wide adder circuit. The semantics of Verilog require that if any bit of @('a') or @('b') is
+@('X') or @('Z'), then every bit of the output is @('X'). We implement this
+explicitly, which adds a layer of X-detection around the core circuitry. The module @('VL_1_BIT_DYNAMIC_BITSELECT(out, in, idx)') implements
+@('assign out = in[idx]') in the (essentially degenerate) case that @('in') is
+only one-bit wide, and @('idx') is only one-bit wide: if @('idx') is zero, we
+return @('in'), otherwise the index is out-of-bounds and X is returned. @('VL_2_BIT_DYNAMIC_BITSELECT(out, in, idx)') conservatively
+approximates @('out = in[idx]') and is used to implement bit-selects where the
+index is not fixed. Its Verilog definition is as follows: The only place we this inexactly approximates the real Verilog semantics is
+when @('in') contains Z's. In Verilog, such a Z can be selected and returned,
+but in our module X is returned instead. Actually this seems good -- our
+behavior probably more closely corresponds to what real hardware would do for a
+dynamic bit-select, anyway. The XOR gates at the end are needed to obtain this X behavior. Without
+them, in cases where @('in[1] === in[0]'), we might return 0 or 1 even when idx
+is @('X'). This wouldn't be okay: the Verilog specification mandates that if
+any bit of @('idx') is @('X'), then @('X') is returned from the bit
+select. We construct @('VL_{2^N}_BIT_DYNAMIC_BITSELECT(out, in, idx)'), a
+conservative approximation of @('out = in[idx]') where @('in') has width
+@('2^N'). We generate this module inductively/recursively by using smaller
+selectors. As a basis, when N is 0 or 1, we use the 1-bit or 2-bit selectors that we
+pre-define; see @(see *vl-1-bit-dynamic-bitselect*) and @(see
+*vl-2-bit-dynamic-bitselect*). When @('N > 1'), let @('M') be @('2^N') and @('K') be @('2^(N-1)'). We
+define @('VL_M_BIT_DYNAMIC_BITSELECT') in Verilog as follows: We construct @('VL_N_BIT_DYNAMIC_BITSELECT(out, in, idx)'), a
+conservative approximation of @('out = in[idx]') where @('in') has width @('N')
+and @('idx') has the minimum width necessary to select from N bits. In
+particular, the width of @('idx') is the smallest number W such that N <=
+2^W. When @('N') is a power of 2, we simply construct the desired module using
+@(see vl-make-2^n-bit-dynamic-bitselect). Otherwise, the basic strategy is to instantiate the next biggest power of 2,
+and then pad @('in') with however many X bits are necessary to obtain an input
+of this larger size. As an example, we implement a 6-bit select by using an
+8-bit select as follows: We produce @('VL_N_BIT_DYNAMIC_BITSELECT_M(out, in, idx)'), a
+conservative approximation of @('out = in[idx]') where @('in') has width @('N')
+and @('idx') has width @('M'). Prerequisite: see @(see vl-make-n-bit-dynamic-bitselect), which can be used
+to introduce a module @('VL_N_BIT_DYNAMIC_BITSELECT(out, in, idx)'), where
+@('in') has width @('N') and @('idx') has width @('W') where W is the the
+smallest number W such that N <= 2^W. The problem with just using @('VL_N_BIT_DYNAMIC_BITSELECT') directly to
+synthesize expressions of the form @('in[idx]') is that, in practice, the width
+of @('idx') may be smaller or larger than W. When smaller, we need to pad it
+with zeros. When larger, we need to do additional out-of-bounds checking. We generate a gate-based module that is semantically equivalent
+to: These \"place shifters\" can be combined to form a full shifter that
+operates on O(log_2 n) muxes. We generate a gate-based module that is semantically equivalent
+to: We generate a gate-based module that is semantically equivalent
+to: These \"place shifters\" can be combined to form a full shifter that
+operates on O(log_2 n) muxes. We generate a gate-based module that is semantically equivalent
+to: The @('type') must be either @(':VL-AND'), @(':VL-OR'),
+@(':VL-XOR'), or @(':VL-XNOR'). Depending on the type, we generate a module
+that is written using @(see primitives) but is semantically equivalent to: For instance, if @('N') is 4 and type is OR, we actually write: We generate a module that is semantically equal to: We actually implement these modules using a list of @(see *vl-1-bit-assign*)
+instances, one for each bit. For instance, we implement our four-bit
+assignment module as: We generate a module that is written using gates and which is
+semantically equivalent to: For instance, for a four-bit negation module, instead of the assignment
+above we would have: The @('type') must be either @(':VL-UNARY-BITAND'),
+@(':VL-UNARY-BITOR'), or @(':VL-UNARY-XOR'). We don't deal with @('nand'),
+@('nor'), or @('xnor') because those should be handled by @(see oprewrite)
+instead. Depending on the type, we generate a module that is written using
+gates, and which is semantically equivalent to: For instance, for a 4-bit reduction xor, we actually generate: We generate a module that is written using gates and which is a
+conservative approximation of the following: We generate a \"regular\" or \"approx\" versions depending on @('approxp').
+Either version is a conservative, inexact approximations of the Verilog
+semantics of the conditional operator, because we cannot really preserve
+@('Z')s appropriately using gates. Perhaps the semantics of @('?:') are not
+exactly synthesizable? When @('approxp') is NIL, we try to model Verilog's semantics as closely as
+possible; in this case @('X ? 1 : 1') and @('X ? 0 : 0') produce 1 and 0,
+respectively. But when @('approxp') is T, we conservatively produce X in these
+cases, instead. For some years we implemented both kinds of muxes using gates, roughly as But we later (October 2013) realized a bizarre inconsistency in the way that
+approx-muxes handled things. In particular: Since our general intent is to model arbitrary mux implementations with
+approx muxes, this optimistic treatment for 0 seems suspicious or incorrect.
+We ultimately decided to adopt both kinds of muxes as new VL @(see primitives)
+rather than implement them with gates. See @(see *vl-1-bit-approx-mux*) and
+@(see *vl-1-bit-mux*) for details. You might expect that it's better to set @('approxp') to NIL and get the
+behavior that is closest to Verilog. But the more conservative version may
+generally produce smaller AIGs since the output doesn't depend upon the inputs
+when the select is X. So, we generally set @('approxp') to T. We generate a module using @(see *vl-1-bit-zmux*) primitives that
+is semantically equivalent to: BOZO is it really equivalent? It seems like it might be
+conservative. These modules are used to implement conditional (a.k.a. the @('?:') or
+ternary) operators whose last argument is @('Z'). Note that in @(see
+oprewrite), we canonicalize @('sel ? Z : a') to @('~sel ? a : Z'), so this
+actually handles both cases. We generate a module that is written using gates and which is
+semantically equivalent to: We basically just instantiate @(see *vl-1-bit-ceq*) N times and then
+reduction-and the results. We generate a module that is semantically equal to: We actually implement these modules using a list of @(see *vl-1-bit-assign*)
+instances, one for each bit. For instance, we implement our four-bit X generator
+like this: We now introduce routines to transform post-@(see split)
+assignments into occurrences of new, primitive modules. We expect to see assignments of the form: where @('EXPR') consists either of a single operand or of a single operation
+applied to operands. We expect to not encounter certain operators such as
+@('==') and @('||') which are handled by @(see oprewrite). We typically replace each assignment with an instance of a newly-generated
+module. For instance, if our operation is @('a + b'), where the operation is
+being done in @('n') bits, we introduce a new @('VL_N_BIT_PLUS') module, and
+replace the assignment with an instance of this module. Each of our @('-occform') functions takes as arguments: And returns @('(mv new-warnings new-modules new-modinsts new-nf)'),
+where: Typically @('new-assigns') will be empty on success, and will just be
+@('(list x)') on failure. See @(see vl-atom-welltyped-p) and note that our internal
+representation of sized expressions leaves zero/sign extensions of identifiers
+implicit. This is unfortunate because it means that, e.g., if we have
+something like: And we translate it into: Then the sizes of the arguments appear to be wrong in the pretty-printed
+representation of the output. We would rather produce something like: So that the extensions are explicit. It's relatively easy to do this, now,
+because since we're going to give this operands as an argument to a submodule,
+its signedness is no longer relevant. @('x') should have one of the following forms: @('x') should have the form @('assign lhs = rhs'), where @('rhs')
+is a @('x') should have one of the following forms: @('x') should have one of the following forms: @('x') should have the form @('assign lhs = a ? b : c;'). As a special case, @('sel ? a : n'bZ') is transformed into a zmux, and in
+@(see oprewrite) we rewrite @('sel ? n'bZ : a') into @('sel ? a : n'bZ') so
+this covers both cases. Otherwise, we create an ordinary mux. Advanced note. Ordinarily, we produce an approx mux as described in the
+documentation for @(see vl-make-n-bit-mux). An advanced user can choose to use
+the non-approx version by adding the attribute @('VL_X_SELECT') to the
+conditional operator. An example of the syntax for doing this is as
+follows: If this attribute is provided, a non-approx mux will be created instead.
+This may be necessary if you want to reason about @('out') even when @('sel')
+is @('X') or @('Z'). @('x') should have one of these forms: This is only for dynamic bitselects, not static selects like
+@('foo[3]'). See @(see vl-assign-occform): any sliceable expressions get
+handled by @(see vl-plain-occform), and any static bitselects are
+sliceable. @('x') should have the form: @('assign lhs = (a === b);') We don't support certain operators like division and modulus yet.
+It should be straightforward to add new operators: just figure out how to
+generate a gate-based conservative approximation, and then plug it in
+below. We generate a gate-based module with the following signature: We set @('out') to X whenever any bit of @('in') is X or Z. Otherwise, we
+set @('out') to 0. This module is useful because many of Verilog's arithmetic
+expressions (compares, additions, subtractions, etc.) require that if any input
+bit is X or Z, then the entire output should be X. The basic idea is to use
+@('VL_N_BIT_XDETECT') to see if any input bit is X or Z, then XOR the output
+bit with every bit of the answer from a compare, addition, subtraction, etc.
+If the X-DET bit is zero, then XOR'ing it with the answer just yields the
+original answer. But if it is X, then the resulting bits are all X. We generate a module that uses gates and is semantically equivalent
+to: In other words, we xor @('a') with each bit of @('b') and return the xor'ed
+vector. We generate a gate-based module that has the following interface: This propagator module can be understood as: if any bit of @('a') or @('b')
+is X/Z, then @('out') will be all X bits. Otherwise @('out') is just a copy of
+@('ans'). Examples: If the wire name isn't of an acceptable form, an error message is returned
as the first return value.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
"
+
+ :ops (:vl-binary-bitand :vl-binary-bitor :vl-binary-xor :vl-binary-xnor)
+
+ :body
+ (b* (((vl-assign x) x)
+ (op (vl-nonatom->op x.expr))
+ (arg1 (first (vl-nonatom->args x.expr)))
+ (arg2 (second (vl-nonatom->args x.expr)))
+ (width (vl-expr->finalwidth x.expr))
+ (type (vl-expr->finaltype x.expr))
+
+ ((unless (and (posp width)
+ (equal width (vl-expr->finalwidth x.lvalue))
+ (equal width (vl-expr->finalwidth arg1))
+ (equal width (vl-expr->finalwidth arg2))
+ type
+ (vl-expr->finaltype x.lvalue)
+ (eq type (vl-expr->finaltype arg1))
+ (eq type (vl-expr->finaltype arg2))))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths/types in assignment of binary op."
+ :args (list x))))
+
+ ((mv warnings arg1) (vl-occform-argfix arg1 mod ialist warnings))
+ ((mv warnings arg2) (vl-occform-argfix arg2 mod ialist warnings))
+
+ (gtype (case op
+ (:vl-binary-bitand :vl-and)
+ (:vl-binary-bitor :vl-or)
+ (:vl-binary-xor :vl-xor)
+ (:vl-binary-xnor :vl-xnor)))
+ (basename (case op
+ (:vl-binary-bitand "vl_band")
+ (:vl-binary-bitor "vl_bor")
+ (:vl-binary-xor "vl_bxor")
+ (:vl-binary-xnor "vl_bxnor")))
+ ((mv instname nf) (vl-namefactory-indexed-name basename nf))
+ (mods (vl-make-n-bit-binary-op gtype (vl-expr->finalwidth x.lvalue)))
+ (modinst (vl-simple-instantiate (car mods) instname
+ (list x.lvalue arg1 arg2)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+
+(def-vl-occform vl-unary-not-occform
+ :short "Transform @('assign lhs = ~a') into occurrences."
+ :ops (:vl-unary-bitnot)
+ :body
+ (b* (((vl-assign x) x)
+ (arg1 (first (vl-nonatom->args x.expr)))
+ (width (vl-expr->finalwidth x.expr))
+ (type (vl-expr->finaltype x.expr))
+
+ ((unless (and (posp width)
+ (equal width (vl-expr->finalwidth x.lvalue))
+ (equal width (vl-expr->finalwidth arg1))
+ type
+ (vl-expr->finaltype x.lvalue)
+ (eq type (vl-expr->finaltype arg1))))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths/types in assignment of unary bitwise not."
+ :args (list x))))
+
+ ((mv warnings arg1) (vl-occform-argfix arg1 mod ialist warnings))
+
+ ((mv instname nf) (vl-namefactory-indexed-name "vl_unot" nf))
+ (mods (vl-make-n-bit-not width))
+ (modinst (vl-simple-instantiate (car mods) instname
+ (list x.lvalue arg1)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+
+(def-vl-occform vl-plain-occform
+ :short "Transform a plain assignment into occurrences."
+
+ :long "
+
"
+
+ :ops (:vl-unary-bitand :vl-unary-bitor :vl-unary-xor)
+ :body
+ (b* (((vl-assign x) x)
+ (op (vl-nonatom->op x.expr))
+ (arg (first (vl-nonatom->args x.expr)))
+
+ ((unless (and (equal (vl-expr->finalwidth x.expr) 1)
+ (equal (vl-expr->finaltype x.expr) :vl-unsigned)
+ (equal (vl-expr->finalwidth x.lvalue) 1)
+ (vl-expr->finaltype x.lvalue)
+ (posp (vl-expr->finalwidth arg))
+ (vl-expr->finaltype arg)))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths/types for assignment of reduction op."
+ :args (list x))))
+
+ ((mv warnings arg) (vl-occform-argfix arg mod ialist warnings))
+
+ (basename (case op
+ (:vl-unary-bitand "vl_uand")
+ (:vl-unary-bitor "vl_uor")
+ (:vl-unary-xor "vl_uxor")))
+ ((mv instname nf) (vl-namefactory-indexed-name basename nf))
+ (mods (vl-make-n-bit-reduction-op op (vl-expr->finalwidth arg)))
+ (modinst (vl-simple-instantiate (car mods) instname
+ (list x.lvalue arg)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+
+(def-vl-occform vl-plusminus-occform
+ :short "Transform an assignment of a addition/subtraction into occurrences."
+
+ :long "
+
"
+
+ :ops (:vl-binary-plus :vl-binary-minus)
+ :body
+ (b* (((vl-assign x) x)
+ (op (vl-nonatom->op x.expr))
+ (arg1 (first (vl-nonatom->args x.expr)))
+ (arg2 (second (vl-nonatom->args x.expr)))
+
+ (width (vl-expr->finalwidth x.expr))
+ (type (vl-expr->finaltype x.expr))
+
+ ((unless (and (posp width)
+ (equal width (vl-expr->finalwidth x.lvalue))
+ (equal width (vl-expr->finalwidth arg1))
+ (equal width (vl-expr->finalwidth arg2))
+ type
+ (vl-expr->finaltype x.lvalue)
+ (eq type (vl-expr->finaltype arg1))
+ (eq type (vl-expr->finaltype arg2))))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths/types in assignment of addition/subtraction."
+ :args (list x))))
+
+ ((mv warnings arg1) (vl-occform-argfix arg1 mod ialist warnings))
+ ((mv warnings arg2) (vl-occform-argfix arg2 mod ialist warnings))
+
+ (basename (case op
+ (:vl-binary-plus "vl_plus")
+ (:vl-binary-minus "vl_minus")))
+
+ ((mv instname nf) (vl-namefactory-indexed-name basename nf))
+ (mods (vl-make-n-bit-plusminus op width))
+ (modinst (vl-simple-instantiate (car mods) instname
+ (list x.lvalue arg1 arg2)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+
+(def-vl-occform vl-mult-occform
+ :short "Transform @('assign lhs = a * b') into occurrences."
+ :ops (:vl-binary-times)
+ :body
+ (b* (((vl-assign x) x)
+ (arg1 (first (vl-nonatom->args x.expr)))
+ (arg2 (second (vl-nonatom->args x.expr)))
+ (width (vl-expr->finalwidth x.expr))
+ (type (vl-expr->finaltype x.expr))
+
+ ((unless (and (posp width)
+ (equal width (vl-expr->finalwidth x.lvalue))
+ (equal width (vl-expr->finalwidth arg1))
+ (equal width (vl-expr->finalwidth arg2))
+ type
+ (vl-expr->finaltype x.lvalue)
+ (eq type (vl-expr->finaltype arg1))
+ (eq type (vl-expr->finaltype arg2))))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths/types in multiplication."
+ :args (list x))))
+
+ ((mv warnings arg1) (vl-occform-argfix arg1 mod ialist warnings))
+ ((mv warnings arg2) (vl-occform-argfix arg2 mod ialist warnings))
+
+ (basename "vl_mult")
+ ((mv instname nf) (vl-namefactory-indexed-name basename nf))
+ (mods (vl-make-n-bit-mult width))
+ (modinst (vl-simple-instantiate (car mods) instname
+ (list x.lvalue arg1 arg2)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+
+(def-vl-occform vl-div-occform
+ :short "Transform @('assign lhs = a / b') into occurrences."
+ :ops (:vl-binary-div)
+ :body
+ (b* (((vl-assign x) x)
+ (arg1 (first (vl-nonatom->args x.expr)))
+ (arg2 (second (vl-nonatom->args x.expr)))
+ (width (vl-expr->finalwidth x.expr))
+ (type (vl-expr->finaltype x.expr))
+
+ ((unless (eq type :vl-unsigned))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-warn-signed-div
+ :msg "~a0: signed divide is not implemented yet"
+ :args (list x))))
+
+ ((unless (and (posp width)
+ (equal width (vl-expr->finalwidth x.lvalue))
+ (equal width (vl-expr->finalwidth arg1))
+ (equal width (vl-expr->finalwidth arg2))
+ type
+ (vl-expr->finaltype x.lvalue)
+ (eq type (vl-expr->finaltype arg1))
+ (eq type (vl-expr->finaltype arg2))))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths/types in divide."
+ :args (list x))))
+
+ ((mv warnings arg1) (vl-occform-argfix arg1 mod ialist warnings))
+ ((mv warnings arg2) (vl-occform-argfix arg2 mod ialist warnings))
+
+ (basename "vl_div")
+ ((mv instname nf) (vl-namefactory-indexed-name basename nf))
+ (mods (vl-make-n-bit-unsigned-div width))
+ (modinst (vl-simple-instantiate (car mods) instname
+ (list x.lvalue arg1 arg2)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+(def-vl-occform vl-rem-occform
+ :short "Transform @('assign lhs = a % b') into occurrences."
+ :ops (:vl-binary-rem)
+ :body
+ (b* (((vl-assign x) x)
+ (arg1 (first (vl-nonatom->args x.expr)))
+ (arg2 (second (vl-nonatom->args x.expr)))
+ (width (vl-expr->finalwidth x.expr))
+ (type (vl-expr->finaltype x.expr))
+
+ ((unless (eq type :vl-unsigned))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-warn-signed-rem
+ :msg "~a0: signed remainder (i.e., modulus, %) is not implemented yet"
+ :args (list x))))
+
+ ((unless (and (posp width)
+ (equal width (vl-expr->finalwidth x.lvalue))
+ (equal width (vl-expr->finalwidth arg1))
+ (equal width (vl-expr->finalwidth arg2))
+ type
+ (vl-expr->finaltype x.lvalue)
+ (eq type (vl-expr->finaltype arg1))
+ (eq type (vl-expr->finaltype arg2))))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths/types in remainder (i.e., modulus, %)."
+ :args (list x))))
+
+ ((mv warnings arg1) (vl-occform-argfix arg1 mod ialist warnings))
+ ((mv warnings arg2) (vl-occform-argfix arg2 mod ialist warnings))
+
+ (basename "vl_rem")
+ ((mv instname nf) (vl-namefactory-indexed-name basename nf))
+ (mods (vl-make-n-bit-unsigned-rem width))
+ (modinst (vl-simple-instantiate (car mods) instname
+ (list x.lvalue arg1 arg2)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+
+(def-vl-occform vl-gte-occform
+ :short "Transform @('assign lhs = a > b') into occurrences."
+ :ops (:vl-binary-gte)
+ :body
+ (b* (((vl-assign x) x)
+ (arg1 (first (vl-nonatom->args x.expr)))
+ (arg2 (second (vl-nonatom->args x.expr)))
+ (arg1width (vl-expr->finalwidth arg1))
+ (arg1type (vl-expr->finaltype arg1))
+
+ ((unless (and (equal (vl-expr->finalwidth x.expr) 1)
+ (equal (vl-expr->finaltype x.expr) :vl-unsigned)
+ (equal (vl-expr->finalwidth x.lvalue) 1)
+ (vl-expr->finaltype x.lvalue)
+ arg1type
+ (posp arg1width)
+ (equal arg1type (vl-expr->finaltype arg2))
+ (equal arg1width (vl-expr->finalwidth arg2))))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths/types in assignment of >= operation."
+ :args (list x))))
+
+ (warnings
+ (if (eq arg1type :vl-unsigned)
+ warnings
+ (warn :type :vl-warn-signed-comparison
+ :msg "~a0: found a signed comparison expression. This is ~
+ dangerous because whereas NCVerilog properly carries ~
+ out a comparison between 2's complement numbers, ~
+ Verilog-XL incorrectly uses an unsigned comparison. ~
+ We follow the Verilog-2005 standard and mimick ~
+ NCVerilog, but to ensure compatibility across Verilog ~
+ implementations, you should probably not use signed ~
+ comparisons. Some typical causes of signedness are ~
+ plain decimal numbers like 17, and the use of integer ~
+ variables instead of regs."
+ :args (list x))))
+
+ ((mv warnings arg1) (vl-occform-argfix arg1 mod ialist warnings))
+ ((mv warnings arg2) (vl-occform-argfix arg2 mod ialist warnings))
+
+ ((mv instname nf) (vl-namefactory-indexed-name "vl_gte" nf))
+ (mods (if (eq arg1type :vl-unsigned)
+ (vl-make-n-bit-unsigned-gte arg1width)
+ (vl-make-n-bit-signed-gte arg1width)))
+ (modinst (vl-simple-instantiate (car mods) instname
+ (list x.lvalue arg1 arg2)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+
+(def-vl-occform vl-mux-occform
+ :short "Transform an assignment of a conditional expression into occurrences."
+
+ :long "
+
"
+
+ :ops (:vl-binary-shl :vl-binary-shr)
+ :body
+ (b* (((vl-assign x) x)
+ (op (vl-nonatom->op x.expr))
+ (width (vl-expr->finalwidth x.expr))
+ (type (vl-expr->finaltype x.expr))
+
+ (arg1 (first (vl-nonatom->args x.expr)))
+ (arg2 (second (vl-nonatom->args x.expr)))
+
+ ((unless (and (posp width)
+ (equal width (vl-expr->finalwidth x.lvalue))
+ (equal width (vl-expr->finalwidth arg1))
+ (posp (vl-expr->finalwidth arg2))
+ type
+ (vl-expr->finaltype x.lvalue)
+ (eq type (vl-expr->finaltype arg1))
+ (vl-expr->finaltype arg2)))
+ (occform-return
+ :assigns (list x)
+ :warnings (fatal :type :vl-programming-error
+ :msg "~a0: bad widths in assignment of shift."
+ :args (list x))))
+
+ ((mv warnings arg1) (vl-occform-argfix arg1 mod ialist warnings))
+ ((mv warnings arg2) (vl-occform-argfix arg2 mod ialist warnings))
+
+ ;; Make a module and instantiate it.
+ (basename (case op
+ (:vl-binary-shl "vl_shl")
+ (:vl-binary-shr "vl_shr")))
+ ((mv iname nf) (vl-namefactory-indexed-name basename nf))
+ (mods (case op
+ (:vl-binary-shl (vl-make-n-bit-shl-by-m-bits width (vl-expr->finalwidth arg2)))
+ (:vl-binary-shr (vl-make-n-bit-shr-by-m-bits width (vl-expr->finalwidth arg2)))))
+ (modinst (vl-simple-instantiate (car mods) iname
+ (list x.lvalue arg1 arg2)
+ :loc x.loc)))
+ (occform-return :mods mods
+ :modinsts (list modinst))))
+
+
+(def-vl-occform vl-bitselect-occform
+ :short "Transform @('assign lhs = foo[i]') into occurrences (dynamic
+bitselects only!)."
+
+ :long "
Currently the most thorough example of such a proof can be found in the book - @('centaur/tutorial/boothmul.lisp'). This example highlights two ways of - performing a compositional equivalence proof:
+Currently the most thorough example of such a proof can be found in the + book @('centaur/esim/tutorial/boothmul.lisp'). This example highlights two + ways of performing a compositional equivalence proof:
Translation objects are most commonly produced by the @(see +defmodules) command.
") + + +(define vl-translation-has-module ((modname stringp) + (x vl-translation-p)) + :parents (vl-translation-p) + :short "Check whether a module was successfully translated." + + :long "The @('modname') should be the desired module's name as a string, +e.g., @('\"fadd\"'). If the module's name includes parameters, you will need +to say which version you want, e.g., @('\"adder$width=4\"').
+ +We return @('t') only when the module was successfully translated with no +\"fatal\" warnings. (See @(see vl-translation-p); failed modules are found in +the translation's @('failmods') field, whereas successful modules are kept in +the @('mods') field.)
" + + (if (vl-find-module modname (vl-design->mods (vl-translation->good x))) + t + nil)) + +(define vl-translation-get-esim ((modname stringp) + (x vl-translation-p)) + :returns (e-mod) + :guard (vl-translation-has-module modname x) + :parents (vl-translation-p) + :short "Get an E Module for a successfully translated module." + :prepwork ((local (in-theory (enable vl-translation-has-module)))) + + (b* ((mod (vl-find-module modname + (vl-design->mods + (vl-translation->good x)))) + (esim (vl-module->esim mod)) + ((unless esim) + (raise "Module ~x0 has no esim?" modname))) + esim)) diff -Nru acl2-7.0/books/centaur/esim/tutorial/acl2-customization.lsp acl2-7.1/books/centaur/esim/tutorial/acl2-customization.lsp --- acl2-7.0/books/centaur/esim/tutorial/acl2-customization.lsp 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/tutorial/acl2-customization.lsp 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1 @@ +(set-deferred-ttag-notes t state) diff -Nru acl2-7.0/books/centaur/esim/tutorial/alu16-book.lisp acl2-7.1/books/centaur/esim/tutorial/alu16-book.lisp --- acl2-7.0/books/centaur/esim/tutorial/alu16-book.lisp 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/tutorial/alu16-book.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1,163 @@ +; Centaur Hardware Verification Tutorial for ESIM/VL2014 +; Copyright (C) 2008-2015 Centaur Technology +; +; Contact: +; Centaur Technology Formal Verification Group +; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA. +; http://www.centtech.com/ +; +; License: (An MIT/X11-style license) +; +; Permission is hereby granted, free of charge, to any person obtaining a +; copy of this software and associated documentation files (the "Software"), +; to deal in the Software without restriction, including without limitation +; the rights to use, copy, modify, merge, publish, distribute, sublicense, +; and/or sell copies of the Software, and to permit persons to whom the +; Software is furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +; DEALINGS IN THE SOFTWARE. +; +; Original author: Jared DavisThis is a demo of the defstv documentation stuff. You can see what +it generates by going to the counter-run page in the XDOC manual; see +centaur/README.html if you don't know where to look.
") + + +; Some basic examples of running the counter. + +#|| + +(stv-run (counter-run) + '((init . 0) ; Never reset, always increment, start counter off at 0. + (r0 . 0) + (r1 . 0) ; We see that it properly counts up, i.e., the outputs + (r2 . 0) ; are 0, 1, 2, 3, and 4. + (r3 . 0) + (r4 . 0) + (i0 . 1) + (i1 . 1) + (i2 . 1) + (i3 . 1) + (i4 . 1))) + +(stv-run (counter-run) + '((init . 8) ; Same as above (never reset, always increment) except we + (r0 . 0) ; start at 8 instead of 0. + (r1 . 0) + (r2 . 0) ; We see the counter go up to 9 and then wrap back down + (r3 . 0) ; to zero. + (r4 . 0) + (i0 . 1) + (i1 . 1) + (i2 . 1) + (i3 . 1) + (i4 . 1))) + +(stv-run (counter-run) ; This time we won't bother to initialize the counter, so + '((r0 . 1) ; its starting value is X. But, we assert reset for cycle + (r1 . 0) ; zero, and then leave it deasserted for the remainder of + (r2 . 0) ; the simulation. + (r3 . 0) + (r4 . 0) ; Since we didn't initialize the counter, we see that in + (i1 . 1) ; cycle 0 it is X. But then, we see that reset clears it + (i2 . 1) ; to zero, and we start counting up as normal. + (i3 . 1) + (i4 . 1))) + +(stv-run (counter-run) + '((r0 . 0) ; Here we never assert reset and always increment. + (r1 . 0) ; But we don't initialize the counter so we just get X. + (r2 . 0) + (r3 . 0) + (r4 . 0) + (i0 . 1) + (i1 . 1) + (i2 . 1) + (i3 . 1) + (i4 . 1))) + +||# + + +; Lets do some proofs. I think of this as, "output 4 is correct, assuming +; there are no resets." + +(def-gl-thm counter-output4-correct-unless-reset + :hyp (and (counter-run-autohyps) + (< init 10) ;; note that this hyp is necessary! + (= r0 0) + (= r1 0) + (= r2 0) + (= r3 0) + (= r4 0)) + :concl (b* ((outs (stv-run (counter-run) (counter-run-autoins))) + ;; Fancy B* binder that extracts o4 from outs. + ((assocs o4) outs)) + (equal o4 + (mod (+ init i0 i1 i2 i3) + 10))) + :g-bindings (counter-run-autobinds)) + + +; BOZO this is as much of a tutorial as there is, so far. + diff -Nru acl2-7.0/books/centaur/esim/tutorial/counter.v acl2-7.1/books/centaur/esim/tutorial/counter.v --- acl2-7.0/books/centaur/esim/tutorial/counter.v 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/tutorial/counter.v 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1,66 @@ +// Centaur Hardware Verification Tutorial for ESIM/VL2014 +// Copyright (C) 2008-2015 Centaur Technology +// +// Contact: +// Centaur Technology Formal Verification Group +// 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA. +// http://www.centtech.com/ +// +// License: (An MIT/X11-style license) +// +// Permission is hereby granted, free of charge, to any person obtaining a +// copy of this software and associated documentation files (the "Software"), +// to deal in the Software without restriction, including without limitation +// the rights to use, copy, modify, merge, publish, distribute, sublicense, +// and/or sell copies of the Software, and to permit persons to whom the +// Software is furnished to do so, subject to the following conditions: +// +// The above copyright notice and this permission notice shall be included in +// all copies or substantial portions of the Software. +// +// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +// IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +// FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +// THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +// LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +// FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +// DEALINGS IN THE SOFTWARE. +// +// Original author: Jared DavisWe want every wire in our E modules to have at most one driver, but +the list of occurrences we get from @(see vl-modinstlist-to-eoccs) could easily +have multiple occurrences all driving the same wire. We now introduce a +transform to simplify a list of E occurrences, eliminating multiply driven +wires by inserting explicit resolution modules.
+ +Note: In this transform we assume that the module's primary inputs +are not driven by any occurrence. This is something we explicitly check for in +@(see vl-module-make-esim); see the warning about @(':vl-backflow') there.
+ +Given this assumption, we basically need to do three things:
+ +The top-level function is @(see vl-add-res-modules), and it just stitches +these steps together.
") + +(local (xdoc::set-default-parents resolving-multiple-drivers)) + + +(defalist vl-res-sigma-p (x) + :key (vl-emodwire-p x) + :val (vl-emodwirelist-p x) + :keyp-of-nil nil + :valp-of-nil t + :parents (resolving-multiple-drivers) + :short "An alist that records the fresh wires we introduce for multiply +driven wires." + + :long "The basic idea is that if @('W') is a multiply-driven wire, and we +are going to rewrite the occurrences so that they drive @('W_1'), @('W_2'), +... instead of @('W'), then this alist should bind
+ +@({ + W --> (W_1 W_2 ...) +}) + +In short, this alist will end up saying which wires need to be resolved +together to drive @('W'); see @(see vl-make-res-occs).
") + + +(defsection vl-res-rewrite-pat + :parents (vl-res-rewrite-occs) + :short "Rewrite an output pattern to eliminate multiple drivers." + + :long "Signature: @(call vl-res-rewrite-pat) returns @('(mv pat' +idx' sigma')').
+ +@('PAT') should be the output pattern for some occurrence, e.g., @('(gpl :o +occ)'). The other arguments are as in @(see vl-res-rewrite-occs).
+ +We replace any multiply driven wires with new, freshly generated names, and +update @('IDX') and @('SIGMA') appropriately to account for the newly generated +names.
" + + (defund vl-res-rewrite-pat (pat mds idx sigma) + "Returns (MV PAT' IDX' SIGMA')" + (declare (xargs :guard (and (natp idx) + (vl-emodwirelist-p (alist-keys mds)) + (vl-res-sigma-p sigma)) + :verify-guards nil)) + (b* ((idx (lnfix idx)) + + ((when (not pat)) + (mv pat idx sigma)) + + ((when (atom pat)) + (b* ((look (hons-get pat mds)) + ((unless look) + ;; Not a multiply driven wire, so don't rewrite it. + (mv pat idx sigma)) + ;; Multiply driven, so generate a fresh name, bump up the name + ;; index, and add the newly generated wire to sigma. + (idx (+ 1 idx)) + (fresh (make-vl-emodwire :basename "vl_res" :index idx)) + (prev (cdr (hons-get pat sigma))) + (sigma (hons-acons pat (cons fresh prev) sigma))) + (mv fresh idx sigma))) + + ((mv car idx sigma) (vl-res-rewrite-pat (car pat) mds idx sigma)) + ((mv cdr idx sigma) (vl-res-rewrite-pat (cdr pat) mds idx sigma))) + (mv (cons car cdr) idx sigma))) + + (local (in-theory (enable vl-res-rewrite-pat))) + + (defmvtypes vl-res-rewrite-pat (nil natp nil)) + + (defthm vl-res-sigma-p-of-vl-res-rewrite-pat + (implies (and (vl-emodwirelist-p (alist-keys mds)) + (vl-res-sigma-p sigma)) + (vl-res-sigma-p (mv-nth 2 (vl-res-rewrite-pat pat mds idx sigma))))) + + (verify-guards vl-res-rewrite-pat) + + (local (defthm l0 + (implies (maybe-natp idx) + (iff (vl-emodwire "vl_res" idx) + t)) + :hints(("Goal" + :in-theory (disable vl-emodwire-p-of-vl-emodwire) + :use ((:instance vl-emodwire-p-of-vl-emodwire + (basename "vl_res") + (index idx))))))) + + (defthm similar-patternsp-of-vl-res-rewrite-pat + (similar-patternsp (mv-nth 0 (vl-res-rewrite-pat pat mds idx sigma)) + pat))) + + +(defsection vl-res-rewrite-occ + :parents (vl-res-rewrite-occs) + :short "Rewrite an occurrence to eliminate multiple drivers." + + (defund vl-res-rewrite-occ (occ mds idx sigma) + "Returns (MV OCC' IDX' SIGMA')" + (declare (xargs :guard (and (natp idx) + (vl-emodwirelist-p (alist-keys mds)) + (vl-res-sigma-p sigma)))) + (b* ((o (gpl :o occ)) + ((mv o idx sigma) (vl-res-rewrite-pat o mds idx sigma)) + (occ (acl2::chgpl :o o occ))) + (mv occ idx sigma))) + + (local (in-theory (enable vl-res-rewrite-occ))) + + (defmvtypes vl-res-rewrite-occ (nil natp nil)) + + (defthm vl-res-sigma-p-of-vl-res-rewrite-occ + (implies (and (vl-emodwirelist-p (alist-keys mds)) + (vl-res-sigma-p sigma)) + (vl-res-sigma-p (mv-nth 2 (vl-res-rewrite-occ occ mds idx sigma))))) + + (defthm good-esim-occp-of-vl-res-rewrite-occ + (implies (good-esim-occp occ) + (good-esim-occp (mv-nth 0 (vl-res-rewrite-occ occ mds idx sigma)))) + :hints(("Goal" :in-theory (enable good-esim-occp))))) + + +(defsection vl-res-rewrite-occs + :parents (resolving-multiple-drivers) + :short "Rewrite occurrences to drive new, fresh wires instead of multiply +driven wires." + + :long "Signature: @(call vl-res-rewrite-occs) returns @('(mv occs' +idx' sigma')').
+ +@(call vl-make-res-sexpr) generates a
Note that the RES operation is commutative and associative, so any nest of +RES operations is equivalent. So, we just resolve the arguments in a +straightforward, right-associative manner.
" + + #!ACL2 + (local (defthm 4v-res-commutes ;; just to show it commutes + (equal (4v-res a b) + (4v-res b a)))) + + #!ACL2 + (local (defthm 4v-res-is-associative ;; just to show it is associative + (equal (4v-res (4v-res a b) c) + (4v-res a (4v-res b c))))) + + (defund vl-make-res-sexpr (args) + ;; Builds the 4v-sexpr for (RES ARG1 (RES ARG2 (RES ... ARGN))). + (declare (xargs :guard (vl-emodwirelist-p args))) + (cond ((atom args) + ;; We'll allow no arguments -- resolving nothing gives you Z. + acl2::*4vz-sexpr*) + ((atom (cdr args)) + ;; Resolving a single argument just gives you that arg. + (car args)) + (t + ;; Resolving anything else gives you a nest of RESes. + (acl2::hons-list 'acl2::res (car args) + (vl-make-res-sexpr (cdr args)))))) + + + (local (defthm l0 + ;; The vl-emodwirelist-p hyp here ensures that the args are non-nil + ;; atoms. The 4v-sexpr-vars function could get confused if NIL was + ;; permitted, for instance. + (implies (vl-emodwirelist-p args) + (equal (set::in a (acl2::4v-sexpr-vars (vl-make-res-sexpr args))) + (if (member-equal a args) + t + nil))) + :hints(("Goal" + :in-theory (enable vl-make-res-sexpr + acl2::4v-sexpr-vars) + :induct (vl-make-res-sexpr args))))) + + (defthm 4v-sexpr-vars-of-vl-make-res-sexpr + (implies (force (vl-emodwirelist-p args)) + (equal (acl2::4v-sexpr-vars (vl-make-res-sexpr args)) + (set::mergesort args))) + :hints((set-reasoning)))) + + + +(defsection vl-make-n-bit-res-module + :parents (vl-make-res-occs) + :short "Make an E module to resolve together N inputs into a single output." + + :long "@(call vl-make-n-bit-res-module) constructs an E module. This +models what happens when we drive the same wire with multiple values. There's +no notion of strengths here; the wires all have to agree on their value (or be +floating) for a good result to come out.
+ +Note that this works even for N=0 (in which case it just always emits Z) and +for N=1 (in which case it acts like an ordinary assignment).
" + + (defund vl-make-n-bit-res-module (n) + (declare (xargs :guard (natp n))) + (b* ((name (vl-starname (cat "VL_" (natstr n) "_BIT_RES"))) + (ins (and (posp n) (vl-emodwires-from-high-to-low "A" (- n 1) 0))) + (out (vl-plain-wire-name "O")) + ;; Note: in-pat and out-pat here must agree with + ;; vl-make-resolution-occ below. + (in-pat (and (posp n) (list ins))) + (out-pat (list (list out))) + (out-alist (list (cons out (vl-make-res-sexpr ins)))) + (x (list :out out-alist))) + (list :n name :i in-pat :o out-pat :x x))) + + ;; It's probably silly to memoize this, but it may avoid some consing... + (memoize 'vl-make-n-bit-res-module) + + (local (in-theory (enable vl-make-n-bit-res-module))) + + (local (in-theory (disable acl2::hons-subset))) + + (local (defthm c0 + (implies (and (atom-listp x) + (not (member nil x))) + (equal (pat-flatten1 x) + x)) + :hints(("Goal" :in-theory (enable atom-listp))))) + + (local (defthm c1 + (implies (vl-emodwirelist-p x) + (equal (atom-listp x) + (true-listp x))) + :hints(("Goal" :induct (len x))))) + + (local (defthm c2 + (implies (vl-emodwirelist-p x) + (not (member nil x))))) + + (defthm good-esim-primitivep-of-vl-make-n-bit-res-module + (implies (natp n) + (good-esim-primitivep (vl-make-n-bit-res-module n))) + :hints(("Goal" :in-theory (enable good-esim-primitivep)))) + + (local (defthm d0 + (implies (member-equal a x) + (member-equal (vl-emodwire->basename a) (vl-emodwirelist->basenames x))) + :hints(("Goal" :induct (len x))))) + + (local (defthm d1 + (implies (not (equal (vl-emodwire->basename a) (string-fix name))) + (not (member-equal a (vl-emodwires-from-high-to-low name high low)))) + :hints(("Goal" + :in-theory (disable d0) + :use ((:instance d0 + (a a) + (x (vl-emodwires-from-high-to-low name high low)))))))) + + (defthm good-esim-modulep-of-vl-make-n-bit-res-module + (implies (natp n) + (good-esim-modulep (vl-make-n-bit-res-module n))) + :hints(("Goal" + :in-theory (e/d (good-esim-modulep + good-esim-primitivep + ) + ;; BOZO some of this is redundant and can be cleaned up + (;NO-DUPLICATESP-EQUAL-WHEN-SAME-LENGTH-MERGESORT + ;; leaving this one enabled--- NO-DUPLICATESP-EQUAL-OF-APPEND + ACL2::NO-DUPLICATESP-EQUAL-APPEND-IFF + acl2::NO-DUPLICATESP-EQUAL-OF-APPEND-OF-APPEND)))))) + + + +(defsection vl-make-res-occ + :parents (vl-make-res-occs) + :short "Generate and instantiate an appropriate resolution module to drive a +wire to multiple values." + + :long "@(call vl-make-res-occ) builds an E occurrence that simultaneously +drives @('out') to all of the values on @('ins').
" + + (defund vl-make-res-occ (name out ins) + (declare (xargs :guard (and (vl-emodwire-p out) + (vl-emodwirelist-p ins) + (true-listp ins) + (uniquep ins)))) + (b* ((n (len ins)) + (op (vl-make-n-bit-res-module n)) + ;; Note: The i/o here must agree with in-pat and out-pat from + ;; vl-make-n-bit-res-module above. + (i (and (posp n) (list ins))) + (o (list (list out)))) + (list :u name :op op :i i :o o))) + + (local (in-theory (enable vl-make-res-occ))) + + (local (defthm similar-patternsp-when-emodwires-of-same-length + (implies (and (vl-emodwirelist-p x) + (vl-emodwirelist-p y) + (true-listp x) + (true-listp y)) + (equal (similar-patternsp x y) + (equal (len x) (len y)))))) + + (local (defthm outs-of-vl-make-n-bit-res-module + (equal (gpl :o (vl-make-n-bit-res-module n)) + (list (list (vl-plain-wire-name "O")))) + :hints(("Goal" :in-theory (enable vl-make-n-bit-res-module))))) + + (local (defthm ins-of-vl-make-n-bit-res-module + (equal (gpl :i (vl-make-n-bit-res-module n)) + (and (posp n) + (list (vl-emodwires-from-high-to-low "A" (- n 1) 0)))) + :hints(("Goal" :in-theory (enable vl-make-n-bit-res-module))))) + + (defthm good-esim-occp-of-vl-make-res-occ + (implies (and (force (vl-emodwire-p out)) + (force (vl-emodwirelist-p ins)) + (force (true-listp ins)) + (force (uniquep ins)) + (force name)) + (good-esim-occp (vl-make-res-occ name out ins))) + :hints(("Goal" :in-theory (enable good-esim-occp))))) + + +(defsection vl-make-res-occs + :parents (resolving-multiple-drivers) + :short "Convert the @(see vl-res-sigma-p) database into a list of E +occurrences to drive each multiply driven wire." + + :long "@(call vl-make-res-occs) takes @('idx'), an index for fresh name +generation, and @('sigma'), which should be the already shrunk @(see +vl-res-sigma-p) obtained from @(see vl-res-rewrite-occs). Recall that the +alist binds, e.g.,
+ +@({ + W --> (W_1 W_2 ... W_n) +}) + +Where @('W') was the name of some original, multiply-driven wire, and +@('W_1, \dots') are the freshly generated names that are now being driven +instead of W. The idea is to build a new occurrence that drives W to the +resolution of W1...Wn, for each such W.
" + + (defund vl-make-res-occs (idx sigma) + ;; Sigma must be pre-shrunk. We make a driver occurrence for each of its + ;; entries. IDX is used for name generation. + "Returns (MV OCCS IDX')" + (declare (xargs :guard (and (natp idx) + (vl-res-sigma-p sigma)))) + (b* ((idx (lnfix idx)) + ((when (atom sigma)) + (mv nil idx)) + (out1 (caar sigma)) + (ins1 (cdar sigma)) + (idx (+ 1 idx)) + (fresh (make-vl-emodwire :basename "vl_res" :index idx)) + ((unless (and (true-listp ins1) + (uniquep ins1))) + ;; Should be impossible by how SIGMA is constructed. + (er hard? 'vl-make-res-occs "Failed to generate unique drivers!") + (mv nil idx)) + (occ1 (vl-make-res-occ fresh out1 ins1)) + ((mv rest idx) (vl-make-res-occs idx (cdr sigma)))) + (mv (cons occ1 rest) idx))) + + (local (in-theory (enable vl-make-res-occs))) + + (defmvtypes vl-make-res-occs (true-listp natp)) + + (local (defthm l0 + (implies (maybe-natp idx) + (iff (vl-emodwire "vl_res" idx) + t)) + :hints(("Goal" + :in-theory (disable vl-emodwire-p-of-vl-emodwire) + :use ((:instance vl-emodwire-p-of-vl-emodwire + (basename "vl_res") + (index idx))))))) + + (defthm good-esim-occsp-of-vl-make-res-occs + (implies (and (force (natp idx)) + (force (vl-res-sigma-p sigma))) + (good-esim-occsp (mv-nth 0 (vl-make-res-occs idx sigma)))) + :hints(("Goal" :in-theory (enable good-esim-occsp))))) + + + + + +(defsection vl-add-res-modules + :parents (resolving-multiple-drivers) + :short "Top-level function for resolving multiple drivers in a list of E +occurrences." + + :long "Signature: @(call vl-add-res-modules) returns +@('occs'').
+ +@('occs') should be a preliminary list of occurrences, e.g., generated +perhaps by @(see vl-modinst-to-eocc) along with other occurrences for driving +T/F, undriven outputs, etc. These occurrences are presumably not yet +well-formed because the same wire may be driven by multiple occs.
+ +@('all-names') must be a @(see vl-emodwirelist-p) that captures the module's +namespace. We expect it to include at least:
+ +However, as a special exception, @('all-names') may exclude names that we +know cannot have the basename @('vl_res'), because any wires we are going to +introduce are either already used in @('occs') or are going to have the form +@('vl_res[k]'). This includes, for instance, the names added during @(see +vl-add-zdrivers) and for driving the T and F wires.
" + + (defund vl-add-res-modules (all-names occs) + "Returns OCCS'" + (declare (xargs :guard (and (vl-emodwirelist-p all-names) + (vl-emodwirelist-p (acl2::collect-signal-list :o occs))))) + (b* ((multiply-driven + ;; Note that we don't include :i as drivers because we separately + ;; insist that no inputs are ever driven. + (duplicated-members (acl2::collect-signal-list :o occs))) + + ((unless multiply-driven) + ;; Optimization: when there aren't any multiply driven wires, we don't + ;; need to do anything. This possibly saves a lot of string + ;; comparisons to figure out the max index, a lot of traversal of the + ;; occs, etc. + occs) + + (idx (vl-emodwirelist-highest "vl_res" all-names)) + (mds (make-lookup-alist multiply-driven)) + (sigma (len multiply-driven)) ;; probably a reasonably good size hint + ((mv rw-occs idx sigma) + (vl-res-rewrite-occs occs mds idx sigma)) + (sigma (b* ((tmp (hons-shrink-alist sigma nil))) + (fast-alist-free sigma) + tmp)) + ((mv res-occs ?idx) + (vl-make-res-occs idx sigma))) + (fast-alist-free mds) + (fast-alist-free sigma) + (append rw-occs res-occs))) + + (local (in-theory (enable vl-add-res-modules))) + + (defthm true-listp-of-vl-add-res-modules + (implies (true-listp occs) + (true-listp (vl-add-res-modules all-names occs))) + :rule-classes :type-prescription) + + (defthm good-esim-occsp-of-vl-add-res-modules + (implies (and (force (good-esim-occsp occs)) + (force (vl-emodwirelist-p (acl2::collect-signal-list :o occs)))) + (good-esim-occsp (vl-add-res-modules all-names occs))))) diff -Nru acl2-7.0/books/centaur/esim/vltoe/cert.acl2 acl2-7.1/books/centaur/esim/vltoe/cert.acl2 --- acl2-7.0/books/centaur/esim/vltoe/cert.acl2 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/vltoe/cert.acl2 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1,32 @@ +; ESIM Symbolic Hardware Simulator +; Copyright (C) 2008-2015 Centaur Technology +; +; Contact: +; Centaur Technology Formal Verification Group +; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA. +; http://www.centtech.com/ +; +; License: (An MIT/X11-style license) +; +; Permission is hereby granted, free of charge, to any person obtaining a +; copy of this software and associated documentation files (the "Software"), +; to deal in the Software without restriction, including without limitation +; the rights to use, copy, modify, merge, publish, distribute, sublicense, +; and/or sell copies of the Software, and to permit persons to whom the +; Software is furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +; DEALINGS IN THE SOFTWARE. +; +; Original author: Jared DavisA significant difference between E and Verilog is that there are no +vectors in E. Whereas our Verilog module might have a vector like @('wire +[7:0] w'), our E module will instead have eight individual wires, whose names +are @('ACL2::|w[7]|') through @('ACL2::|w[0]|').
+ +There is a fair bit of code geared towards making this bit-level conversion +safe and efficient. As a quick summary:
+ +BOZO much of this code predates the exprsesion slicing code. We may wish to +eventually redo significant portions of the wirealist stuff to instead be based +on the expression-slicing code.
") + +(local (defthm equal-of-string-and-nil-string + (implies (force (stringp str)) + (equal (equal str "NIL") + (equal (explode str) + '(#\N #\I #\L)))) + :hints(("Goal" + :in-theory (disable str::equal-of-explodes) + :use ((:instance str::equal-of-explodes + (acl2::x str) + (acl2::y "NIL"))))))) + +#!ACL2 +(local (defthm intern-in-package-of-symbol-not-nil + (implies (and (force (stringp str)) + (force (not (equal str "NIL")))) + (intern-in-package-of-symbol str 'acl2::rewrite)) + :hints(("Goal" + :in-theory (disable equal-of-intern-in-package-of-symbols) + :use ((:instance equal-of-intern-in-package-of-symbols + (a "NIL") + (b str) + (in-pkg 'acl2::rewrite))))))) + +(local (defthm member-of-make-character-list + (implies (and (characterp a) + (member-equal a chars)) + (member-equal a (make-character-list chars))) + :hints(("Goal" :in-theory (enable make-character-list))))) + +(local (defthm implode-is-not-nil-bracket-char + (implies (member #\[ chars) + (not (equal (implode chars) "NIL"))) + :hints(("Goal" + :in-theory (disable member-of-make-character-list) + :use ((:instance member-of-make-character-list + (a #\[) + (chars chars))))))) + + +(local + (defsection no-specials-in-natstr + + (local (defthm c0 + (and (not (equal (str::digit-to-char x) #\!)) + (not (equal (str::digit-to-char x) #\.)) + (not (equal (str::digit-to-char x) #\/))) + :hints(("Goal" :in-theory (enable digit-to-char))))) + + (local (defthm c1 + (and (not (member-equal #\! (str::basic-natchars x))) + (not (member-equal #\. (str::basic-natchars x))) + (not (member-equal #\/ (str::basic-natchars x)))) + :hints(("Goal" :in-theory (enable str::basic-natchars))))) + + (local (defthm c2 + (and (not (member-equal #\! (str::natchars x))) + (not (member-equal #\. (str::natchars x))) + (not (member-equal #\/ (str::natchars x)))) + :hints(("Goal" :in-theory (enable str::natchars))))) + + (defthm no-specials-in-natstr + (and (not (member-equal #\! (explode (natstr x)))) + (not (member-equal #\. (explode (natstr x)))) + (not (member-equal #\/ (explode (natstr x))))) + :hints(("Goal" :in-theory (enable natstr)))))) + + +(local (defthm digit-listp-encoding-help + (implies (str::digit-listp x) + (and (not (member-equal #\] x)) + (not (member-equal #\[ x)) + (not (member-equal #\{ x)))) + :hints(("Goal" :in-theory (enable str::digit-listp))))) + + + +(defsection emodwire-encoding + :parents (exploding-vectors) + :short "A simple encoding scheme to basenames that are free of certain +special characters." + + :long "Usually Verilog wire names do not have special characters in them, +but with escaped identifiers it is possible to have names that include +brackets, dots, etc.
+ +These special characters could pose certain problems. The most obvious is +in a module such as this:
+ +@({ + wire [7:0] w ; + wire \w[3] ; +}) + +Here, the E wires corresponding to @('w') would be @('ACL2::|w[7]|') on down +to @('ACL2::|w[0]|'). But if we naively translate @('\w[3] ') into +@('ACL2::|w[3]|') then there could be a name clash.
+ +To avoid this kind of problem, we use a simple encoding scheme that ensures +there are no brackets in the basename of a @(see vl-emodwire-p). We originally +used the following, trivial encoding scheme:
+ +But later we decided to slightly extend this scheme, to ensure that the +special characters @('.'), @('!'), and @('/') also do not occur. Why? We +think having @('.') in a name could be confusing to some tools since it is used +as a hierarchical identifier in Verilog. Meanwhile, @('!') is used as a +hierarchical identifier in E (e.g., see @('mod-state')). And we have +occasionally seen other Verilog tools that use @('/') as a hierarchical +separator.
+ +To ensure these characters also do not occur, we extend our encoding scheme +in a simple way:
+ +This encoding is done automatically by the @(see vl-emodwire) constructor +and the appropriate decoding is done by the @(see vl-emodwire->basename) +accessor. Usually no encoding is necessary, so these functions are optimized +for the case that there are no bracket or { characters.
+ +Note that we actually implement the encoding and decoding functions in +raw-lisp for better performance.
" + + (defund vl-emodwire-encode-chars (x) + ;; Slow. We don't expect this to ever really be called in practice. + (declare (xargs :guard (character-listp x))) + (if (atom x) + nil + (let ((rest (vl-emodwire-encode-chars (cdr x)))) + (case (car x) + (#\[ (list* #\{ #\1 rest)) + (#\] (list* #\{ #\2 rest)) + (#\{ (list* #\{ #\3 rest)) + (#\. (list* #\{ #\4 rest)) + (#\! (list* #\{ #\5 rest)) + (#\/ (list* #\{ #\6 rest)) + (otherwise + (cons (car x) rest)))))) + + (local (in-theory (enable vl-emodwire-encode-chars))) + + (defthm character-listp-of-vl-emodwire-encode-chars + (implies (force (character-listp x)) + (character-listp (vl-emodwire-encode-chars x)))) + + (defthm no-special-chars-in-vl-emodwire-encode-chars + (and (not (member-equal #\[ (vl-emodwire-encode-chars x))) + (not (member-equal #\] (vl-emodwire-encode-chars x))) + (not (member-equal #\. (vl-emodwire-encode-chars x))) + (not (member-equal #\! (vl-emodwire-encode-chars x))) + (not (member-equal #\/ (vl-emodwire-encode-chars x))))) + + (defthm vl-emodwire-encode-chars-identity + (implies (and (not (member-equal #\[ x)) + (not (member-equal #\] x)) + (not (member-equal #\{ x)) + (not (member-equal #\. x)) + (not (member-equal #\! x)) + (not (member-equal #\/ x))) + (equal (vl-emodwire-encode-chars x) + (list-fix x)))) + + + (defund vl-emodwire-encoding-valid-p (x) + ;; Slow. We don't expect this to ever really be called in practice. + (declare (xargs :guard (character-listp x))) + (cond ((atom x) + t) + ((eql (car x) #\{) + (and (consp (cdr x)) + (or (eql (cadr x) #\1) + (eql (cadr x) #\2) + (eql (cadr x) #\3) + (eql (cadr x) #\4) + (eql (cadr x) #\5) + (eql (cadr x) #\6)) + (vl-emodwire-encoding-valid-p (cddr x)))) + (t + (vl-emodwire-encoding-valid-p (cdr x))))) + + (local (in-theory (enable vl-emodwire-encoding-valid-p))) + + (defthm vl-emodwire-encoding-valid-p-of-vl-emodwire-encode-chars + (vl-emodwire-encoding-valid-p (vl-emodwire-encode-chars x))) + + (defthm vl-emodwire-encoding-valid-p-typical + (implies (not (member-equal #\{ x)) + (vl-emodwire-encoding-valid-p x))) + + (defthm vl-emodwire-encoding-valid-p-of-append + (implies (and (force (vl-emodwire-encoding-valid-p x)) + (force (vl-emodwire-encoding-valid-p y))) + (vl-emodwire-encoding-valid-p (append x y)))) + + + + + (defund vl-emodwire-decode-chars (x) + ;; Slow. We don't expect this to ever really be called in practice. + (declare (xargs :guard (character-listp x))) + (cond ((atom x) + nil) + ((and (eql (car x) #\{) + (consp (cdr x))) + (let ((rest (vl-emodwire-decode-chars (cddr x)))) + (case (cadr x) + (#\1 (cons #\[ rest)) + (#\2 (cons #\] rest)) + (#\3 (cons #\{ rest)) + (#\4 (cons #\. rest)) + (#\5 (cons #\! rest)) + (otherwise (cons #\/ rest))))) + (t + (cons (car x) (vl-emodwire-decode-chars (cdr x)))))) + + (local (in-theory (enable vl-emodwire-decode-chars))) + + (defthm vl-emodwire-decode-chars-under-iff + (iff (vl-emodwire-decode-chars x) + (consp x))) + + (defthm character-listp-of-vl-emodwire-decode-chars + (implies (force (character-listp x)) + (character-listp (vl-emodwire-decode-chars x)))) + + (defthm vl-emodwire-decode-chars-of-vl-emodwire-encode-chars + (implies (force (character-listp x)) + (equal (vl-emodwire-decode-chars (vl-emodwire-encode-chars x)) + (list-fix x)))) + + (defthm vl-emodwire-decode-chars-identity + (implies (case-split (not (member-equal #\{ x))) + (equal (vl-emodwire-decode-chars x) + (list-fix x)))) + + + (defsection equal-of-vl-emodwire-decode-chars + + (local (defun my-induct (x y) + (if (and (atom x) + (atom y)) + t + (if (or (atom x) + (atom y)) + nil + (if (eql (car x) #\{) + (if (eql (car y) #\{) + (my-induct (cddr x) (cddr y)) + nil) + (my-induct (cdr x) (cdr y))))))) + + ;; All this junk is just to make the proof fast. + + (local (defthm c0 + (implies (vl-emodwire-encoding-valid-p x) + (vl-emodwire-encoding-valid-p (cdr x))))) + + (local (defthm c1 + (implies (and (EQUAL (LIST-FIX (cdr X)) (LIST-FIX (cdr Y))) + (consp x) + (consp y)) + (equal (EQUAL (LIST-FIX X) (LIST-FIX Y)) + (equal (car x) (car y)))))) + + (local (defthm c2 + (implies (not (equal (LIST-FIX (cdr X)) (LIST-FIX (cdr Y)))) + (not (equal (LIST-FIX X) (LIST-FIX Y)))))) + + (local (defthm c3 + (implies (not (member-equal a x)) + (equal (equal (first x) a) + (and (atom x) + (not a)))))) + + (local (defthm c4 + (implies (and (not (equal (car x) (car y))) + (or (consp x) + (consp y))) + (not (equal (list-fix x) (list-fix y)))))) + + (local (defthm c5 + (implies (atom x) + (equal (list-fix x) nil)))) + + (local (defthm c6 + (implies (atom x) + (equal (vl-emodwire-decode-chars x) + nil)))) + + (defthm equal-of-vl-emodwire-decode-chars + (implies (and (vl-emodwire-encoding-valid-p x) + (vl-emodwire-encoding-valid-p y) + (not (member-equal #\[ x)) + (not (member-equal #\] x)) + (not (member-equal #\. x)) + (not (member-equal #\! x)) + (not (member-equal #\/ x)) + (not (member-equal #\[ y)) + (not (member-equal #\] y)) + (not (member-equal #\. y)) + (not (member-equal #\! y)) + (not (member-equal #\/ y))) + (equal (equal (vl-emodwire-decode-chars x) + (vl-emodwire-decode-chars y)) + (equal (list-fix x) + (list-fix y)))) + :hints(("Goal" + :induct (my-induct x y) + :do-not '(generalize fertilize eliminate-destructors) + :in-theory (disable vl-emodwire-decode-chars + vl-emodwire-encoding-valid-p + vl-emodwire-decode-chars-identity + ACL2::TRUE-LISTP-MEMBER-EQUAL + ACL2::LIST-FIX-WHEN-TRUE-LISTP + double-containment + MEMBER-EQUAL-WHEN-MEMBER-EQUAL-OF-CDR-UNDER-IFF + acl2::MEMBER-EQUAL-WHEN-ALL-EQUALP + acl2::subsetp-trans + acl2::subsetp-trans2 + + ) + :expand ((vl-emodwire-decode-chars x) + (vl-emodwire-decode-chars y) + (vl-emodwire-encoding-valid-p x) + (vl-emodwire-encoding-valid-p y)))))) + + (defund vl-emodwire-encode-aux (x) + ;; Slow. We don't expect this to ever really be called in practice. We keep + ;; this in a separate function to minimize expansion from inlining the main + ;; function. + (declare (type string x)) + (b* ((chars (explode x)) + (encoded (vl-emodwire-encode-chars chars))) + (implode encoded))) + + (defund vl-emodwire-decode-aux (x) + ;; Slow. We don't expect this to ever really be called in practice. We keep + ;; this in a separate function to minimize expansion from inlining the main + ;; function. + (declare (type string x)) + (b* ((chars (explode x)) + (decoded (vl-emodwire-decode-chars chars))) + (implode decoded))) + + (local (in-theory (enable vl-emodwire-encode-aux + vl-emodwire-decode-aux))) + + ;; We seem to be able to do a lot better in raw lisp. It seems worth the + ;; effort to optimize these under the hood, since we may need to generate + ;; millions of emodwires. + ;; + ;; Encoding with no inlining: + ;; ACL2 version: 7.60 seconds (no inlining) + ;; Raw version: 0.68 seconds (no inlining) + ;; + ;; Decoding with no inlining: + ;; ACL2 version: 1.27 seconds (no inlining) + ;; Raw version: 0.39 seconds (no inlining) + + #|| + (time$ + (loop for i from 1 to 10000000 do + (vl2014::vl-emodwire-encode "looksLikeAVerilogWire"))) + + (time$ + (loop for i from 1 to 10000000 do + (vl2014::vl-emodwire-decode "looksLikeAVerilogWire"))) + ||# + + + (defund vl-emodwire-encode (x) + (declare (type string x)) + (mbe :logic (vl-emodwire-encode-aux x) + :exec (if (or (position #\[ (the string x)) + (position #\] (the string x)) + (position #\{ (the string x)) + (position #\. (the string x)) + (position #\! (the string x)) + (position #\/ (the string x))) + (vl-emodwire-encode-aux x) + x))) + + (defund vl-emodwire-decode (x) + (declare (type string x)) + (mbe :logic (vl-emodwire-decode-aux x) + :exec (if (position #\{ x) + (vl-emodwire-decode-aux x) + x))) + + (defttag vl-optimize) + (progn! + (set-raw-mode t) + + (declaim (inline vl-emodwire-encode)) + (declaim (inline vl-emodwire-decode)) + + (defun vl-emodwire-encode (x) + (declare (type string x)) + (let ((xl (length (the simple-string x)))) + (loop for i fixnum from 0 below xl do + (let ((c (schar x i))) + (case c + ((#\[ #\] #\{ #\. #\! #\/) + (return-from vl-emodwire-encode + (vl2014::vl-emodwire-encode-aux x))) + (otherwise + nil)))) + x)) + + (defun vl-emodwire-decode (x) + (declare (type string x)) + (let ((xl (length (the simple-string x)))) + (loop for i fixnum from 0 below xl do + (let ((c (schar x i))) + (when (eql c #\{) + (return-from vl-emodwire-decode + (vl2014::vl-emodwire-decode-aux x))))) + x))) + + (defttag nil)) + + + + + +(defsection vl-emodwire-encode-chars-nil + + ;; N: if there are no special chars, then NIL is the only string whose encoding + ;; is "NIL" + + (local (defthmd n0 + (implies (and (not (member-equal #\[ x)) + (not (member-equal #\] x)) + (not (member-equal #\{ x)) + (not (member-equal #\. x)) + (not (member-equal #\! x)) + (not (member-equal #\/ x))) + (equal (vl-emodwire-encode-chars x) + (list-fix x))))) + + (local (defthm n1 + (implies (and (not (member-equal #\[ x)) + (not (member-equal #\] x)) + (not (member-equal #\{ x)) + (not (member-equal #\. x)) + (not (member-equal #\! x)) + (not (member-equal #\/ x)) + (character-listp x)) + (equal (equal (vl-emodwire-encode-chars x) '(#\N #\I #\L)) + (equal x '(#\N #\I #\L)))))) + + ;; M: if there are special chars, then it doesn't get encoded as NIL because + ;; its encoding has a { character in it. + + (local (defthmd m0 + (implies (or (member-equal #\[ x) + (member-equal #\] x) + (member-equal #\{ x) + (member-equal #\. x) + (member-equal #\! x) + (member-equal #\/ x)) + (member #\{ (vl-emodwire-encode-chars x))) + :hints(("Goal" :in-theory (enable vl-emodwire-encode-chars))))) + + (local (defthmd m1 + (implies (member #\{ x) + (not (equal x '(#\N #\I #\L)))))) + + (local (defthm m2 + (implies (or (member-equal #\[ x) + (member-equal #\] x) + (member-equal #\{ x) + (member-equal #\. x) + (member-equal #\! x) + (member-equal #\/ x)) + (not (equal (vl-emodwire-encode-chars x) '(#\N #\I #\L)))) + :hints(("Goal" + :use ((:instance m0) + (:instance m1 (x (vl-emodwire-encode-chars x)))))))) + + (defthm vl-emodwire-encode-chars-nil + (implies (character-listp x) + (equal (equal (vl-emodwire-encode-chars x) '(#\N #\I #\L)) + (equal x '(#\N #\I #\L)))) + :hints(("Goal" + :use ((:instance n1) + (:instance m2)))))) + + +(defsection vl-emodwire-encode-nil + + (local (defthm l0 + (implies (force (stringp str)) + (equal (equal str "NIL") + (equal (explode str) + '(#\N #\I #\L)))) + :hints(("Goal" + :in-theory (disable str::equal-of-explodes) + :use ((:instance str::equal-of-explodes + (acl2::x str) + (acl2::y "NIL"))))))) + + (defthm vl-emodwire-encode-nil + (implies (stringp x) + (equal (equal (vl-emodwire-encode x) "NIL") + (equal x "NIL"))) + :hints(("Goal" + :in-theory (enable vl-emodwire-encode + vl-emodwire-encode-aux)))) + + (defthm vl-emodwire-encode-nil-alt + (implies (stringp x) + (equal (equal (explode (vl-emodwire-encode x)) '(#\N #\I #\L)) + (equal x "NIL"))) + :hints(("Goal" + :in-theory (enable vl-emodwire-encode + vl-emodwire-encode-aux))))) + + + +(defsection vl-emodwire-p + :parents (exploding-vectors) + :short "@(call vl-emodwire-p) recognizes symbols that VL generates as wire +names for E modules." + + :long "E uses a permissive pattern system that allows almost any atom to +be used as a wire name. But when VL is used to translate Verilog modules, we +always produce wire names that are symbols, whose names are either simple +names like @('\"reset\"') or indexed names like +@('\"opcode[3]\"').
+ +We always generate wire names in the @('ACL2') package. This is due to +historic convention, but also is a good idea for efficiency: we can control the +size of the ACL2 package at the time we build ACL2, but we have no +method (well, ttags I suppose) to construct a new package with a larger size. +See the efficiency considerations in @(see vl-wirealist-p) for more +details.
" + + (definline vl-emodwire-scan (name) + "We optimize this under the hood to make vl-emodwire-p faster. This + logical definition never gets executed." + (declare (type string name)) + (b* ((open (position #\[ name)) + (close (position #\] name)) + (escape (if (position #\{ name) t nil)) + (illegal (if (or (position #\. name) + (position #\! name) + (position #\/ name)) + t + nil))) + (mv open close escape illegal))) + + (defttag vl-optimize) + (progn! + (set-raw-mode t) + + (defun vl-emodwire-scan$inline (name) + (declare (type string name)) + (let ((open nil) + (close nil) + (escape nil) + (illegal nil) + (len (length (the simple-string name)))) + (loop for i fixnum from 0 below len do + (let ((c (schar name i))) + (case c + (#\[ (unless open (setq open i))) + (#\] (unless close (setq close i))) + ((#\. #\! #\/) (setq illegal t)) + (#\{ (setq escape t)) + (otherwise nil)))) + (mv open close escape illegal)))) + + + + ;; Without scan optimization: 15.8 seconds, 480 MB allocated + ;; With scan optimization: 8.65 seconds, 480 MB allocated + + #|| + (time (loop for i fixnum from 1 to 10000000 do + (vl2014::vl-emodwire-p 'acl2::|LooksLikeAVerilogWire[3]|))) + ||# + + +; We could do even better: +; +; I think the MBE optimization in vl-emodwire-get-index here is legitimate, but +; proving it is hard. Using skip-proofs to get it admitted, the loop goes down +; to 6.81 seconds and we get rid of all the allocation. So this could be a +; very nice optimization, if only we could get the proof completed. + + (definline vl-emodwire-get-index (name open close) + (declare (xargs :guard (and (stringp name) + (natp open) + (natp close) + (< open close) + (= close (- (length name) 1))))) + ;; (mbe :logic + (b* ((index-str (subseq name (+ open 1) close)) + ((mv index-val len) + (str::parse-nat-from-string index-str 0 0 0 (length index-str))) + (ok1 (= len (length index-str))) + (ok2 (equal index-str (natstr index-val)))) + (mv (and ok1 ok2) index-val)) + ;; :exec + ;;(b* ((start (+ open 1)) + ;; ((mv index-val len) + ;; (str::parse-nat-from-string name 0 0 start (length name))) + ;; (ok1 (= len (- close start))) + ;; (ok2 (or (not (eql (char name start) #\0)) + ;; (= len 1)))) + ;; (mv (and ok1 ok2) index-val))) + ) + +; Here is a fledgling effort toward verifying the guards. Lemmas C3 and C4 +; show that INDEX-VAL and LEN are correct in the :exec definition. But doing +; the proofs for ok1 and ok2 seemed too hard, and I didn't want to spend the +; necessary time. + +; If you ever get this working, probably optimize vl-emodwire->index to take +; advantage of it. + + ;; (defthm c0 + ;; (equal (cdr (nthcdr n x)) + ;; (nthcdr (+ 1 (nfix n)) x))) + + ;; (in-theory (disable nthcdr-of-increment)) + + ;; (defthm str::take-leading-digits-of-replicate + ;; (equal (str::take-leading-digits (replicate n char)) + ;; (if (str::digitp char) + ;; (replicate n char) + ;; nil)) + ;; :hints(("Goal" :in-theory (enable str::take-leading-digits + ;; replicate)))) + + + ;; (defthm c1 + ;; (implies (not (str::digitp (nth n x))) + ;; (equal (str::take-leading-digits (take n x)) + ;; (str::take-leading-digits x))) + ;; :hints(("Goal" :in-theory (enable str::take-leading-digits + ;; nth)))) + + ;; (defthm c2 + ;; (IMPLIES + ;; (AND (NATP OPEN) + ;; (< OPEN (+ -1 (LEN X))) + ;; (NOT (STR::DIGITP (NTH (+ -1 (LEN X)) X))) + ;; (<= 2 (+ (- OPEN) (LEN X)))) + ;; (EQUAL + ;; (STR::DIGIT-LIST-VALUE + ;; (STR::TAKE-LEADING-DIGITS (TAKE (+ -2 (- OPEN) (LEN X)) + ;; (NTHCDR (+ 1 OPEN) X)))) + ;; (STR::DIGIT-LIST-VALUE + ;; (STR::TAKE-LEADING-DIGITS (NTHCDR (+ 1 OPEN) X)))))) + + ;; (defthm c3 + ;; (implies (and (stringp name) + ;; (natp open) + ;; (natp close) + ;; (< open close) + ;; (= close (- (length name) 1)) + ;; (not (str::digitp (char name close)))) + ;; (equal + ;; (let ((index-str (subseq name (+ open 1) close))) + ;; (mv-nth 0 (str::parse-nat-from-string index-str 0 0 0 (length index-str)))) + ;; (let ((start (+ open 1))) + ;; (mv-nth 0 (str::parse-nat-from-string name 0 0 start (length name)))))) + ;; :hints(("Goal" :in-theory (enable subseq + ;; subseq-list)))) + + ;; (defthm c4 + ;; (implies (and (stringp name) + ;; (natp open) + ;; (natp close) + ;; (< open close) + ;; (= close (- (length name) 1)) + ;; (not (str::digitp (char name close)))) + ;; (equal + ;; (let ((index-str (subseq name (+ open 1) close))) + ;; (mv-nth 1 (str::parse-nat-from-string index-str 0 0 0 (length index-str)))) + ;; (let ((start (+ open 1))) + ;; (mv-nth 1 (str::parse-nat-from-string name 0 0 start (length name)))))) + ;; :hints(("Goal" :in-theory (enable subseq + ;; subseq-list)))) + + ;; ;; (verify-guards vl-emodwire-get-index) + + + (defund vl-emodwire-p (x) + (declare (xargs :guard t)) + (b* (((unless (and (symbolp x) x)) + nil) + (name (symbol-name x)) + ((unless (eq (intern name "ACL2") x)) + ;; For canonicity + nil) + ((mv open close escape illegal) + (vl-emodwire-scan name)) + ((when (or illegal + (and escape + (not (vl-emodwire-encoding-valid-p (explode name)))))) + ;; Improper escaping + nil) + ((when (and (not open) (not close))) + ;; Fine, a blank wire with proper escaping + t) + ((unless (and open close + (< open close) + (= close (- (length name) 1)))) + nil) + ((mv okp ?idx) + (vl-emodwire-get-index name open close))) + okp)) + + (local (in-theory (enable vl-emodwire-p))) + + (defthm booleanp-of-vl-emodwire-p + (booleanp (vl-emodwire-p x)) + :rule-classes :type-prescription) + + (defthm type-of-vl-emodwire-p + (implies (vl-emodwire-p x) + (and (symbolp x) + (not (equal x nil)))) + :rule-classes :compound-recognizer) + + (local + (progn + (assert! (vl-emodwire-p 'acl2::foo)) + (assert! (vl-emodwire-p 'acl2::foo[0])) + (assert! (vl-emodwire-p 'acl2::foo[1])) + (assert! (vl-emodwire-p 'acl2::foo[10])) + (assert! (vl-emodwire-p 'acl2::foo[123457])) + (assert! (not (vl-emodwire-p 'acl2::foo[01]))) + (assert! (not (vl-emodwire-p 'acl2::foo[01345]))) + (assert! (not (vl-emodwire-p 'acl2::fo[o]))) + (assert! (not (vl-emodwire-p 'acl2::fo[o))) + (assert! (not (vl-emodwire-p 'acl2::f/o[o))) + (assert! (not (vl-emodwire-p 'acl2::f.o[o))) + (assert! (not (vl-emodwire-p 'acl2::f]o[o))) + (assert! (not (vl-emodwire-p 'acl2::f{o[o))) + (assert! (not (vl-emodwire-p 'acl2::foo]))) + (assert! (not (vl-emodwire-p 'vl2014::foo)))))) + + +(define vl-emodwire-fix ((x vl-emodwire-p)) + :returns (x-prime vl-emodwire-p) + :inline t + :hooks nil + (mbe :logic (if (vl-emodwire-p x) x 'acl2::bad-default-emodwire) + :exec x) + /// + (defthm vl-emodwire-fix-when-vl-emodwire-p + (implies (vl-emodwire-p x) + (equal (vl-emodwire-fix x) x))) + + (fty::deffixtype vl-emodwire :pred vl-emodwire-p :fix vl-emodwire-fix + :equiv vl-emodwire-equiv :define t)) + + +(fty::deflist vl-emodwirelist :elt-type vl-emodwire + :elementp-of-nil nil + :parents (exploding-vectors) + /// + (local (in-theory (enable vl-emodwirelist-p))) + (defthm symbol-listp-when-vl-emodwirelist-p + (implies (vl-emodwirelist-p x) + (equal (symbol-listp x) + (true-listp x)))) + + (defthm member-of-nil-when-vl-emodwirelist-p + (implies (vl-emodwirelist-p x) + (not (member-equal nil x))))) + + +(fty::deflist vl-emodwirelistlist :elt-type vl-emodwirelist + :elementp-of-nil t + :parents (exploding-vectors) + :short "A list of @(see vl-emodwire-p) lists." + + :long "These are notably used as the @(':i') and @(':o') patterns for +modules; see @(see modinsts-to-eoccs) for details.
" + + /// + (local (in-theory (enable vl-emodwirelistlist-p))) + (defthm vl-emodwirelist-p-of-flatten + (implies (vl-emodwirelistlist-p x) + (vl-emodwirelist-p (flatten x))))) + + +(defsection vl-emodwire + :parents (vl-emodwire-p) + :short "Construct an emod wire from a base name and index." + :long "No restrictions are placed on the base name because we will +automatically encode it if necessary; see @(see emodwire-encoding).
+ +We take special measures to optimize this function: we pre-generate strings +@('\"[0]\"'), @('\"[1]\"'), ..., @('\"[255]\"') so that for indicies under 256 +we can avoid some concatenations. This appears to reduce memory usage by about +half and reduces run-time by about 30% for a simple loop that builds the wire +name @('foo[33]') millions of times, but this timing is based on the fast-cat +book and may change if CCL gets a compiler-macro for CONCATENATE.
+ +Note that we emulate @(see defaggregate) and add @('make-vl-emodwire') and +@('change-vl-emodwire') macros.
" + + (defun vl-make-indexed-wire-names-array (n) + (declare (xargs :ruler-extenders :all)) + (cons (cons n (cat "[" (natstr n) "]")) + (if (zp n) + nil + (vl-make-indexed-wire-names-array (1- n))))) + + (defconst *vl-indexed-wire-name-array* + ;; Array of pre-computed strings "[0]", "[1]", ..., "[255]" + (compress1 '*vl-indexed-wire-name-array* + (cons (list :HEADER + :DIMENSIONS (list 256) + :MAXIMUM-LENGTH 257 + :DEFAULT 0 + :NAME '*vl-indexed-wire-name-array*) + (vl-make-indexed-wire-names-array 255)))) + + (definlined vl-emodwire-encoded (basename index) + ;; This is a convenient target for use in wirealist generation; we can + ;; pre-encode a wire's name and then generate symbols for its bits by + ;; calling this function directly. + (declare (type string basename) + (xargs :guard (and (maybe-natp index) + (or index + (not (equal basename "NIL")))))) + (mbe :logic + (if (not index) + (intern basename "ACL2") + (intern (cat basename "[" (natstr index) "]") "ACL2")) + :exec + (cond ((not index) + (intern basename "ACL2")) + ((< index 256) + (intern (cat basename (aref1 '*vl-indexed-wire-name-array* + *vl-indexed-wire-name-array* + index)) + "ACL2")) + (t + (intern (cat basename "[" (natstr index) "]") "ACL2"))))) + + (defthm vl-emodwire-p-of-vl-emodwire-encoded + (implies (and (force (stringp name)) + (force (maybe-natp index)) + (force (or index (not (equal name "NIL"))))) + (vl-emodwire-p + (vl-emodwire-encoded (vl-emodwire-encode name) index))) + :hints(("Goal" :in-theory (enable vl-emodwire-p + vl-emodwire-encoded + vl-emodwire-encode + vl-emodwire-encode-aux + subseq + subseq-list + string-append)))) + + (definlined vl-emodwire-exec (basename index) + (declare (type string basename) + (xargs :guard (and (maybe-natp index) + (or index (not (equal basename "NIL")))))) + (vl-emodwire-encoded (vl-emodwire-encode basename) index)) + + (defthm vl-emodwire-p-of-vl-emodwire-exec + (implies (and (force (stringp basename)) + (force (maybe-natp index)) + (force (or index (not (equal basename "NIL"))))) + (vl-emodwire-p (vl-emodwire-exec basename index))) + :hints(("Goal" :in-theory (enable vl-emodwire-exec)))) + + + (defund vl-emodwire (basename index) + (declare (type string basename) + (xargs :guard (and (maybe-natp index) + (or index (not (equal basename "NIL")))) + :guard-hints(("Goal" :in-theory (enable vl-emodwire-exec + vl-emodwire-encoded))))) + (mbe :logic + (let ((basename (vl-emodwire-encode basename))) + (if (not index) + (intern basename "ACL2") + (intern (cat basename "[" (natstr index) "]") "ACL2"))) + :exec (vl-emodwire-exec basename index))) + + (defthmd vl-emodwire-is-vl-emodwire-exec + (equal (vl-emodwire basename index) + (vl-emodwire-exec basename index)) + :hints(("Goal" :in-theory (enable vl-emodwire-exec + vl-emodwire-encoded + vl-emodwire)))) + + (local (in-theory (enable vl-emodwire-is-vl-emodwire-exec))) + + (defthm symbolp-of-vl-emodwire + (symbolp (vl-emodwire basename index)) + :rule-classes :type-prescription) + + (defthm vl-emodwire-p-of-vl-emodwire + (implies (and (force (stringp basename)) + (force (maybe-natp index)) + (force (or index (not (equal basename "NIL"))))) + (vl-emodwire-p (vl-emodwire basename index))))) + + +#|| + +(defund vl-emodwire-plain (basename index) + (declare (type string basename) + (xargs :guard (maybe-natp index))) + (let ((basename (vl-emodwire-encode basename))) + (if (not index) + (intern basename "ACL2") + (intern (cat basename "[" (natstr index) "]") "ACL2")))) + +:q + +(progn + ;; 7.276 seconds, 1.12 GB allocated + (gc$) + (time$ (loop for i fixnum from 1 to 10000000 do + (vl2014::vl-emodwire "looksLikeAVerilogName" 33)))) + +(progn + ;; 10.231 seconds, 2.24 GB allocated + (gc$) + (time$ (loop for i fixnum from 1 to 10000000 do + (vl2014::vl-emodwire-plain "looksLikeAVerilogName" 33)))) + +||# + + + +(defsection vl-emodwire->basename + :parents (vl-emodwire-p) + :short "Returns the name of an @(see vl-emodwire-p), excluding the index, as +a string." + + :long "For instance, the basename of @('|opcode[3]|') is @('\"opcode\"'), +and the basename of @('|reset|') is @('\"reset\"').
" + + (local (in-theory (enable vl-emodwire-p))) + + (defund vl-emodwire->basename (x) + (declare (xargs :guard (vl-emodwire-p x))) + (b* ((name (symbol-name x)) + (open (position #\[ name))) + (vl-emodwire-decode (if open + (subseq name 0 open) + name)))) + + (local (in-theory (enable vl-emodwire->basename))) + + (defthm stringp-of-vl-emodwire->basename + (stringp (vl-emodwire->basename x)) + :rule-classes :type-prescription) + + (defthm vl-emodwire->basename-of-vl-emodwire + (implies (and (force (stringp basename)) + (force (maybe-natp index))) + (equal (vl-emodwire->basename (vl-emodwire basename index)) + basename)) + :hints(("Goal" :in-theory (enable vl-emodwire + position-equal + vl-emodwire-encode + vl-emodwire-decode + vl-emodwire-encode-aux + vl-emodwire-decode-aux + subseq + subseq-list + string-append))))) + + + +(defsection vl-emodwire->index + :parents (vl-emodwire-p) + :short "Return the index of an @(see vl-emodwire-p) as a natural, or @('nil') +if there is no index." + + :long "For instance, the index of @('|opcode[3]|') is @('3'), and the +index of @('|reset|') is @('nil').
" + +(local (in-theory (enable vl-emodwire-p))) + +(defund vl-emodwire->index (x) + (declare (xargs :guard (vl-emodwire-p x))) + (and (mbt (vl-emodwire-p x)) + (b* ((name (symbol-name x)) + (open (position #\[ name)) + ((when (not open)) + nil) + (close (position #\] name)) + (index-str (subseq name (+ open 1) close)) + ((mv index-val ?len) + (str::parse-nat-from-string index-str 0 0 0 (length index-str)))) + index-val))) + +(local (in-theory (enable vl-emodwire->index))) + +(defthm type-of-vl-emodwire->index + (or (not (vl-emodwire->index x)) + (natp (vl-emodwire->index x))) + :rule-classes :type-prescription) + +(defthm vl-emodwire->index-of-vl-emodwire + (implies (and (force (stringp basename)) + (force (maybe-natp index)) + (force (or index (not (equal basename "NIL"))))) + (equal (vl-emodwire->index (vl-emodwire basename index)) + index)) + :hints(("Goal" :in-theory (e/d (vl-emodwire + position-equal + vl-emodwire-encode + vl-emodwire-decode + vl-emodwire-encode-aux + vl-emodwire-decode-aux + subseq + subseq-list + string-append) + ((force))))))) + + +;; Introduce defaggregate like make-vl-emodwire and change-vl-emodwire macros. + +(make-event (std::da-make-maker-fn 'vl-emodwire '(basename index) nil)) +(make-event (std::da-make-maker 'vl-emodwire '(basename index))) +(make-event (std::da-make-changer-fn 'vl-emodwire '(basename index))) +(make-event (std::da-make-changer 'vl-emodwire '(basename index))) + + + +(defsection equal-when-vl-emodwire-p + +; We now show that emodwires are equal exactly when their basenames and indices +; are equal. This is a huge pain in the ass to prove, but it is a crucial +; correctness property that shows our wirenames are "canonical" or "reliable." + +; Reduction 1. Equality of emodwires is just equality of symbol names, because +; they always are in the ACL2 package. + + (local + (defthmd main-lemma-1 + (implies (and (vl-emodwire-p x) + (vl-emodwire-p y)) + (equal (equal x y) + (equal (symbol-name x) (symbol-name y)))) + :hints(("Goal" :in-theory (union-theories (theory 'minimal-theory) + '(vl-emodwire-p)))))) + + + +; Reduction 2. Symbol-name of an emodwire can be broken down into two parts: +; +; (1) the "basename without decoding" (everything up to the first [, +; or the whole thing if there is no ]), and +; +; (2) the index inside the []s. + + (local + (defsection main-lemma-2 + + (defund vl-emodwire->basename-without-decoding (x) + ;; A useful abstraction -- just get everything up to the first [ char. + (declare (xargs :guard (vl-emodwire-p x) + :guard-hints (("Goal" :in-theory (enable vl-emodwire-p))))) + (b* ((name (symbol-name x)) + (open (position #\[ name))) + (if open + (subseq name 0 open) + name))) + + (defthm stringp-of-vl-emodwire->basename-without-decoding + (implies (vl-emodwire-p x) + (stringp (vl-emodwire->basename-without-decoding x))) + :hints(("Goal" :in-theory (enable vl-emodwire-p + vl-emodwire->basename-without-decoding)))) + + (local (defthm equal-with-implode + (implies (and (stringp x) + (character-listp y)) + (equal (equal x (implode y)) + (equal (explode x) y))))) + + (local (defthm equal-with-append-take-self + (equal (equal x (append (take n x) y)) + (and (<= (nfix n) (len x)) + (equal (nthcdr (nfix n) x) y))))) + + (local (defthm cdr-of-nthcdr + (equal (cdr (nthcdr n x)) + (nthcdr (+ 1 (nfix n)) x)))) + + (local (in-theory (disable nthcdr-of-increment))) + + (local (defthm equal-of-cons-rewrite + (equal (equal (cons a b) x) + (and (consp x) + (equal (car x) a) + (equal (cdr x) b))))) + + (defthmd main-lemma-2 + (implies (vl-emodwire-p x) + (equal (symbol-name x) + (if (vl-emodwire->index x) + (cat (vl-emodwire->basename-without-decoding x) + "[" (natstr (vl-emodwire->index x)) "]") + (vl-emodwire->basename-without-decoding x)))) + :hints(("Goal" + :in-theory (e/d (vl-emodwire-p + vl-emodwire->index + vl-emodwire->basename-without-decoding + subseq + subseq-list + string-append + len + nth) + (acl2::consp-under-iff-when-true-listp + str::explode-under-iff))))))) + +; Reduction 3. Because of the restrictions made in vl-emodwire-p on the name, +; there aren't any special characters except perhaps for { in the basename +; without decoding. Hence, by the one-to-one nature of our decoder (as +; explained by equal-of-vl-emodwire-decode-chars), we know the real basenames +; are equal exactly when the basenames without decoding are equal. + + (local + (defsection main-lemma-3 + + (local (defthm f1 + (equal (vl-emodwire->basename x) + (vl-emodwire-decode (vl-emodwire->basename-without-decoding x))) + :hints(("Goal" :in-theory (enable vl-emodwire->basename + vl-emodwire->basename-without-decoding))))) + + (local + (encapsulate + () + (local (defun my-induct (n x) + (if (zp n) + x + (my-induct (- n 1) (cdr x))))) + + (local (defthm f2-help + (implies (and (vl-emodwire-encoding-valid-p x) + ;; This weird hyp ensures that the list doesn't end on a + ;; { escape. Ugly but effective. + (equal (nth n x) #\[)) + (vl-emodwire-encoding-valid-p (take n x))) + :hints(("Goal" + :induct (my-induct n x) + :in-theory (enable vl-emodwire-encoding-valid-p + acl2::take-redefinition))))) + + (defthm f2 + (implies (vl-emodwire-p x) + (vl-emodwire-encoding-valid-p + (explode (vl-emodwire->basename-without-decoding x)))) + :hints(("Goal" :in-theory (enable vl-emodwire-p + vl-emodwire->basename-without-decoding + subseq subseq-list)))))) + + + + (local + (defthm f3 + (implies (vl-emodwire-p x) + (let ((start (explode (vl-emodwire->basename-without-decoding x)))) + (and (not (member-equal #\[ start)) + (not (member-equal #\] start)) + (not (member-equal #\. start)) + (not (member-equal #\! start)) + (not (member-equal #\/ start))))) + :hints(("Goal" :in-theory (enable vl-emodwire-p + vl-emodwire->basename-without-decoding))))) + + (defthmd main-lemma-3 + (implies (and (vl-emodwire-p x) + (vl-emodwire-p y)) + (equal (equal (vl-emodwire->basename-without-decoding x) + (vl-emodwire->basename-without-decoding y)) + (equal (vl-emodwire->basename x) + (vl-emodwire->basename y)))) + :hints(("Goal" + :in-theory (e/d (vl-emodwire-decode-aux + vl-emodwire-decode) + (vl-emodwire-p + vl-emodwire->basename + vl-emodwire->basename-without-decoding + vl-emodwire-decode-chars-identity + equal-of-vl-emodwire-decode-chars)) + :use ((:instance equal-of-vl-emodwire-decode-chars + (x (explode (vl-emodwire->basename-without-decoding x))) + (y (explode (vl-emodwire->basename-without-decoding y)))))))))) + + +; Chaining it all together we see that emodwires are equal when when their +; basename/indexes are equal. + + (local (defthm main-consequence + (implies (and (vl-emodwire-p x) + (vl-emodwire-p y) + (equal (vl-emodwire->basename x) + (vl-emodwire->basename y)) + (equal (vl-emodwire->index x) + (vl-emodwire->index y))) + (equal (equal x y) + t)) + :hints(("Goal" :in-theory (enable main-lemma-1 + main-lemma-2 + main-lemma-3 + string-append))))) + +; And the other direction is trivial by the functional equality axiom, so we +; can always decompose equality of emodwires into the equalities of their +; components. + + (defthm equal-when-vl-emodwire-p + (implies (and (vl-emodwire-p x) + (vl-emodwire-p y)) + (equal (equal x y) + (and (equal (vl-emodwire->basename x) + (vl-emodwire->basename y)) + (equal (vl-emodwire->index x) + (vl-emodwire->index y))))) + :rule-classes ((:rewrite :backchain-limit-lst 0)))) + + + +(defprojection vl-emodwirelist->basenames (x) + (vl-emodwire->basename x) + :guard (vl-emodwirelist-p x) + :result-type string-listp + :nil-preservingp nil) + +(defprojection vl-emodwirelist->indices (x) + (vl-emodwire->index x) + :guard (vl-emodwirelist-p x) + :result-type vl-maybe-nat-listp + :nil-preservingp t) + + + + +(defsection vl-emodwirelist-highest + :parents (vl-emodwire-p) + :short "@(call vl-emodwirelist-highest) returns a number @('n') that is at +least as large as the index of any wire with this @('basename') in @('x')." + + :long "We use this in a few places during @(see e-conversion) to generate +new, fresh E wires.
+ +The scheme is basically similar to that of a @(see vl-namedb-p) or @(see +vl-namefactory-p): we first find an @('n') that is larger than any @('foo[k]') +currently in use, then start generating @('foo[n]'), @('foo[n+1]'), etc. We +don't use a namedb or namefactory because we need to generate @(see +vl-emodwire-p)s instead of strings.
" + + (defund vl-emodwirelist-highest (basename x) + (declare (xargs :guard (and (stringp basename) + (vl-emodwirelist-p x)))) + (cond ((atom x) + 0) + ((equal (vl-emodwire->basename (car x)) basename) + (max (nfix (vl-emodwire->index (car x))) + (vl-emodwirelist-highest basename (cdr x)))) + (t + (vl-emodwirelist-highest basename (cdr x))))) + + (local (in-theory (enable vl-emodwirelist-highest))) + + (defthm natp-of-vl-emodwirelist-highest + (natp (vl-emodwirelist-highest basename x)) + :rule-classes :type-prescription) + + (defthm vl-emodwirelist-highest-correct + (implies (and (member-equal w x) + (equal (vl-emodwire->basename w) basename)) + (<= (nfix (vl-emodwire->index w)) + (vl-emodwirelist-highest basename x))))) diff -Nru acl2-7.0/books/centaur/esim/vltoe/eocc-allnames.lisp acl2-7.1/books/centaur/esim/vltoe/eocc-allnames.lisp --- acl2-7.0/books/centaur/esim/vltoe/eocc-allnames.lisp 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/vltoe/eocc-allnames.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1,160 @@ +; ESIM Symbolic Hardware Simulator +; Copyright (C) 2008-2015 Centaur Technology +; +; Contact: +; Centaur Technology Formal Verification Group +; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA. +; http://www.centtech.com/ +; +; License: (An MIT/X11-style license) +; +; Permission is hereby granted, free of charge, to any person obtaining a +; copy of this software and associated documentation files (the "Software"), +; to deal in the Software without restriction, including without limitation +; the rights to use, copy, modify, merge, publish, distribute, sublicense, +; and/or sell copies of the Software, and to permit persons to whom the +; Software is furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +; DEALINGS IN THE SOFTWARE. +; +; Original author: Jared DavisThis documentation assumes you have already read @(see +e-conversion). Note that the E occurrences we generate in this initial pass +are only preliminary and might include multiple drivers of certain wires. See +also @(see exploding-vectors), since we are going to be doing a lot of +that.
+ +To convert each Verilog module instance into preliminary E occurrences, we +need to create E language @(see acl2::patterns) that represent (1) the inputs +and outputs of each module, i.e., the @(':i') and @(':o') patterns for each +module, and (2) the corresponding \"actuals\" of each module instance, i.e., +the @(':i') and @(':o') patterns for each occurrence.
+ + +Suppose we have a module with port declarations like:
+ +@({ +input [3:0] a; +input b; +input [5:3] c; + +... +}) + +Then we are going to generate an input pattern like:
+ +@({ +:i ( (a[0] a[1] a[2] a[3]) + (b) + (c[3] c[4] c[5]) + ...) +}) + +Here, individual bits like @('a[2]') and @('b') are @(see vl-emodwire-p)s. +The bits for each vector form a @(see vl-emodwirelist-p) like @('(a[0] a[1] +a[2] a[3])') or @('(b)'). Finally, our full @(':i') and @(':o') patterns are +lists of such vectors, and are recognized with @(see +vl-emodwirelistlist-p).
+ + +Recall the difference between port declarations (see @(see vl-portdecl-p)) +and ports (see @(see vl-port-p)). For instance:
+ +@({ +module mymod (.low(vec[3:0]), .high(vec[5:4]), foo) <-- ports + input foo; + input [5:0] vec; <-- port declarations +endmodule +}) + +We generate the @(':i') and @(':o') patterns for each module from their port +declarations, not from thir ports; see @(see vl-portdecls-to-i/o) for +details. Because of this, the actual input pattern for @('mymod') would look +like this:
+ +@({ +:i ((foo) + (vec[0] vec[1] vec[2] vec[3] vec[4] vec[5])) +}) + + +An instance of this mymod might look something like this:
+ +@({ +mymod myinstance (a[3:0], b[1:0], c[7]); +}) + +Unfortunately, the I/O patterns we have generated for @('mymod') are not +very useful when we want to translate @('myinstance'), because its entries are +not at all in the same shape or order as the ports.
+ +To correct for this, we build a port pattern for each module. For +instance, the port pattern for @('mymod') would be:
+ +@({ + ((vec[3] vec[2] vec[1] vec[0]) + (vec[5] vec[4]) + (foo)) +}) + +The port pattern matches the shape of the module's port expressions, and +lists the wires each port is connected to, in MSB-first order.
+ +Port patterns are generated by @(see vl-portlist-msb-bit-pattern). We can +carry out certain checking to ensure that the port pattern mentions every input +and output wire without duplication; see @(see port-bit-checking).
+ + +Port patterns make it pretty easy to create the E occurrence for a module +instance. In particular, for any valid module instance, we can explode the +\"actuals\" into wires that line up perfectly with the port pattern. In the +case of @('myinstance'), we sort of intuitively might imagine generating the +following \"actual pattern\":
+ +@({ + ((a[3] a[2] a[1] a[0]) + (b[1] b[0]) + (c[7])) +}) + +We don't actually build this pattern. Instead, we directly construct an +alist that binds each formal to its actual; see @(see +vl-modinst-eocc-bindings).
+ +The @(':i') and @(':o') patterns for the module may then be instantiated +with this pattern to form the @(':i') and @(':o') fields for the occurrence. +The main function that does all of this is @(see vl-modinst-to-eocc).
") + + + + +; ---------------------------------------------------------------------------- +; +; MAKING THE MODULE I/O PATTERNS +; +; (just for the port decls -- NOT the actual "port pattern") +; +; ---------------------------------------------------------------------------- + +(define vl-portdecls-to-i/o + :parents (modinsts-to-eoccs) + :short "Compute the @(':i') and @(':o') fields for a module." + + ((portdecls vl-portdecllist-p) + (walist vl-wirealist-p)) + :returns + (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (in-wires vl-emodwirelistlist-p) + (out-wires vl-emodwirelistlist-p)) + + :long "We don't take a warnings accumulator because we memoize this +function.
+ +See @(see vl-emodwirelistlist-p) for some discussion about the kinds of +patterns we generate.
+ +Historic note. We originally tried to base our @(':i') and @(':o') patterns +on the order of a module's ports. We now instead use the order of the port +declarations. This is particularly nice for ports whose expressions are +concatenations such as @('{foo, bar, baz}'), since the individual components +might not even have the same direction.
" + + (b* (((when (atom portdecls)) + (mv t nil nil nil)) + + (warnings nil) + (decl1 (car portdecls)) + ((vl-portdecl decl1) decl1) + + ((unless (or (eq decl1.dir :vl-input) + (eq decl1.dir :vl-output))) + (mv nil + (fatal :type :vl-bad-portdecl + :msg "~a0: port declaration has unsupported direction ~x1." + :args (list decl1 decl1.dir)) + nil nil)) + + (entry (hons-get decl1.name walist)) + ((unless (and entry + (mbt (vl-emodwirelist-p (cdr entry))))) + (mv nil + (fatal :type :vl-bad-portdecl + :msg "~a0: no wire alist entry for ~w1." + :args (list decl1 decl1.name)) + nil nil)) + + (msb-wires (mbe :logic (list-fix (cdr entry)) :exec (cdr entry))) + (lsb-wires (reverse msb-wires)) + +;; BOZO eventually it would be good to restore this kind of sanity checking, +;; but it's kind of broken because of the new, rich types that port +;; declarations can have. + + ;; ;; Sanity check: make sure that we found the right number of wires. + ;; ;; This shouldn't happen if the ports and the net/reg decls agree on + ;; ;; their range, which presumably we should have checked for earlier, + ;; ;; right? Well, it seems safest to check it here, "too." + ;; ((unless (and (vl-maybe-range-resolved-p decl1.range) + ;; (= (length lsb-wires) + ;; (vl-maybe-range-size decl1.range)))) + ;; (b* ((w (make-vl-warning + ;; :type :vl-programming-error + ;; :msg "~a0: wire-alist has ~x1 wires for ~w2, but its range ~ + ;; is ~a3." + ;; :args (list decl1 (length lsb-wires) decl1.name decl1.range) + ;; :fatalp t + ;; :fn 'vl-portdecls-to-i/o))) + ;; (mv nil (list w) nil nil))) + + ;; Process all the other port declarations. + ((mv successp warnings in-wires out-wires) + (vl-portdecls-to-i/o (cdr portdecls) walist)) + + ((unless successp) + (mv nil warnings in-wires out-wires)) + + ((mv in-wires out-wires) + (case decl1.dir + (:vl-input (mv (cons lsb-wires in-wires) out-wires)) + (:vl-output (mv in-wires (cons lsb-wires out-wires))) + (otherwise + (prog2$ (impossible) + (mv in-wires out-wires)))))) + + (mv t warnings in-wires out-wires)) + + /// + ;; We want to memoize top-level calls because this will be invoked repeatedly + ;; from other modules when we're trying to build the E occurrences for module + ;; instances. + (memoize 'vl-portdecls-to-i/o :recursive nil) + + (more-returns + (warnings true-listp :rule-classes :type-prescription) + (in-wires true-listp :rule-classes :type-prescription) + (out-wires true-listp :rule-classes :type-prescription))) + + +; ---------------------------------------------------------------------------- +; +; MAKING THE PORT PATTERN +; +; (the real "port pattern" -- not the module i/o portdecl pattern) +; +; ---------------------------------------------------------------------------- + +(define vl-port-msb-bits + :parents (modinsts-to-eoccs) + :short "Compute the port pattern for a single port." + ((x vl-port-p) + (walist vl-wirealist-p)) + :returns + (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (msb-bits vl-emodwirelist-p)) + + (b* ((warnings nil) + (x (vl-port-fix x)) + ((when (eq (tag x) :vl-interfaceport)) + (mv nil + (fatal :type :vl-bad-port + :msg "~a0: interface ports are not supported." + :args (list x)) + nil)) + + (expr (vl-regularport->expr x)) + ((unless expr) + (mv nil + (fatal :type :vl-bad-port + :msg "~a0: expected no blank ports." + :args (list x)) + nil)) + + ((mv successp warnings msb-bits) + (vl-msb-expr-bitlist expr walist warnings)) + + ((unless successp) + (mv nil + (fatal :type :vl-bad-port + :msg "~a0: failed to generate wires for this port." + :args (list x)) + nil))) + + (mv t warnings msb-bits)) + /// + (more-returns + (msb-bits true-listp :rule-classes :type-prescription))) + + +(define vl-portlist-msb-bit-pattern + :parents (modinsts-to-eoccs) + :short "Compute the port pattern for a module." + ((x vl-portlist-p) + (walist vl-wirealist-p)) + :returns + (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (pattern vl-emodwirelistlist-p)) + :long "We don't take a warnings accumulator because we memoize this + function.
" + + (b* (((when (atom x)) + (mv t nil nil)) + ((mv successp1 warnings1 wires1) (vl-port-msb-bits (car x) walist)) + ((mv successp2 warnings2 wires2) (vl-portlist-msb-bit-pattern (cdr x) walist))) + (mv (and successp1 successp2) + (append-without-guard warnings1 warnings2) + (cons wires1 wires2))) + + /// + (memoize 'vl-portlist-msb-bit-pattern :recursive nil) + + (more-returns + (pattern true-listp :rule-classes :type-prescription) + (pattern true-list-listp))) + + + +; ---------------------------------------------------------------------------- +; +; PORT-BIT CHECKING +; +; (a separate transform before making occurrences) +; +; ---------------------------------------------------------------------------- + +(defxdoc port-bit-checking + :parents (e-conversion) + :short "A well-formedness check to ensure that ports and port declarations +agree, and are simple enough for E conversion." + + :long "Before generating E modules, we do a global pass over the module +list and make sure that we can generate the port pattern for each module +appropriately.
") + +(define vl-module-check-port-bits + :parents (port-bit-checking) + :short "Ensure the port pattern for a module is reasonable." + ((x vl-module-p)) + :returns (new-x (and (vl-module-p new-x) + (equal (vl-module->name new-x) + (vl-module->name x)))) + + :long "@(call vl-module-check-port-bits) separately builds up the bit +patterns for ports and the port declarations of the module @('x'), then makes +sure that there is exactly one port bit for every port declaration bit and vice +versa. We extend @('X') with a fatal warning if this doesn't hold.
" + + (b* (((vl-module x) (vl-module-fix x)) + (warnings x.warnings) + + ;; Construct the wire alist + ((mv successp warnings walist) + (vl-module-wirealist x warnings)) + ((unless successp) + (change-vl-module x :warnings warnings)) + ((with-fast walist)) + + ;; Get bit lists for ports and port declarations + ((mv okp1 warnings1 port-bits) + (vl-portlist-msb-bit-pattern x.ports walist)) + ((mv okp2 warnings2 in-wires out-wires) + (vl-portdecls-to-i/o x.portdecls walist)) + (warnings (append-without-guard warnings1 warnings2 x.warnings)) + ((unless (and okp1 okp2)) + (change-vl-module x :warnings warnings)) + + ;; Turn everything into sets so we can compare them efficiently + (flat-ports (flatten port-bits)) + (flat-ports-s (mergesort flat-ports)) + + (flat-ins (flatten in-wires)) + (flat-outs (flatten out-wires)) + (flat-ins-s (mergesort flat-ins)) + (flat-outs-s (mergesort flat-outs)) + (flat-decls-s (union flat-ins-s flat-outs-s)) + + ;; Check: unique bits for all port declarations. + (warnings + (b* (((when (mbe :logic (uniquep (append flat-ins flat-outs)) + :exec (and (mbe :logic (uniquep flat-ins) + :exec (same-lengthp flat-ins-s flat-ins)) + (mbe :logic (uniquep flat-outs) + :exec (same-lengthp flat-outs-s flat-outs)) + (mbe :logic (not (intersectp-equal flat-ins flat-outs)) + :exec (not (set::intersectp flat-ins-s flat-outs-s)))))) + warnings) + ;; Else, there are duplicated port names! + (dupe-names (duplicated-members (vl-portdecllist->names x.portdecls))) + ((when dupe-names) + (fatal :type :vl-bad-portdecls + :msg "The following ports are illegally declared more ~ + than once: ~&0." + :args (list dupe-names))) + (dupe-bits (duplicated-members (append flat-ins flat-outs)))) + (fatal :type :vl-programming-error + :msg "Failed to generate unique port bit names even though ~ + the port decls have unique names. Jared thinks this ~ + should be impossible unless the wire alist is invalid. ~ + Duplicate bits: ~&0." + :args (list (vl-verilogify-emodwirelist dupe-bits))))) + + ;; Check: unique bits for all ports. + (warnings + (b* (((when (mbe :logic (uniquep flat-ports) + :exec (same-lengthp flat-ports-s flat-ports))) + warnings) + (dupe-bits (duplicated-members flat-ports))) + (fatal :type :vl-bad-ports + :msg "The following wires are directly connected to multiple ~ + ports: ~&0." + :args (list (vl-verilogify-emodwirelist dupe-bits))))) + + ;; Check: every declared bit is in a port, and vice versa. + (warnings + (b* (((when (equal flat-decls-s flat-ports-s)) + warnings) + (extra-port-bits (difference flat-ports-s flat-decls-s)) + (extra-decl-bits (difference flat-decls-s flat-ports-s))) + (fatal :type :vl-bad-ports + :msg "Mismatch between the ports and port declarations:~% ~ + - Bits only in ports: ~&0~% ~ + - Bits only in port declarations: ~&1" + :args (list (vl-verilogify-emodwirelist extra-port-bits) + (vl-verilogify-emodwirelist extra-decl-bits))))) + + ((when (equal x.warnings warnings)) + ;; Optimization: don't change the module if the warnings haven't + ;; changed. This is actually very useful: it lets us reuse the + ;; memoized wirealist and portpat stuff for modules that don't have any + ;; problems. + x)) + (change-vl-module x :warnings warnings)) + + :prepwork + ((local + (encapsulate + () + (local (defthm insert-under-iff + (iff (insert a x) + t) + :hints(("Goal" :in-theory (enable (:ruleset set::primitive-rules)))))) + + (local (defthm demote-in-to-member-equal + (implies (setp x) + (equal (in a x) + (if (member-equal a x) + t + nil))) + :hints(("Goal" :in-theory (enable (:ruleset set::primitive-rules)))))) + + (defthm empty-intersect-to-intersectp-equal + (implies (and (setp x) + (setp y)) + (equal (empty (set::intersect x y)) + (not (intersectp-equal x y)))) + :hints(("Goal" + :induct (set::intersect x y) + :in-theory (e/d ((:ruleset set::primitive-rules)) + ;; speed hint + (promote-member-equal-to-membership + set::insert-identity + set::intersect-symmetric + set::double-containment + set::setp))))))) + + ;; Speed hint + (local (in-theory (disable no-duplicatesp-equal + union + intersect + mergesort + difference + intersectp-equal + hons-assoc-equal + acl2::consp-under-iff-when-true-listp + subsetp-equal-when-first-two-same-yada-yada + set::double-containment))))) + + +(defprojection vl-modulelist-check-port-bits ((x vl-modulelist-p)) + :returns (new-x vl-modulelist-p) + :parents (port-bit-checking) + :long "Performance note. This will look expensive because it calls @(see +vl-module-wirealist), @(see vl-portdecls-to-i/o) and @(see +vl-portlist-msb-bit-pattern) on all modules. But since these are memoized, we +get to reuse this work when we generate the eoccs for module instances and need +to look up these patterns.
" + (vl-module-check-port-bits x) + /// + (defthm vl-modulelist->names-of-vl-modulelist-check-port-bits + (equal (vl-modulelist->names (vl-modulelist-check-port-bits x)) + (vl-modulelist->names x)))) + + + +; ---------------------------------------------------------------------------- +; +; MAKING THE ALIST OF FORMALS->ACTUALS FOR AN INSTANCE +; +; ---------------------------------------------------------------------------- + +(define vl-plainarg-lsb-bits + :parents (modinsts-to-eoccs) + :short "Build the list of @(see vl-emodwire-p)s for a @(see vl-plainarg-p), +in LSB-first order." + ((x vl-plainarg-p) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :returns (mv (successp) + (warnings vl-warninglist-p) + (lsb-bits vl-emodwirelist-p)) + + :long "See @(see vl-msb-expr-bitlist). This function just makes sure a +@(see vl-plainarg-p) isn't blank and then calls @('vl-msb-expr-bitlist') to do +the work. We return the bits in LSB-first order to match the convention +throughout E.
" + + (b* ((warnings (vl-warninglist-fix warnings)) ;; BOZO shouldn't need this + (expr (vl-plainarg->expr x)) + + ((unless expr) + (mv nil + (fatal :type :vl-unsupported + :msg "In vl-plainarg-lsb-bits, expected no blank ports.") + nil)) + ((mv successp warnings bits) + (vl-msb-expr-bitlist expr walist warnings))) + (mv successp warnings (reverse bits))) + /// + (more-returns + (lsb-bits true-listp :rule-classes :type-prescription))) + + +(define vl-plainarglist-lsb-pattern + :parents (modinsts-to-eoccs) + :short "Build lists of @(see vl-emodwire-p)s for a @(see vl-plainarglist-p)." + ((x vl-plainarglist-p) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :returns + (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (pattern vl-emodwirelistlist-p)) + + :long "We project @(see vl-plainarg-lsb-bits) across a list of arguments, +and cons together the resulting bits to produce an @(see vl-emodwirelistlist-p) +where each sub-list is in LSB-order.
" + + (b* (((when (atom x)) + (mv t (ok) nil)) + ((mv car-successp warnings car-lsb-bits) + (vl-plainarg-lsb-bits (car x) walist warnings)) + ((mv cdr-successp warnings cdr-lsb-pattern) + (vl-plainarglist-lsb-pattern (cdr x) walist warnings))) + (mv (and car-successp cdr-successp) + warnings + (cons car-lsb-bits cdr-lsb-pattern))) + /// + (more-returns + (pattern true-listp :rule-classes :type-prescription) + (pattern true-list-listp))) + + +(define vl-modinst-eocc-bindings + :parents (modinsts-to-eoccs) + :short "Build a (slow) alist binding the \"formals\" for a module to the +\"actuals\" from an instance." + + ((actuals vl-plainarglist-p "Arguments in the module instance.") + + (portpat vl-emodwirelistlist-p + "Port pattern for the module being instanced; see @(see modinsts-to-eoccs). + We assume (in the guard) that it is the same length as the + actuals (i.e., the module instance has the proper arity), but we + still have to check the lengths on the sub-lists.") + + (walist vl-wirealist-p + "Wire alist for the superior module. Used to generate the E wires + for the actuals.") + + (warnings vl-warninglist-p "Warnings accumulator for the superior module.") + (inst vl-modinst-p "Context for warnings, semantically irrelevant.")) + + :guard (and (true-list-listp portpat) + (same-lengthp actuals portpat)) + :returns + (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (binding-alist (and (alistp binding-alist) + (vl-emodwirelist-p (alist-keys binding-alist)) + (vl-emodwirelist-p (alist-vals binding-alist))))) + + (b* (((when (atom actuals)) + (mv t (ok) nil)) + + ((vl-modinst inst) inst) + (expr1 (vl-plainarg->expr (car actuals))) + + ((unless expr1) + ;; Shouldn't happen if we've properly converted blanks to Zs. + (mv nil + (fatal :type :vl-programming-error + :msg "~a0: expected all arguments to be non-blank." + :args (list inst)) + nil)) + + ((mv successp warnings expr1-msb-bits) + (vl-msb-expr-bitlist expr1 walist warnings)) + + ((unless successp) + (mv nil + (fatal :type :vl-bad-instance + :msg "~a0: error generating wires for ~a1." + :args (list inst.loc expr1)) + nil)) + + (formal1-msb-bits (car portpat)) + + ((unless (and (same-lengthp expr1-msb-bits formal1-msb-bits) + (mbt (vl-emodwirelist-p formal1-msb-bits)))) + (b* ((nactuals (length expr1-msb-bits)) + (nformals (length formal1-msb-bits))) + (mv nil + (fatal :type :vl-bad-instance + :msg "~a0: we produced ~x1 wire~s2 for an argument whose ~ + corresponding port has ~x3 wire~s4. ~ + - Argument wires: ~x5; ~ + - Port wires: ~x6." + :args (list inst + nactuals (if (= nactuals 1) "" "s") + nformals (if (= nformals 1) "" "s") + (symbol-list-names expr1-msb-bits) + (symbol-list-names formal1-msb-bits))) + nil))) + + ((mv successp warnings binding-alist) + (vl-modinst-eocc-bindings (cdr actuals) (cdr portpat) + walist warnings inst)) + + (binding-alist (append (pairlis$ formal1-msb-bits expr1-msb-bits) + binding-alist))) + + (mv successp warnings binding-alist)) + /// + (more-returns + (binding-alist true-listp :rule-classes :type-prescription))) + + +; ---------------------------------------------------------------------------- +; +; CONVERTING MODULE INSTANCES INTO E OCCURRENCES +; +; ---------------------------------------------------------------------------- + +(defalist vl-ealist-p (x) + :key (stringp x) + :val (good-esim-modulep x) + :keyp-of-nil nil + :valp-of-nil t + :parents (e-conversion) + :short "Alist binding module names to E modules." + + :long "Our main E conversion transform proceeds in dependency order, so +that the E modules for all submodules should already be available.
+ +A @('vl-ealist-p') is an alist that binds module names to the E modules we +have generated for them. We use it to look up the definitions for submodules. +To make lookups fast, we generally expect it to be a fast alist.
") + + +(define vl-modinst-to-eocc + :parents (modinsts-to-eoccs) + :short "Main function for transforming a Verilog module instance into +an (preliminary) E language occurrence." + + ((x vl-modinst-p + "The module instance that we want to convert into an E occurrence.") + (walist vl-wirealist-p + "The wire alist for the superior module. We use it to build the + wire lists for the actuals.") + (mods vl-modulelist-p + "The list of all modules. Needed so we can look up the submodule + being instantiated, so we can compute its port pattern.") + (modalist (equal modalist (vl-modalist mods)) + "For fast submodule lookups.") + (eal vl-ealist-p + "The already-processed @(see vl-ealist-p) that binds module names + to the E modules we've built for them so far. We use this to + look up the definiton of the submodule for the @(':op') field of + the E occurrence.") + (warnings vl-warninglist-p + "Warnings accumulator for the superior module.")) + :returns + (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (eocc)) + + :long "We do a lot of sanity checking to make sure the module instance is +simple enough to transform, that the submodule exists and was translated into +an E module successfully, etc. Then, we figure out the bindings to use for the +@(':i') and @(':o') fields of the occurrence, as described in @(see +modinsts-to-eoccs).
" + + (b* (((vl-modinst x) x) + + ;; Preliminary sanity checks to make sure this instance is + ;; reasonable. + + ((unless x.instname) + (mv nil + (fatal :type :vl-bad-instance + :msg "~a0: expected all module instances to be named. Did ~ + you run the addinstnames transform?" + :args (list x)) + nil)) + + ((when x.range) + (mv nil + (fatal :type :vl-bad-instance + :msg "~a0: expected only simple module instances, but ~s1 ~ + is an array of module instances. Did you run the ~ + replicate transform?" + :args (list x x.instname)) + nil)) + + ((unless (vl-paramargs-empty-p x.paramargs)) + (mv nil + (fatal :type :vl-bad-instance + :msg "~a0: expected only simple module instances, but ~s1 ~ + still has parameters. Did you run the ~ + unparameterization transform?" + :args (list x x.instname)) + nil)) + + ((when (eq (vl-arguments-kind x.portargs) :vl-arguments-named)) + (mv nil + (fatal :type :vl-bad-instance + :msg "~a0: expected only resolved module instances, but ~ + ~s1 still has named arguments. Did you run the ~ + argresolve transform?" + :args (list x x.instname)) + nil)) + + ;; Look up the submodule, its esim, etc. + + (sub (vl-fast-find-module x.modname mods modalist)) + ((unless sub) + (mv nil + (fatal :type :vl-bad-instance + :msg "~a0 refers to undefined module ~m1." + :args (list x x.modname)) + nil)) + + (sub-esim (cdr (hons-get x.modname eal))) + ((unless sub-esim) + (mv nil + (fatal :type :vl-bad-submodule + :msg "~a0 refers to module ~m1, but we failed to build an ~ + E module for ~m1." + :args (list x x.modname)) + nil)) + + ((mv okp & sub-walist) (vl-module-wirealist sub nil)) + ((unless okp) + (mv nil + (fatal :type :vl-programming-error + :msg "~a0: failed to build a wire alist for ~x0? Jared ~ + thinks this should never happen since we were able ~ + to build the ESIM module for it." + :args (list x.modname)) + nil)) + + ;; Now compute the port pattern for the submodule. + + ((mv successp & portpat) + ;; We ignore the warnings here, because (1) there shouldn't be any + ;; and (2) if there are, it's a problem with the submodule, not with + ;; the superior module. + (vl-portlist-msb-bit-pattern (vl-module->ports sub) sub-walist)) + ((unless successp) + (mv nil + (fatal :type :vl-programming-error + :msg "~a0: failed to build a portlist pattern for module ~ + ~m1. Jared thinks this should never happen because ~ + we check that these lists can be built before trying ~ + to make E occurrences from module instances." + :args (list x x.modname)) + nil)) + + ;; Build the alist binding formals to actuals... + + (actuals (vl-arguments-plain->args x.portargs)) + ((unless (same-lengthp actuals portpat)) + (mv nil + (fatal :type :vl-bad-instance + :msg "~a0: wrong arity. Expected ~x1 arguments but found ~x2." + :args (list x (len portpat) (len actuals))) + nil)) + + ((mv successp warnings binding-alist) + (vl-modinst-eocc-bindings actuals portpat walist warnings x)) + ((unless successp) + ;; Already explained why. + (mv nil warnings nil)) + + + ;; Get the :i and :o patterns to instantiate. It would probably be + ;; reasonable to just look these up from sub-esim. But as an extra + ;; sanity check, we'll go ahead and recompute them, and make sure + ;; everything agrees. Note that vl-portdecls-to-i/o is memoized, so + ;; this should be pretty cheap. + + ((mv successp & in-pat out-pat) + ;; We ignore the warnings here because if there's any problem, it's + ;; a problem with the submodule. + (vl-portdecls-to-i/o (vl-module->portdecls sub) sub-walist)) + ((unless successp) + (mv nil + (fatal :type :vl-programming-error + :msg "~a0: failed to build :i and :o patterns for module ~ + ~m1. Jared thinks this should never happen because ~ + we already built its esim and should have checked ~ + that this was all okay due to port-bit-checking." + :args (list x x.modname)) + nil)) + + ((unless (and (equal in-pat (gpl :i sub-esim)) + (equal out-pat (gpl :o sub-esim)))) + (mv nil + (fatal :type :vl-programming-error + :msg "~a0: the :i and :o patterns we built for ~m1 do ~ + not agree with the :i and :o patterns of its ESIM? ~ + Jared thinks this should never happen because the ~ + patterns should be being built in the same way. ~% ~ + - in-pat: ~x2~% ~ + - found: ~x3~% ~ + - out-pat: ~x4~% ~ + - found: ~x5~%" + :args (list x x.modname in-pat (gpl :i sub-esim) + out-pat (gpl :o sub-esim))) + nil)) + + ;; Instantiate the :i and :o patterns to get the actuals for this + ;; occurrence. + + ((with-fast binding-alist)) + + ;; Extra sanity check, so that we can prove this always builds a good + ;; esim occ. + (all-formal-bits (pat-flatten out-pat (pat-flatten1 in-pat))) + (all-actual-bits (alist-keys binding-alist)) + ((unless (equal (mergesort all-formal-bits) + (mergesort all-actual-bits))) + (mv nil + (fatal :type :vl-programming-error + :msg "~a0: the binding alist we produced doesn't contain ~ + bindings for exactly the right bits. Jared thinks ~ + vl-modinst-to-eocc-bindings should ensure that this ~ + never happens." + :args (list x)) + nil)) + + (inputs (acl2::al->pat in-pat binding-alist nil)) + (outputs (acl2::al->pat out-pat binding-alist nil)) + + ;; Goofy hack to make sure the instance names are unique: + + (instname (vl-plain-wire-name x.instname)) + + (eocc (list* :u instname + :op sub-esim + :o outputs + :i inputs + (if x.atts + (list :a x.atts) + nil)))) + + (mv t (ok) eocc)) + /// + (local (defthm l0 + (implies (vl-emodwirelist-p x) + (equal (atom-listp x) + (true-listp x))) + :hints(("Goal" :induct (len x))))) + + (local (defthm l1 + ;; follows from similar-patternsp-of-al->pat + (implies (and (subsetp-equal (pat-flatten1 pat) (alist-keys al)) + (vl-emodwirelist-p (alist-keys al)) + (vl-emodwirelist-p (alist-vals al))) + (similar-patternsp (al->pat pat al default) pat)))) + + (local (defthm vl-plain-wire-name-under-iff + (vl-plain-wire-name x) + :hints(("Goal" :in-theory (enable (tau-system)))))) + + (defthm good-esim-occp-of-vl-modinst-to-eocc + (let ((ret (vl-modinst-to-eocc x walist mods modalist eal warnings))) + (implies (and (mv-nth 0 ret) + (force (vl-modinst-p x)) + (force (vl-wirealist-p walist)) + (force (vl-modulelist-p mods)) + (force (equal modalist (vl-modalist mods))) + (force (vl-ealist-p eal))) + (good-esim-occp (mv-nth 2 ret)))) + :hints(("Goal" + :in-theory (enable good-esim-occp) + :expand ((:free (a x) (good-esim-occp (cons a x)))))))) + + + +(define vl-modinstlist-to-eoccs + :parents (modinsts-to-eoccs) + :short "Build the preliminary E-language occurrences for a list of module +instances." + + ((x vl-modinstlist-p) + (walist vl-wirealist-p) + (mods vl-modulelist-p) + (modalist (equal modalist (vl-modalist mods))) + (eal vl-ealist-p) + (warnings vl-warninglist-p)) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (eoccs)) + :long "We just extend @(see vl-modinst-to-eocc) across a list.
" + (b* (((when (atom x)) + (mv t (ok) nil)) + ((mv car-successp warnings car-eocc) + (vl-modinst-to-eocc (car x) walist mods modalist eal warnings)) + ((mv cdr-successp warnings cdr-eoccs) + (vl-modinstlist-to-eoccs (cdr x) walist mods modalist eal warnings))) + (mv (and car-successp cdr-successp) + warnings + (cons car-eocc cdr-eoccs))) + /// + (more-returns + (eoccs true-listp :rule-classes :type-prescription)) + + (defthm good-esim-occsp-of-vl-modinstlist-to-eoccs + (let ((ret (vl-modinstlist-to-eoccs x walist mods modalist eal warnings))) + (implies (and (mv-nth 0 ret) + (force (vl-modinstlist-p x)) + (force (vl-wirealist-p walist)) + (force (vl-modulelist-p mods)) + (force (equal modalist (vl-modalist mods))) + (force (vl-ealist-p eal))) + (good-esim-occsp (mv-nth 2 ret)))) + :hints(("Goal" :in-theory (enable good-esim-occsp))))) + diff -Nru acl2-7.0/books/centaur/esim/vltoe/top.lisp acl2-7.1/books/centaur/esim/vltoe/top.lisp --- acl2-7.0/books/centaur/esim/vltoe/top.lisp 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/vltoe/top.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1,539 @@ +; ESIM Symbolic Hardware Simulator +; Copyright (C) 2008-2015 Centaur Technology +; +; Contact: +; Centaur Technology Formal Verification Group +; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA. +; http://www.centtech.com/ +; +; License: (An MIT/X11-style license) +; +; Permission is hereby granted, free of charge, to any person obtaining a +; copy of this software and associated documentation files (the "Software"), +; to deal in the Software without restriction, including without limitation +; the rights to use, copy, modify, merge, publish, distribute, sublicense, +; and/or sell copies of the Software, and to permit persons to whom the +; Software is furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +; DEALINGS IN THE SOFTWARE. +; +; Original author: Jared DavisThe conversion from Verilog to E is mostly straightforward because +here we only try to support an extremely limited subset of Verilog. The basic +idea is that other @(see transforms) should first be used to simplify more +complex, \"original\" input modules into this simple subset.
+ +Here are some basic expectations:
+ +We have checks to ensure our assumptions hold, and these checks will result +in fatal @(see warnings) if the modules contain unsupported constructs. See in +particular @(see vl-module-check-e-ok) and @(see vl-module-check-port-bits).
+ +We process the modules in dependency order, and aside from sanity checking +there are basically two steps for each module we need to convert:
+ +Some final sanity checking is done to ensure that the module's inputs and +outputs are properly marked and there is no \"backflow\" occurring.
+ +The resulting E module for each Verilog module is saved in the @('esim') +field of each @(see vl-module-p).
") + +(local (xdoc::set-default-parents e-conversion)) + +; ----------------------------------------------------------------------------- +; +; Checking for Unsupported Constructs +; +; ----------------------------------------------------------------------------- + +(define vl-has-any-hid-netdecls ((x vl-vardecllist-p)) + :parents (vl-module-check-e-ok) + (cond ((atom x) + nil) + ((assoc-equal "HID" (vl-vardecl->atts (car x))) + t) + (t + (vl-has-any-hid-netdecls (cdr x))))) + +(define vl-module-check-e-ok + :short "Check for unsupported constructs." + ((x vl-module-p) + (warnings vl-warninglist-p)) + :returns (mv (okp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p + :hyp (force (vl-warninglist-p warnings)))) + (b* (((vl-module x) x) + ;; Gather up a message about what unsupported constructs there are. + (acc nil) + ;; We used to check whether there were parameter declarations and fail + ;; if so, because e doesn't really support them directly. But it's + ;; basically harmless to have parameter declarations in your module as + ;; long as they're not used. If unparameterization failed somewhere, it + ;; should have produced a fatal warning, so we don't expect this check + ;; to be necessary. + ;; (acc (if x.paramdecls + ;; (cons (str::join (cons "parameter declarations: " (vl-paramdecllist->names x.paramdecls)) " ") + ;; acc) + ;; acc)) + (acc (if x.fundecls + (cons (str::join (cons "function declarations: " (vl-fundecllist->names x.fundecls)) " ") + acc) + acc)) + (acc (if x.taskdecls + (cons (str::join (cons "task declarations: " (vl-taskdecllist->names x.taskdecls)) " ") + acc) + acc)) + (acc (if x.assigns (cons "assigns" acc) acc)) + (acc (if x.gateinsts (cons "gate instances" acc) acc)) + (acc (if x.alwayses (cons "always blocks" acc) acc)) + ;; We'll allow but ignore initial statements + (acc (if (vl-has-any-hid-netdecls x.vardecls) + (cons "hierarchical identifiers" acc) + acc)) + ;; BOZO BOZO BOZO !!!!! + ;; need to check netdecls for WOR, etc. + + (acc (if (vl-module->ifports x) (cons "interface ports" acc) acc)) + + ((unless acc) + (mv t warnings)) + + (w (make-vl-warning + :type :vl-unsupported + :msg "Failing to build an E module for ~s0 because it still has ~ + ~&1. We generally expect all constructs other than net ~ + declarations and module instances to be simplified away by ~ + other transforms before E module generation." + :args (list x.name acc) + :fatalp t + :fn 'vl-module-check-e-ok))) + (mv nil (cons w warnings)))) + + +; ----------------------------------------------------------------------------- +; +; Adding Design-Wires Annotations +; +; ----------------------------------------------------------------------------- + +(define vl-collect-msb-bits-for-wires + :parents (vl-collect-design-wires) + :short "Append together all the MSB bits for a list of wire names." + ((names string-listp) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :returns (mv (warnings vl-warninglist-p :hyp (vl-warninglist-p warnings)) + (wires vl-emodwirelist-p :hyp (vl-wirealist-p walist))) + (b* (((when (atom names)) + (mv warnings nil)) + (name1 (car names)) + (entry1 (hons-get name1 walist)) + (wires1 (cdr entry1)) + ((mv warnings rest) + (vl-collect-msb-bits-for-wires (cdr names) walist warnings)) + (warnings (if entry1 + warnings + (warn :type :vl-design-wires + :msg "No walist entry for ~s0." + :args (list name1))))) + (mv warnings (append wires1 rest)))) + +(define vl-collect-design-wires + :short "Collect all symbols for design-visible wires and return them as a + flat list of bits." + ((x vl-module-p) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :returns (mv (warnings vl-warninglist-p :hyp (vl-warninglist-p warnings)) + (wires vl-emodwirelist-p :hyp (vl-wirealist-p walist))) + (b* (((when (atom x)) + (mv warnings nil)) + (vars (vl-module->vardecls x)) + (dnets (vl-gather-vardecls-with-attribute vars "VL_DESIGN_WIRE")) + (dnet-names (vl-vardecllist->names dnets))) + (vl-collect-msb-bits-for-wires dnet-names walist warnings))) + + + +; ----------------------------------------------------------------------------- +; +; Top-Level E Conversion +; +; ----------------------------------------------------------------------------- + +(define vl-module-make-esim + :short "Convert a Verilog module into an E module." + + ((x vl-module-p + "The module we want to convert into an E module. We assume that the + module has no unsupported constructs, okay port bits, etc, since these + are checked in @(see vl-modulelist-make-esims).") + (mods vl-modulelist-p + "The list of all modules. Note: this stays fixed as we recur, so the + modules generally here don't have their @('esim') fields filled in + yet.") + (modalist (equal modalist (vl-modalist mods)) + "For fast module lookups.") + (eal vl-ealist-p + "The @(see vl-ealist-p) that we are constructing and extending. This + allows us to look up the E modules for previously processed modules.")) + + :returns + (mv (new-x vl-module-p :hyp (force (vl-module-p x)) + "New version of @('x') with its @('esim') field filled in, + if possible.") + (eal "Extended version of @('eal') with the @('esim') for @('x').")) + + :long "We try to compute the @('esim') for @('x'), install it into @('x'), +and extend @('eal') with the newly produced @('esim').
" + + :prepwork + ((local (defthm c0 + (implies (vl-emodwirelist-p (vl-eocclist-allnames occs)) + (vl-emodwirelist-p (collect-signal-list :o occs))) + :hints(("Goal" :in-theory (enable collect-signal-list + vl-eocclist-allnames + vl-eocc-allnames))))) + + (local (defthm c1 + (implies (vl-emodwirelist-p (vl-eocclist-allnames occs)) + (vl-emodwirelist-p (collect-signal-list :i occs))) + :hints(("Goal" :in-theory (enable collect-signal-list + vl-eocclist-allnames + vl-eocc-allnames))))) + + (local (defthm d0 + (implies (and (force (vl-emodwire-p out)) + (force (vl-emodwire-p name))) + (vl-emodwirelist-p (vl-eocc-allnames (vl-make-z-occ name out)))) + :hints(("Goal" :in-theory (enable vl-make-z-occ + vl-eocc-allnames))))) + + (local (defthm d1 + (implies (and (force (natp idx)) + (force (vl-emodwirelist-p outs))) + (vl-emodwirelist-p (vl-eocclist-allnames (vl-make-z-occs idx outs)))) + :hints(("Goal" :in-theory (enable vl-make-z-occs))))) + + (local (defthm d2 + (implies (and (force (vl-emodwirelist-p (vl-eocclist-allnames occs))) + (force (vl-emodwirelist-p flat-ins)) + (force (vl-emodwirelist-p flat-outs))) + (vl-emodwirelist-p (vl-eocclist-allnames (vl-add-zdrivers all-names flat-ins flat-outs occs)))) + :hints(("Goal" :in-theory (enable vl-add-zdrivers)))))) + + (b* (((vl-module x) x) + + ((when x.esim) + ;; This makes it easy for primitive modules to supply their own esim + (if (good-esim-modulep x.esim) + (mv x (hons-acons x.name x.esim eal)) + (b* ((w (make-vl-warning + :type :vl-bad-esim + :msg "~a0 already has an esim provided, but it does ~ + not even satisfy good-esim-modulep." + :args (list x.name) + :fatalp t + :fn 'vl-module-make-esim))) + ;; Goofy: we throw away the bad E module so that we can + ;; unconditionally prove that if the ESIM field gets filled in, + ;; then it's filled in with a good esim module. + (mv (change-vl-module x + :esim nil + :warnings (cons w x.warnings)) + eal)))) + + (warnings x.warnings) + + ;; Check for unsupported constructs + ((mv okp warnings) (vl-module-check-e-ok x warnings)) + ((unless okp) + (mv (change-vl-module x :warnings warnings) eal)) + + ;; Wire alist + ((mv okp warnings walist) (vl-module-wirealist x warnings)) + ((unless okp) + (er hard? 'vl-module-make-esim + "Wire-alist construction failed? Shouldn't be possible: we ~ + should have already done this in vl-module-check-port-bits.") + (mv x eal)) + + ;; Build Name for :n + (starname (vl-starname x.name)) + + ;; Build Patterns for :i and :o + ((mv okp & in out) + (vl-portdecls-to-i/o x.portdecls walist)) + ((unless okp) + (er hard? 'vl-module-make-esim + "Portdecl i/o pattern construction failed? Shouldn't be ~ + possible: we should have already done this in ~ + vl-module-check-port-bits.") + (mv x eal)) + (flat-in (pat-flatten1 in)) + (flat-out (pat-flatten1 out)) + (flat-ios (append flat-in flat-out)) + + ;; Build preliminary :occs + ((mv okp warnings occs) + (vl-modinstlist-to-eoccs x.modinsts walist mods modalist eal warnings)) + ((unless okp) + ;; Should have already explained why + (mv (change-vl-module x :warnings warnings) eal)) + + ;; BOZO eventually add a check for cross-connected outputs that are + ;; being read inside their modules. + + + ;; Collect up all the names used in :I, :O, and throughout :OCCS in + ;; their :I and :O patterns, and in their :U patterns. + (all-names (vl-eocclist-allnames-exec occs flat-ios)) + ((unless (vl-emodwirelist-p all-names)) + (er hard? 'vl-module-make-esim + "Found names that are not emodwires in the list of allnames? ~ + This shouldn't be possible because of how the occurrences and ~ + i/o patterns are constructed.") + (mv x eal)) + + ;; Note that after adding Z drivers, all-names is still "good enough" + ;; after we add zdrivers. This is because we only add wires named + ;; vl_zdrive[k], and in the add-res-modules pass we know these wires + ;; are okay. + (occs (vl-add-zdrivers all-names flat-in flat-out occs)) + + ;; Extra sanity check to make sure T and F aren't driven. BOZO + ;; probably kind of expensive. + ((when (let ((driven-sigs (collect-signal-list :o occs))) + (or (member 'acl2::t driven-sigs) + (member 'acl2::f driven-sigs)))) + (b* ((w (make-vl-warning + :type :vl-output-constant + :msg "In ~a0, somehow we have occurrences driving the ~ + wires T and F. Is this module somehow trying to ~ + drive a value onto a constant or something?" + :args (list x.name) + :fatalp t + :fn 'vl-module-make-esim))) + (mv (change-vl-module x :warnings (cons w warnings)) eal))) + + ;; Special hack to drive T and F. BOZO eventually it'd be nicer to + ;; have a proper VL transform that eliminates constants, similar to + ;; weirdint elimination. + ((when (or (member 'acl2::vl-driver-for-constant-t all-names) + (member 'acl2::vl-driver-for-constant-f all-names))) + (b* ((w (make-vl-warning + :type :vl-name-clash + :msg "~a0 contains a wire named vl-driver-for-constant-t or ~ + vl-driver-for-constant-f, so we're dying badly." + :args (list x.name) + :fatalp t + :fn 'vl-module-make-esim))) + (mv (change-vl-module x :warnings (cons w warnings)) eal))) + + (occs (list* (list :u 'acl2::vl-driver-for-constant-t + :op acl2::*esim-t* + :i nil + :o '((acl2::t))) + (list :u 'acl2::vl-driver-for-constant-f + :op acl2::*esim-f* + :i nil + :o '((acl2::f))) + occs)) + + + ;; Adding the T/F wires and drivers doesn't invalidate all-names, + ;; since none of the names we've added are of the form vl_res[k]. + ;; Hence, it's okay to add RES modules now. + (occs (vl-add-res-modules all-names occs)) + + ;; Probably unnecessary (and perhaps somewhat expensive) sanity check + ;; to make sure everything does indeed have only one driver. + (driven-sigs (collect-signal-list :o occs)) + ((unless (uniquep driven-sigs)) + (b* ((w (make-vl-warning + :type :vl-programming-error + :msg "~a0: after resolving multiply driven wires, we ~ + somehow have multiple drivers for ~&1." + :args (list x.name (duplicated-members driven-sigs)) + :fatalp t + :fn 'vl-module-make-esim))) + (mv (change-vl-module x :warnings (cons w warnings)) eal))) + + (in-driven (intersect (mergesort driven-sigs) (mergesort flat-in))) + ((when in-driven) + (b* ((w (make-vl-warning + :type :vl-backflow + :msg "~a0: input bits ~&1 are being driven from within ~ + the module!" + :args (list x.name (vl-verilogify-emodwirelist in-driven)) + :fatalp t + :fn 'vl-module-make-esim))) + (mv (change-vl-module x :warnings (cons w warnings)) eal))) + + ((mv warnings dwires) (vl-collect-design-wires x walist warnings)) + + (esim (list :n starname + :i in + :o out + :occs occs + :a (list (cons :design-wires dwires) + (cons :wire-alist walist)))) + + ((unless (good-esim-modulep esim)) + ;; BOZO could eventually try to prove some of this away + (b* (((cons details args) (bad-esim-modulep esim)) + (w (make-vl-warning + :type :vl-programming-error + :msg (cat x.name ": failed to make a good esim module. " + "Details: " details) + :args args + :fatalp t + :fn 'vl-module-make-esim))) + (mv (change-vl-module x :warnings (cons w warnings)) eal))) + + (x-prime (change-vl-module x + :warnings warnings + :esim esim)) + + (eal (hons-acons x.name esim eal))) + (mv x-prime eal)) + + /// + + + (defthm vl-module->name-of-vl-module-make-esim + (let ((ret (vl-module-make-esim x mods modalist eal))) + (equal (vl-module->name (mv-nth 0 ret)) + (vl-module->name x)))) + + (defthm good-esim-modulep-of-vl-module-make-esim + (let ((ret (vl-module-make-esim x mods modalist eal))) + (implies (and (vl-module->esim (mv-nth 0 ret)) ;; "success" + (force (vl-module-p x)) + (force (vl-ealist-p eal))) + (good-esim-modulep + (vl-module->esim (mv-nth 0 ret)))))) + + (defthm vl-ealist-p-vl-module-make-esim + (let ((ret (vl-module-make-esim x mods modalist eal))) + (implies (and (force (vl-module-p x)) + (force (vl-ealist-p eal))) + (vl-ealist-p (mv-nth 1 ret)))))) + + +(define vl-modulelist-make-esims + :short "Extend @(see vl-module-make-esim) across a list of modules." + ((x vl-modulelist-p) + (mods vl-modulelist-p) + (modalist (equal modalist (vl-modalist mods))) + (eal vl-ealist-p)) + :returns (mv (new-x vl-modulelist-p :hyp (force (vl-modulelist-p x))) + (eal vl-ealist-p :hyp (and (vl-modulelist-p x) + (vl-ealist-p eal)))) + (b* (((when (atom x)) + (mv nil eal)) + ((mv car eal) (vl-module-make-esim (car x) mods modalist eal)) + ((mv cdr eal) (vl-modulelist-make-esims (cdr x) mods modalist eal))) + (mv (cons car cdr) eal)) + /// + (defmvtypes vl-modulelist-make-esims (true-listp nil)) + + (defthm vl-modulelist->names-of-vl-modulelist-make-esims + (let ((ret (vl-modulelist-make-esims x mods modalist eal))) + (equal (vl-modulelist->names (mv-nth 0 ret)) + (vl-modulelist->names x))))) + + + +(define vl-design-to-e-check-ports ((x vl-design-p)) + :returns (new-x vl-design-p) + :short "Make sure that the module port/port-declarations agree and that there + are no unsupported constructs." + (b* (((vl-design x) (vl-design-fix x)) + (mods (vl-modulelist-check-port-bits x.mods))) + (change-vl-design x :mods mods))) + +(define vl-design-to-e-main ((x vl-design-p)) + :returns (new-x vl-design-p) + (b* (((vl-design x) (vl-design-fix x)) + (mods x.mods) + (modalist (vl-modalist mods)) + ((mv mods eal) (vl-modulelist-make-esims mods mods modalist nil))) + (fast-alist-free eal) + (fast-alist-free modalist) + (clear-memoize-table 'vl-make-n-bit-res-module) + (clear-memoize-table 'vl-portdecls-to-i/o) + (clear-memoize-table 'vl-portlist-msb-bit-pattern) + (clear-memoize-table 'vl-module-wirealist) + (change-vl-design x :mods mods))) + +(define vl-design-to-e ((good vl-design-p) + (bad vl-design-p)) + :short "Top-level function for E conversion." + :returns (mv (good vl-design-p) + (bad vl-design-p)) + (b* ((good (vl-design-to-e-check-ports good)) + (bad (vl-design-fix bad)) + + ((mv good bad) (vl-design-propagate-errors good bad)) + ((mv okp good) (vl-design-deporder-modules good)) + ((unless okp) + (raise "Somehow failed to dependency order sort the modules.") + (mv good bad)) + + (good (vl-design-to-e-main good)) + ((mv good bad) (vl-design-propagate-errors good bad))) + (mv good bad))) diff -Nru acl2-7.0/books/centaur/esim/vltoe/verilogify.lisp acl2-7.1/books/centaur/esim/vltoe/verilogify.lisp --- acl2-7.0/books/centaur/esim/vltoe/verilogify.lisp 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/vltoe/verilogify.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1,260 @@ +; ESIM Symbolic Hardware Simulator +; Copyright (C) 2008-2015 Centaur Technology +; +; Contact: +; Centaur Technology Formal Verification Group +; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA. +; http://www.centtech.com/ +; +; License: (An MIT/X11-style license) +; +; Permission is hereby granted, free of charge, to any person obtaining a +; copy of this software and associated documentation files (the "Software"), +; to deal in the Software without restriction, including without limitation +; the rights to use, copy, modify, merge, publish, distribute, sublicense, +; and/or sell copies of the Software, and to permit persons to whom the +; Software is furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +; DEALINGS IN THE SOFTWARE. +; +; Original author: Jared Davis@(call vl-verilogify-merged-indices) takes @('name'), which should +be a string, and @('x'), a @('vl-merged-index-list-p') such as @(see +vl-merge-contiguous-indices) generates. It produces a list of strings that +represent the Verilog bit- and part-selects of these indices from @('name'). +For instance,
+ +@({ + (vl-verilogify-merged-indices \"foo\" '(1 (3 . 6) 8)) + --> + (\"foo[1]\" \"foo[6:3]\" \"foo[8]\") +})" + + (local (in-theory (enable vl-merged-index-p))) + + (defund vl-verilogify-merged-indices (name x) + (declare (xargs :guard (and (stringp name) + (vl-merged-index-list-p x)))) + (if (atom x) + nil + (cons + (cond ((not (car x)) + ;; A nil index means the whole wire. + name) + ((natp (car x)) + ;; A single index, name[i] + (cat name "[" (natstr (car x)) "]")) + ((consp (car x)) + ;; A merged range, (low . high) + (let ((low (caar x)) + (high (cdar x))) + (cat name "[" (natstr high) ":" (natstr low) "]")))) + (vl-verilogify-merged-indices name (cdr x))))) + + (local (in-theory (enable vl-verilogify-merged-indices))) + + (defthm string-listp-of-vl-verilogify-merged-indices + (implies (and (force (stringp name)) + (force (vl-merged-index-list-p x))) + (string-listp (vl-verilogify-merged-indices name x))))) + + + + +(defund vl-verilogify-emodwirelist-2 (name x) +; Returns (MV NAME-INDICES REST-X) +; NAME-INDICES: indices of all wires with NAME at the front of the list. +; REST-X: remainder of X after the wires with this NAME. + (declare (xargs :guard (and (stringp name) + (vl-emodwirelist-p x)))) + (cond ((atom x) + (mv nil x)) + ((equal name (vl-emodwire->basename (car x))) + (mv-let (matches2 rest) + (vl-verilogify-emodwirelist-2 name (cdr x)) + (mv (cons (vl-emodwire->index (car x)) matches2) rest))) + (t + (mv nil x)))) + +(defthm vl-verilogify-emodwirelist-2-basics + (implies (and (force (stringp name)) + (force (vl-emodwirelist-p x))) + (let ((result (vl-verilogify-emodwirelist-2 name x))) + (and (vl-maybe-nat-listp (mv-nth 0 result)) + (vl-emodwirelist-p (mv-nth 1 result))))) + :hints(("Goal" :in-theory (enable vl-verilogify-emodwirelist-2)))) + +(defthm acl2-count-of-vl-verilogify-emodwirelist-2-weak + (<= (acl2-count (mv-nth 1 (vl-verilogify-emodwirelist-2 name x))) + (acl2-count x)) + :rule-classes ((:rewrite) (:linear)) + :hints(("Goal" :in-theory (enable vl-verilogify-emodwirelist-2)))) + +(defthm acl2-count-of-vl-verilogify-emodwirelist-2-strong + (implies (and (consp x) + (equal name (vl-emodwire->basename (car x)))) + (< (acl2-count (mv-nth 1 (vl-verilogify-emodwirelist-2 name x))) + (acl2-count x))) + :rule-classes ((:rewrite) (:linear)) + :hints(("Goal" :in-theory (enable vl-verilogify-emodwirelist-2)))) + + + +(defund vl-verilogify-emodwirelist-1 (name x) + ;; Returns (MV STRING-LIST REST-X) + (declare (xargs :guard (and (stringp name) + (vl-emodwirelist-p x)))) + (b* (((mv indices rest-x) + (vl-verilogify-emodwirelist-2 name x)) + (merged-indices (vl-merge-contiguous-indices indices)) + (verilog-names + (vl-verilogify-merged-indices name merged-indices))) + (mv verilog-names rest-x))) + +(defthm vl-verilogify-emodwirelist-1-basics + (implies (and (force (stringp name)) + (force (vl-emodwirelist-p x))) + (let ((result (vl-verilogify-emodwirelist-1 name x))) + (and (string-listp (mv-nth 0 result)) + (vl-emodwirelist-p (mv-nth 1 result))))) + :hints(("Goal" :in-theory (enable vl-verilogify-emodwirelist-1)))) + +(defthm acl2-count-of-vl-verilogify-emodwirelist-1-weak + (<= (acl2-count (mv-nth 1 (vl-verilogify-emodwirelist-1 name x))) + (acl2-count x)) + :rule-classes ((:rewrite) (:linear)) + :hints(("Goal" :in-theory (enable vl-verilogify-emodwirelist-1)))) + +(defthm acl2-count-of-vl-verilogify-emodwirelist-1-strong + (implies (and (consp x) + (equal name (vl-emodwire->basename (car x)))) + (< (acl2-count (mv-nth 1 (vl-verilogify-emodwirelist-1 name x))) + (acl2-count x))) + :rule-classes ((:rewrite) (:linear)) + :hints(("Goal" :in-theory (enable vl-verilogify-emodwirelist-1)))) + + +(defund vl-verilogify-emodwirelist-0 (x) + ;; Returns a string list + ;; We assume X is already sorted. + (declare (xargs :guard (vl-emodwirelist-p x))) + (if (atom x) + nil + (b* ((name (vl-emodwire->basename (car x))) + ((mv first-strings rest-x) + (vl-verilogify-emodwirelist-1 name x)) + (rest-strings + (vl-verilogify-emodwirelist-0 rest-x))) + (append first-strings rest-strings)))) + +(defthm string-listp-of-vl-verilogify-emodwirelist-0 + (implies (force (vl-emodwirelist-p x)) + (string-listp (vl-verilogify-emodwirelist-0 x))) + :hints(("Goal" :in-theory (enable vl-verilogify-emodwirelist-0)))) + + +(defsection vl-verilogify-emodwirelist + :parents (vl-wirealist-p) + :short "Merge a list of @(see vl-emodwire-p)s into Verilog-style names." + + (defund vl-verilogify-emodwirelist (x) + (declare (xargs :guard (vl-emodwirelist-p x))) + (vl-verilogify-emodwirelist-0 (vl-emodwire-sort (redundant-list-fix x)))) + + (defthm string-listp-of-vl-verilogify-emodwirelist + (implies (force (vl-emodwirelist-p x)) + (string-listp (vl-verilogify-emodwirelist x))) + :hints(("Goal" :in-theory (enable vl-verilogify-emodwirelist)))) + + (local + (assert! (equal + (vl-verilogify-emodwirelist + #!ACL2 + '(|foo[0]| |bar[18]| |foo[3]| |bar[0]| + |foo[4]| |foo[5]| |bar[5]| |bar[17]|)) + (list "bar[0]" "bar[5]" "bar[18:17]" + "foo[0]" "foo[5:3]"))))) + + + +(defund vl-verilogify-symbols (x) + (declare (xargs :guard (symbol-listp x))) + (if (vl-emodwirelist-p x) + (vl-verilogify-emodwirelist x) + (prog2$ + (cw "Note: in vl-verilogify-symbols, symbols are not all emod wires!~%") + (symbol-list-names x)))) + +(defthm string-listp-of-vl-verilogify-symbols + (implies (force (symbol-listp x)) + (string-listp (vl-verilogify-symbols x))) + :hints(("Goal" :in-theory (enable vl-verilogify-symbols)))) + diff -Nru acl2-7.0/books/centaur/esim/vltoe/wirealist.lisp acl2-7.1/books/centaur/esim/vltoe/wirealist.lisp --- acl2-7.0/books/centaur/esim/vltoe/wirealist.lisp 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/vltoe/wirealist.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1,1370 @@ +; ESIM Symbolic Hardware Simulator +; Copyright (C) 2008-2015 Centaur Technology +; +; Contact: +; Centaur Technology Formal Verification Group +; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA. +; http://www.centtech.com/ +; +; License: (An MIT/X11-style license) +; +; Permission is hereby granted, free of charge, to any person obtaining a +; copy of this software and associated documentation files (the "Software"), +; to deal in the Software without restriction, including without limitation +; the rights to use, copy, modify, merge, publish, distribute, sublicense, +; and/or sell copies of the Software, and to permit persons to whom the +; Software is furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +; DEALINGS IN THE SOFTWARE. +; +; Original author: Jared DavisA wire alist provides a bit-level view of the wires in a module by +associating the names of each net and register declared in the Verilog +module (strings) with lists of @(see vl-emodwire-p)s that represent the +individual bits of the wire, in msb-first order.
+ +In particular,
+ +Our @(see vl-emodwire-p) representation is robust and can reliably deal with +wires no matter what their names. We can guarantee that the bits produced in a +wire alist are unique as long as the net and register declarations for the +module are uniquely named.
+ +We take special care to avoid generating the names @('T'), @('NIL'), and +@('F'), since these have a special special meaning in Emod; see @(see +vl-plain-wire-name).
+ +Profiling might \"unfairly\" suggest that wire-alist construction is very +expensive.
+ +In particular, the first time we build a wire alist for a module, we are +generally doing \"first-time\" @('intern')s for the names of every bit. It is +far more expensive to @('intern') a string for the first time than to +subsequently @('intern') it again. For instance, when we run the following +code in a fresh CCL session, we find that it takes 2.2 seconds to intern +100,000 fresh strings the first time, but it only takes 0.15 seconds to intern +them all again.
+ +@({ + (defpackage \"FOO\" (:use)) + + (ccl::egc nil) + + (defparameter *strings* + (loop for i fixnum from 1 to 100000 + collect + (concatenate 'string \"FOO-\" + (format nil \"~a\" i)))) + + ;; 2.21 seconds, 15 MB allocated + (time (loop for str in *strings* do (intern str \"FOO\"))) + + ;; 0.15 seconds, no allocation + (time (loop for str in *strings* do (intern str \"FOO\"))) +}) + +When we are interning millions of symbols, the package's size also has a +huge impact on interning performance. Because of this, we typically build ACL2 +with @('ACL2_SIZE=3000000') to avoid very slow interning.
+ +Moreover, whether we intern these symbols \"eagerly\" by constructing a wire +alist or \"lazily\" as they are needed, we will end up doing the same number of +first-time interns. There is not really any way to avoid this interning +without either fundamentally changing the design of the E language (e.g., to +support vectors), or abandoning named wires in E modules (e.g., using numbers +instead).
" + +;; bozo switch to defalist? + + (if (atom x) + t + (and (consp (car x)) + (stringp (caar x)) + (true-listp (cdar x)) ;; bozo why do we care? + (vl-emodwirelist-p (cdar x)) + (vl-wirealist-p (cdr x)))) + /// + (defthm vl-wirealist-p-when-atom + (implies (atom x) + (equal (vl-wirealist-p x) + t))) + + (defthm vl-wirealist-p-of-cons + (equal (vl-wirealist-p (cons a x)) + (and (consp a) + (stringp (car a)) + (true-listp (cdr a)) + (vl-emodwirelist-p (cdr a)) + (vl-wirealist-p x)))) + + (defthm cons-listp-when-vl-wirealist-p + (implies (vl-wirealist-p x) + (cons-listp x))) + + (defthm vl-wirealist-p-of-hons-shrink-alist + (implies (and (vl-wirealist-p x) + (vl-wirealist-p y)) + (vl-wirealist-p (hons-shrink-alist x y))) + :hints(("Goal" :in-theory (enable (:i hons-shrink-alist))))) + + (defthm vl-emodwirelist-p-of-cdr-of-hons-assoc-equal-when-vl-wirealist-p + (implies (vl-wirealist-p walist) + (vl-emodwirelist-p (cdr (hons-assoc-equal name walist))))) + + (defthm true-listp-of-cdr-of-hons-assoc-equal-when-vl-wirealist-p + (implies (vl-wirealist-p walist) + (true-listp (cdr (hons-assoc-equal name walist)))))) + + + +(define vl-plain-wire-name ((name stringp)) + :returns (emodwire vl-emodwire-p) + :parents (vl-wirealist-p) + :short "@(call vl-plain-wire-name) is given @('name'), a string, and +typically returns the symbol @('ACL2::name')." + + :long "Typically, for a wire named @('foo'), we generate the symbol +@('ACL2::|foo|'). But there are three special cases.
+ +The symbols @('ACL2::T') and @('ACL2::F') were historically given a special +interpretation by the EMOD hardware simulator, and represented the constant +true and false functions. These wires no longer have a special meaning in +ESIM, but throughout VL our notion of emodwires still assumes that T and F +stand for constant true and false, and, e.g., we still rely on this in @(see +e-conversion). We might eventually get away from this by using a transform +analagous to @(see weirdint-elim) to introduce T/F wires and eliminate +constants.
+ +The symbol @('ACL2::NIL') is also special, but for a different and more +fundamental reason: NIL has a special meaning in @(see acl2::patterns), so to +make sure that every @(see vl-emodwire-p) is a good atom in the sense of +patterns, we do not allow NIL to even be an emodwire.
+ +At any rate, if we encounter a Verilog wire named @('T'), @('F'), or +@('NIL'), we must use some other name. What other name should we use? We want +to pick something that will not clash with other wire names, but which reflects +the original name of the wire.
+ +We have chosen to use @('T[0]'), @('F[0]'), and @('NIL[0]') as the +replacements. This should not be too confusing since, e.g., in Verilog +@('T[0]') is typically a valid way to reference a wire named @('T').
" + +; Performance comparison: +; Logic: 6.286, 6.285, 6.298 +; Exec: 5.291, 5.232, 5.232 + + #|| + (prog2$ (gc$) + (time$ + (loop for i fixnum from 1 to 10000000 do + (vl2014::vl-plain-wire-name "looksLikeAVerilogWire")))) + ||# + + :inline t + + (mbe :logic + (cond ((equal name "T") + (make-vl-emodwire :basename "T" :index 0)) + ((equal name "F") + (make-vl-emodwire :basename "F" :index 0)) + ((equal name "NIL") + (make-vl-emodwire :basename "NIL" :index 0)) + (t + (make-vl-emodwire :basename (string-fix name) :index nil))) + :exec + (let ((len (length name))) + (cond ((and (= len 1) + (eql (char name 0) #\T)) + (make-vl-emodwire :basename "T" :index 0)) + ((and (= len 1) + (eql (char name 0) #\F)) + (make-vl-emodwire :basename "F" :index 0)) + ((and (= len 3) + (eql (char name 0) #\N) + (eql (char name 1) #\I) + (eql (char name 2) #\L)) + (make-vl-emodwire :basename "NIL" :index 0)) + (t + (make-vl-emodwire :basename name :index nil))))) + + :guard-hints(("Goal" :in-theory (disable str::explode-under-iff))) + :prepwork + ((local (defthm equal-string-constant + (implies (and (syntaxp (quotep name)) + (stringp name)) + (equal (equal x name) + (and (stringp x) + (equal (explode x) (explode name))))) + :hints(("Goal" + :in-theory (disable str::implode-of-explode) + :use ((:instance str::implode-of-explode (str::x x)) + (:instance str::implode-of-explode (str::x name))))))) + + (local (defthm open-equal-len + (implies (syntaxp (quotep n)) + (equal (equal (len x) n) + (if (zp n) + (and (= n 0) + (atom x)) + (and (consp x) + (equal (len (cdr x)) (- n 1)))))) + :hints(("Goal" :in-theory (enable len))))) + + (local (defthm open-nth + (implies (syntaxp (quotep n)) + (equal (nth n x) + (if (zp n) + (car x) + (nth (- n 1) (cdr x))))) + :hints(("Goal" :in-theory (enable nth))))) + + (local (in-theory (enable len))))) + + + +(defsection vl-emodwires-from-high-to-low + :parents (vl-wirealist-p) + :short "@(call vl-emodwires-from-high-to-low) returns a list of @(see +vl-emodwire-p)s: @('(name[high] name[high-1] ... name[low])')" + + :long "The range is inclusive on both sides, so if @('low') and @('high') +are the same you still get one wire.
" + + ;; Here's a stupid performance testing loop. It's somewhat sensitive to + ;; how full the ACL2 package is. The times below were gathered in a fresh + ;; session that had just loaded the book up until here. + + #|| + (progn (gc$) + (time$ + (loop for i from 1 to 1000000 do + (vl2014::vl-emodwires-from-high-to-low "aTypicalWireName" 7 0)))) + ||# + + ;; On fv-1, after adding fast-cat: + ;; - Original version: 5.223 seconds, 896 MB + ;; - Tail-recursive version: 5.094 seconds, 896 MB + ;; - Tail-recursive, pre-encode names: 4.601 seconds, 896 MB + ;; + ;; So we're only 1.13x faster than the simple implementation. + ;; + ;; Note that the above loop interns 8 million symbols, which seems to + ;; take 3.33 seconds all by itself: + + #|| + (progn (gc$) + (time$ + (loop for i from 1 to 8000000 do + (intern "aTypicalWireName" "ACL2")))) + ||# + + ;; I don't really see a good way to do any better. I tried making it faster + ;; using raw-lisp code that would reuse a character array, but this caused + ;; problems in CCL. Looking at the CLHS documentation for "intern", it looks + ;; like changing the contents of the string you've interned is undefined, so I + ;; guess it's just not a valid optimization. + + (defund vl-emodwires-from-high-to-low-aux (name high low acc) + ;; Name must be pre-encoded. + (declare (type string name) + (xargs :guard (and (natp high) + (natp low) + (>= high low)) + :measure (nfix (- (nfix high) (nfix low))))) + (b* ((name[low] (vl-emodwire-encoded name low)) + (acc (cons name[low] acc)) + ((when (mbe :logic (<= (nfix high) (nfix low)) + :exec (= high low))) + acc)) + (vl-emodwires-from-high-to-low-aux name + (lnfix high) + (+ 1 (lnfix low)) + acc))) + + (definlined vl-emodwires-from-high-to-low-aux-fixnum (name high low acc) + ;; Fixnum and otherwise optimized version of the above. + (declare (type string name) + (type (unsigned-byte 32) high) + (type (unsigned-byte 32) low) + (xargs :guard (>= high low) + :guard-hints(("Goal" :in-theory (enable vl-emodwire-encoded))) + :measure (nfix (- (nfix high) + (nfix low))))) + (b* ((name[low] (mbe :logic (vl-emodwire-encoded name low) + :exec (if (< (the (unsigned-byte 32) low) 256) + (intern (cat name + (aref1 '*vl-indexed-wire-name-array* + *vl-indexed-wire-name-array* + low)) + "ACL2") + (intern (cat name "[" (natstr low) "]") + "ACL2")))) + (acc (cons name[low] acc)) + ((when (mbe :logic (<= (nfix high) (nfix low)) + :exec (= (the (unsigned-byte 32) high) + (the (unsigned-byte 32) low)))) + acc)) + (vl-emodwires-from-high-to-low-aux-fixnum name + (lnfix high) + (mbe :logic (+ 1 (nfix low)) + :exec (the (unsigned-byte 32) + (+ low 1))) + acc))) + + (local (defthm vl-emodwires-from-high-to-low-aux-fixnum-removal + (equal (vl-emodwires-from-high-to-low-aux-fixnum name high low acc) + (vl-emodwires-from-high-to-low-aux name high low acc)) + :hints(("Goal" :in-theory (enable vl-emodwires-from-high-to-low-aux-fixnum + vl-emodwires-from-high-to-low-aux))))) + + (defund vl-emodwires-from-high-to-low (name high low) + (declare (type string name) + (xargs :guard (and (natp high) + (natp low) + (>= high low)) + :measure (nfix (- (nfix high) (nfix low))))) + (mbe :logic + (vl-emodwires-from-high-to-low-aux (vl-emodwire-encode (string-fix name)) + (nfix high) + (nfix low) + nil) + :exec + (let ((name (vl-emodwire-encode name))) + (if (< high (expt 2 30)) + (vl-emodwires-from-high-to-low-aux-fixnum name high low nil) + (vl-emodwires-from-high-to-low-aux name high low nil))))) + + (local (assert! + ;; Basic sanity check, handy when mucking with the definition + (and (equal (vl-emodwires-from-high-to-low "foo" 5 0) + #!ACL2 '(|foo[5]| |foo[4]| |foo[3]| |foo[2]| |foo[1]| |foo[0]|)) + (equal (vl-emodwires-from-high-to-low "foo" 5 3) + #!ACL2 '(|foo[5]| |foo[4]| |foo[3]|)) + (equal (vl-emodwires-from-high-to-low "foo" 5 5) + #!ACL2 '(|foo[5]|))))) + + + + (local (defun simpler-aux-function (name high low acc) + (declare (xargs :measure (nfix (- (nfix high) (nfix low))))) + (b* ((name[low] (make-vl-emodwire :basename name :index low)) + (acc (cons name[low] acc)) + ((when (<= (nfix high) (nfix low))) + acc)) + (simpler-aux-function name (nfix high) (+ 1 (nfix low)) acc)))) + + (local (defthm vl-emodwires-from-high-to-low-aux-removal + (equal (vl-emodwires-from-high-to-low-aux (vl-emodwire-encode name) high low acc) + (simpler-aux-function name high low acc)) + :hints(("Goal" :in-theory (enable vl-emodwires-from-high-to-low-aux + vl-emodwire-is-vl-emodwire-exec + vl-emodwire-exec))))) + + (local (defthm true-listp-of-simpler-aux-function + (implies (true-listp acc) + (true-listp (simpler-aux-function name high low acc))) + :rule-classes :type-prescription)) + + (local (defthm vl-emodwirelist-p-of-simpler-aux-function + (implies (and (force (vl-emodwirelist-p acc)) + (force (stringp name)) + (force (natp high)) + (force (natp low))) + (vl-emodwirelist-p (simpler-aux-function name high low acc))))) + + (local (defthm len-of-simpler-aux-function + (equal (len (simpler-aux-function name high low acc)) + (+ 1 + (nfix (- (nfix high) (nfix low))) + (len acc))))) + + (local (defthm cons-same-onto-replicate + (equal (cons a (replicate n a)) + (replicate (+ 1 (nfix n)) a)) + :hints(("Goal" :in-theory (enable replicate))))) + + (local (defthm vl-emodwirelist->basenames-of-simpler-aux-function + (implies (and (stringp name) + (natp high) + (natp low)) + (equal (vl-emodwirelist->basenames (simpler-aux-function name high low acc)) + (append (replicate (+ 1 (nfix (- (nfix high) (nfix low)))) name) + (vl-emodwirelist->basenames acc)))) + :hints(("Goal" :do-not '(generalize fertilize))))) + + (local (defthm member-equal-of-indicies-of-simpler-aux-function + (implies (and (stringp name) + (natp high) + (natp low) + (>= high low)) + (iff (member-equal idx (vl-emodwirelist->indices + (simpler-aux-function name high low acc))) + (or (and (natp idx) + (<= low idx) + (<= idx high)) + (member-equal idx (vl-emodwirelist->indices acc))))) + :hints(("Goal" :in-theory (disable (force)))))) + + (local (defun nats-from (low high) + (declare (xargs :measure (nfix (- (nfix high) (nfix low))))) + (if (zp (- (nfix high) (nfix low))) + (list (nfix low)) + (cons (nfix low) + (nats-from (+ 1 (nfix low)) (nfix high)))))) + + (local (defthm member-equal-of-nats-from + (implies (and (natp low) + (natp high) + (<= low high)) + (iff (member-equal idx (nats-from low high)) + (and (natp idx) + (<= (nfix low) idx) + (<= idx (nfix high))))) + :hints(("Goal" :induct (nats-from low high))))) + + (local (defthm unique-indicies-of-simpler-aux-function + (implies (and (stringp name) + (natp high) + (natp low) + (no-duplicatesp-equal (vl-emodwirelist->indices acc)) + (not (intersectp-equal (vl-emodwirelist->indices acc) + (nats-from low high)))) + (no-duplicatesp-equal + (vl-emodwirelist->indices + (simpler-aux-function name high low acc)))) + :hints(("Goal" :in-theory (disable (force)))))) + + (local (in-theory (enable vl-emodwires-from-high-to-low))) + + (defthm true-listp-of-vl-emodwires-from-high-to-low + (true-listp (vl-emodwires-from-high-to-low name high low)) + :rule-classes :type-prescription) + + (defthm vl-emodwirelist-p-of-vl-emodwires-from-high-to-low + (vl-emodwirelist-p (vl-emodwires-from-high-to-low name high low))) + + (defthm basenames-of-vl-emodwires-from-high-to-low + (equal (vl-emodwirelist->basenames (vl-emodwires-from-high-to-low name high low)) + (replicate (len (vl-emodwires-from-high-to-low name high low)) + (string-fix name)))) + + (defthm member-equal-of-indicies-of-vl-emodwires-from-high-to-low + (implies (>= (nfix high) (nfix low)) + (iff (member-equal idx (vl-emodwirelist->indices + (vl-emodwires-from-high-to-low name high low))) + (and (natp idx) + (<= (nfix low) idx) + (<= idx (nfix high)))))) + + (defthm unique-indicies-of-vl-emodwires-from-high-to-low + (no-duplicatesp-equal + (vl-emodwirelist->indices + (vl-emodwires-from-high-to-low name high low)))) + + (local (defthm d0 + (implies (no-duplicatesp-equal (vl-emodwirelist->indices x)) + (no-duplicatesp-equal x)) + :hints(("Goal" :in-theory (enable vl-emodwirelist->indices))))) + + (defthm no-duplicatesp-equal-of-vl-emodwires-from-high-to-low + (no-duplicatesp-equal (vl-emodwires-from-high-to-low name high low))) + + (defthm len-of-vl-emodwires-from-high-to-low + (equal (len (vl-emodwires-from-high-to-low name high low)) + (+ 1 (nfix (- (nfix high) (nfix low))))))) + + + + +(define vl-emodwires-from-msb-to-lsb + :parents (vl-wirealist-p) + :short "@(call vl-emodwires-from-msb-to-lsb) returns a list of @(see +vl-emodwire-p)s: @('(name[msb] name[msb +/- 1] ... name[lsb])')" + ((name stringp) + (msb natp) + (lsb natp)) + :long "The range is inclusive on both sides, so if @('msb') and @('lsb') +are the same you still get one wire.
" + :enabled t + ;; We think most ranges we'll encounter are [high:low], so we don't bother to + ;; optimize the reverse case, but it would be easy enough to do if it's slow. + (b* ((high (max msb lsb)) + (low (min msb lsb)) + (|w[high:low]| (vl-emodwires-from-high-to-low name high low)) + (|w[msb:lsb]| (if (>= msb lsb) + |w[high:low]| + ;; Unusual case of a wire like w[0:3], so the + ;; w[high:low] is in the wrong order. + (reverse |w[high:low]|)))) + |w[msb:lsb]|)) + + +(define vl-vardecl-msb-emodwires + :parents (vl-wirealist-p) + :short "Compute the @(see vl-emodwire-p)s for a variable declaration, in MSB-first order." + ((x vl-vardecl-p) + (warnings vl-warninglist-p)) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (emodwires vl-emodwirelist-p)) + (b* (((vl-vardecl x) x) + + ((unless (vl-simplevar-p x)) + (mv nil + (fatal :type :vl-bad-vardecl + :msg "~a0 is not yet supported: we only handle simple ~ + wires and reg/logic variables with at most a single ~ + range." + :args (list x)) + nil)) + + (range (vl-simplevar->range x)) + ((unless (vl-maybe-range-resolved-p range)) + (mv nil + (fatal :type :vl-bad-vardecl + :msg "~a0 has unresolved range ~a1." + :args (list x range)) + nil)) + + ((unless range) + (mv t (ok) (list (vl-plain-wire-name x.name)))) + + (msb (vl-resolved->val (vl-range->msb range))) + (lsb (vl-resolved->val (vl-range->lsb range))) + (|w[msb:lsb]| (vl-emodwires-from-msb-to-lsb x.name msb lsb))) + (mv t (ok) |w[msb:lsb]|)) + /// + (defthm true-listp-of-vl-vardecl-msb-emodwires + (true-listp (mv-nth 2 (vl-vardecl-msb-emodwires x warnings))) + :rule-classes :type-prescription) + + (defthm basenames-of-vl-vardecl-msb-emodwires + (implies (vl-vardecl-p x) + (let ((wires (mv-nth 2 (vl-vardecl-msb-emodwires x warnings)))) + (equal (vl-emodwirelist->basenames wires) + (replicate (len wires) (vl-vardecl->name x))))) + :hints(("Goal" :in-theory (enable vl-plain-wire-name)))) + + (defthm unique-indicies-of-vl-vardecl-msb-emodwires + (no-duplicatesp-equal + (vl-emodwirelist->indices + (mv-nth 2 (vl-vardecl-msb-emodwires x warnings)))))) + + +(define vl-vardecllist-to-wirealist + :parents (vl-wirealist-p) + :short "Generate a (fast) wirealist from a @(see vl-vardecllist-p)." + ((x vl-vardecllist-p) + (warnings vl-warninglist-p)) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (wire-alist vl-wirealist-p)) + (b* (((when (atom x)) + (mv t (ok) nil)) + ((mv successp1 warnings wires1) + (vl-vardecl-msb-emodwires (car x) warnings)) + ((mv successp2 warnings walist) + (vl-vardecllist-to-wirealist (cdr x) warnings)) + (successp (and successp1 successp2)) + (walist (if successp1 + (hons-acons (vl-vardecl->name (car x)) wires1 walist) + walist))) + (mv successp warnings walist)) + /// + (defthm subsetp-equal-of-strip-cars-of-vl-vardecllist-to-wirealist + (subsetp-equal (strip-cars (mv-nth 2 (vl-vardecllist-to-wirealist x warnings))) + (vl-vardecllist->names x)))) + +(define vl-module-wirealist + :parents (vl-wirealist-p) + :short "Safely generate the (fast) wirealist for a module." + ((x vl-module-p) + (warnings vl-warninglist-p)) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (wire-alist vl-wirealist-p)) + :long "Note: this function is memoized and generates fast alists. You +should be sure to clear its memo table so that these fast alists can be garbage +collected.
+ +This function can fail, setting @('successp') to @('nil') and adding fatal +warnings, when:
+ +But unless the failure is due to a namespace problem, the resulting wire +alist will be at least a partial wire alist for this module that has entries +for all of the wires that don't have problems.
+ +A key property of this function is that the wire alist it generates binds +completely unique bits to all of the wires. This is proven as the following +theorem:
+ +@(thm no-duplicatesp-equal-of-append-alist-vals-of-vl-module-wirealist)" + + (b* (((vl-module x) x) + +; Name uniqueness check. +; +; Note this uniqueness check is on the module's net and register names and NOT +; on the generated name lists. This is a performance win since each name might +; expand into lots of bits. This appears to be taking about 8% of the runtime +; in practice. +; +; I once thought that a fast-alist style check might be better than using +; uniquep. Here is some code: +; +; (defun no-dupe-netdecls-names (x alist) +; (declare (xargs :guard (vl-netdecllist-p x))) +; (if (atom x) +; (mv t alist) +; (let ((name1 (vl-netdecl->name (car x)))) +; (if (hons-get name1 alist) +; (mv nil alist) +; (let ((alist (hons-acons name1 t alist))) +; (no-dupe-netdecls-names (cdr x) alist)))))) +; +; (defun no-dupe-regdecls-names (x alist) +; (declare (xargs :guard (vl-regdecllist-p x))) +; (if (atom x) +; (mv t alist) +; (let ((name1 (vl-regdecl->name (car x)))) +; (if (hons-get name1 alist) +; (mv nil alist) +; (let ((alist (hons-acons name1 t alist))) +; (no-dupe-regdecls-names (cdr x) alist)))))) +; +; But this was MUCH slower than uniquep in my benchmarks, even when building +; an appropriately-sized alist, even when all of the names were pre-honsed. +; +; BOZO it might be worth looking into how strings are handled in the honsing +; code and revisiting this. In particular, when we look up a string right now, +; we have to do an EQUAL hash to find its canonical version, even if we're +; staring right at its canonical version. It might be better to add another EQ +; hash table, say the STR-HT-EQ, that would associate canonical versions of +; strings with themselves. Then, when checking if a string is honsed, we could +; first look in this EQ hash table, and only look in the EQL hash table if +; there has been a failure. This would add some space overhead. It would also +; cost (very slightly) more time when we initially hons strings, and make +; looking up non-honsed strings slightly more expensive. But it might +; dramatically improve the performance of looking up honsed strings, which +; would give us a nice improvement here. +; +; BOZO this might also be due to fast-alist sentinel problems in previous +; versions of the Hons code, you may wish to revisit it! + + ((unless (mbe :logic + (uniquep (vl-vardecllist->names x.vardecls)) + :exec + (uniquep (vl-vardecllist->names-exec x.vardecls nil)))) + (mv nil + (fatal :type :vl-namespace-error + :msg "~m0 illegally redefines ~&1." + :args (list x.name + (duplicated-members (vl-vardecllist->names x.vardecls)))) + nil))) + + (vl-vardecllist-to-wirealist x.vardecls warnings)) + + /// + (memoize 'vl-module-wirealist) + + ;; Wow, this proof is way simpler now that vardecls/netdecls are merged. + + (local (defthm append-alist-vals-removal + (equal (append-alist-vals x) + (flatten (strip-cdrs x))) + :hints(("Goal" :induct (len x))))) + + (local (defthm rcars + (implies (no-duplicatesp-equal (vl-vardecllist->names x)) + (no-duplicatesp-equal + (strip-cars (mv-nth 2 (vl-vardecllist-to-wirealist x warnings))))) + :hints(("Goal" :in-theory (enable vl-vardecllist-to-wirealist))))) + + (local + (defthm r0 + (implies (and (not (member-equal (vl-vardecl->name a) + (vl-vardecllist->names x))) + (consp x)) + (not (equal (vl-vardecl->name a) + (vl-vardecl->name (first x))))))) + + (local + (defthm r1 + (implies (and (force (not (equal (vl-vardecl->name a) + (vl-vardecl->name b)))) + (force (vl-vardecl-p a)) + (force (vl-vardecl-p b))) + (not (intersectp-equal + (mv-nth 2 (vl-vardecl-msb-emodwires a warnings1)) + (mv-nth 2 (vl-vardecl-msb-emodwires b warnings2))))) + :hints(("Goal" + :use ((:instance empty-intersect-of-vl-emodwires-by-basename + (xname (vl-vardecl->name a)) + (yname (vl-vardecl->name b)) + (x (mv-nth 2 (vl-vardecl-msb-emodwires a warnings1))) + (y (mv-nth 2 (vl-vardecl-msb-emodwires b warnings2))))))))) + + (local + (defthm r2 + (let ((r-wires (mv-nth 2 (vl-vardecl-msb-emodwires r warnings1))) + (other-wire-lists (strip-cdrs (mv-nth 2 (vl-vardecllist-to-wirealist others warnings2))))) + (implies (and (force (not (member-equal (vl-vardecl->name r) + (vl-vardecllist->names others)))) + (force (vl-vardecl-p r)) + (force (vl-vardecllist-p others))) + (empty-intersect-with-each-p r-wires + other-wire-lists))) + :hints(("Goal" + :induct (vl-vardecllist-to-wirealist others warnings2) + :in-theory (enable vl-vardecllist-to-wirealist))))) + + (local (defthm rcdrs + (implies (and (no-duplicatesp-equal (vl-vardecllist->names x)) + (force (vl-vardecllist-p x))) + (no-duplicatesp-equal + (flatten (strip-cdrs (mv-nth 2 (vl-vardecllist-to-wirealist x warnings)))))) + :hints(("Goal" + :in-theory (enable vl-vardecllist-to-wirealist) + :induct (vl-vardecllist-to-wirealist x warnings))))) + + (defthm no-duplicatesp-equal-of-append-alist-vals-of-vl-module-wirealist + (let ((walist (mv-nth 2 (vl-module-wirealist x warnings)))) + (no-duplicatesp-equal (append-alist-vals walist))))) + + + + +(define vl-msb-constint-bitlist-aux ((value natp) acc) + :parents (vl-msb-constint-bitlist) + :short "Produce an MSB-ordered list of the bits for some value." + :prepwork ((local (include-book "arithmetic-3/floor-mod/floor-mod" :dir :system))) + :measure (nfix value) + (b* (((when (zp value)) + acc) + (floor2 (mbe :logic (floor value 2) + :exec (ash value -1))) + (mod2 (mbe :logic (mod value 2) + :exec (rem value 2))) + (bit (if (eql mod2 0) + 'acl2::f + 'acl2::t))) + (vl-msb-constint-bitlist-aux floor2 (cons bit acc))) + /// + (defthm true-listp-of-vl-msb-constint-bitlist-aux + (implies (true-listp acc) + (true-listp (vl-msb-constint-bitlist-aux value acc))) + :rule-classes :type-prescription) + + (defthm vl-emodwirelist-p-of-vl-msb-constint-bitlist-aux + (implies (vl-emodwirelist-p acc) + (vl-emodwirelist-p (vl-msb-constint-bitlist-aux value acc))))) + +(define vl-msb-constint-bitlist + :parents (vl-msb-expr-bitlist) + :short "Produce the @(see vl-emodwire-p)s for a @(see vl-constint-p)." + + ((x vl-expr-p) + (warnings vl-warninglist-p)) + :guard (and (vl-atom-p x) + (vl-constint-p (vl-atom->guts x))) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (bits vl-emodwirelist-p)) + + :long "In E modules, the symbols @('ACL2::t') and @('ACL2::f') are +interpreted as literal 1 and 0 bits.
+ +We are given an atomic, constant integer expression. This expression has +some width and value. We return a width-long list of symbols +@('ACL2::T') or @('ACL2::F') that represent this value.
" + + (b* ((width (vl-atom->finalwidth x)) + (guts (vl-atom->guts x)) + (value (vl-constint->value guts)) + + ((unless width) + (mv nil + (fatal :type :vl-programming-error + :msg "Cannot generate wires for ~a0 because it does not ~ + have a finalwidth." + :args (list x)) + nil)) + + (bits (vl-msb-constint-bitlist-aux value nil)) + (blen (length bits)) + + ((when (equal blen width)) + ;; Already the right width. No need to pad. + (mv t (ok) bits)) + + ((when (< blen width)) + ;; Sometimes we need to pad with extra F bits to get to the + ;; appropriate width. + (mv t (ok) (make-list-ac (- width blen) 'acl2::f bits)))) + + ;; Else, more bits than the width permits? This shouldn't ever happen + ;; if our sizing code is right. + (mv nil + (fatal :type :vl-programming-error + :msg "Produced too many wires for ~a0. Finalwidth: ~x1. ~x2 ~ + Bits: ~x3." + :args (list x (vl-atom->finalwidth x) blen bits)) + nil)) + + /// + (more-returns + (bits true-listp :rule-classes :type-prescription)) + + ;; Some basic unit tests. + (local (assert! + (let ((f 'acl2::f)) + (flet ((test-ok (width val expect) + (mv-let (successp warnings bits) + (vl-msb-constint-bitlist + (make-vl-atom :finalwidth width + :finaltype :vl-unsigned + :guts (make-vl-constint + :origwidth width + :origtype :vl-unsigned + :value val)) + nil) + (and successp + (not warnings) + (equal bits expect))))) + (debuggable-and + (test-ok 8 0 (list f f f f f f f f)) + (test-ok 8 1 (list f f f f f f f t)) + (test-ok 8 15 (list f f f f t t t t)) + (test-ok 8 127 (list f t t t t t t t)) + (test-ok 8 128 (list t f f f f f f f)) + + (test-ok 10 0 (list f f f f f f f f f f)) + (test-ok 10 1 (list f f f f f f f f f t)) + (test-ok 10 15 (list f f f f f f t t t t)) + (test-ok 10 127 (list f f f t t t t t t t)) + (test-ok 10 128 (list f f t f f f f f f f)))))))) + + + +(define vl-msb-wire-bitlist + :parents (vl-msb-expr-bitlist) + :short "Produce the @(see vl-emodwire-p)s for a @(see vl-id-p)." + + ((x vl-expr-p) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :guard (and (vl-atom-p x) + (vl-id-p (vl-atom->guts x))) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (bits vl-emodwirelist-p)) + :long "We are given an atomic, identifier expression. This expression has +some width and refers to a particular wire. We return a wires associated with +this name in MSB order.
" + + (b* ((width (vl-atom->finalwidth x)) + (guts (vl-atom->guts x)) + (name (vl-id->name guts)) + + ((unless (posp width)) + (mv nil + (fatal :type :vl-programming-error + :msg "Expected only sized expressions, but ~a0 does not ~ + have a finalwidth." + :args (list x)) + nil)) + + (wires (mbe :logic (list-fix (cdr (hons-get name walist))) + :exec (cdr (hons-get name walist)))) + + ((unless (and (consp wires) + (mbt (vl-emodwirelist-p wires)))) + (mv nil + (fatal :type :vl-bad-id + :msg "No wires for ~a0." + :args (list name)) + nil)) + + (nwires (length wires)) + + ((when (< width nwires)) + (mv nil + (fatal :type :vl-programming-error + :msg "Produced too many wires for ~a0. Finalwidth is ~x1, ~ + but produced ~x2 bits: ~x3." + :args (list x (vl-atom->finalwidth x) nwires wires)) + nil)) + + ((when (eql nwires width)) + (mv t (ok) wires)) + + ;; else, we need to implicitly zero-extend or sign-extend the wire + ;; based on its type; @(see vl-atom-welltyped-p). + + (type (vl-atom->finaltype x)) + (extension-bit (if (eq type :vl-signed) + (car wires) + 'acl2::f)) + (wires (append (replicate (- width nwires) extension-bit) wires))) + + (mv t (ok) wires)) + + /// + (more-returns + (bits true-listp :rule-classes :type-prescription))) + + + +(define vl-msb-partselect-bitlist + :parents (vl-msb-expr-bitlist) + :short "Produce the @(see vl-emodwire-p)s for a part-select." + + ((x vl-expr-p) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :guard (and (not (vl-atom-p x)) + (equal (vl-nonatom->op x) :vl-partselect-colon)) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (bits vl-emodwirelist-p)) + :long "We attempt to return the list of wires that correspond to this part +select, in MSB order. We are careful to ensure that the range is resolved, the +indices are in bounds, and so on.
" + + :prepwork ((local (in-theory (enable hons-assoc-equal)))) + + (b* ((args (vl-nonatom->args x)) + (from (first args)) + (left (second args)) + (right (third args)) + + ((unless (and (vl-idexpr-p from) + (vl-expr-resolved-p left) + (vl-expr-resolved-p right))) + (mv nil + (fatal :type :vl-bad-expr + :msg "Expected a simple name and resolved indices, but ~ + found ~a0." + :args (list x)) + nil)) + + (name (vl-idexpr->name from)) + (left (vl-resolved->val left)) + (right (vl-resolved->val right)) + + (entry (hons-get name walist)) + ((unless entry) + (mv nil + (fatal :type :vl-bad-expr + :msg "No wire-alist entry for ~w0." + :args (list name)) + nil)) + + (wires (mbe :logic (list-fix (cdr entry)) + :exec (cdr entry))) + + (plain-name (vl-plain-wire-name name)) + + ((when (equal wires (list plain-name))) + ;; Special case. This is a select of a single, non-ranged wire. The + ;; only valid possibility is that high and low are both zero, in which + ;; case we are choosing name[0:0] which is the same as name. + (if (and (eql left 0) + (eql right 0)) + ;; BOZO probably we should not be doing this. But I suspect things + ;; will break if we just remove this, so for now just add a + ;; non-fatal warning. Hrmn, but what about the scalared and + ;; vectored keywords? Ugh. If you fix this consider also the + ;; similar thing happening for bit-selects, and also fix the + ;; vl-expr-allwires function. + (mv t + (warn :type :vl-select-from-scalar + :msg "~a0: permitting selecting bit 0 from a scalar ~ + wire, but this is probably wrong." + :args (list x)) + wires) + + (mv nil + (fatal :type :vl-bad-expr + :msg "~w0 is a lone wire, but found ~a1." + :args (list name x)) + nil))) + + ;; Otherwise, this is the ordinary case, and we are selecting some part + ;; of some ranged wire. Since the wires in the walist are contiguous, + ;; we can check that the whole part is in bound by merely checking that + ;; both indices are found. + (name[left] (make-vl-emodwire :basename name :index left)) + (name[right] (make-vl-emodwire :basename name :index right)) + ((unless (and (member name[left] wires) + (member name[right] wires))) + (mv nil + (fatal :type :vl-bad-expr + :msg "Select ~a0 is out of range; valid range is from ~x1 ~ + to ~x2." + :args (list x (car wires) (car (last wires)))) + nil))) + + ;; We're fine. It seems easiest to just re-intern the symbols instead of + ;; extracting the appropriate slice out of the wire alist. + (mv t (ok) (vl-emodwires-from-msb-to-lsb name left right))) + + /// + (more-returns + (bits true-listp :rule-classes :type-prescription))) + + + +(define vl-msb-bitselect-bitlist + :parents (vl-msb-expr-bitlist) + :short "Produce the @(see vl-emodwire-p)s for a bit-select." + ((x vl-expr-p) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :guard (and (not (vl-atom-p x)) + (equal (vl-nonatom->op x) :vl-bitselect)) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (bits vl-emodwirelist-p)) + :long "We attempt to return the list of wires that correspond to this bit +select. In practice this will be a singleton wire, or nil on failure. We are +careful to ensure that the selected bit is in bounds, etc.
" + + :prepwork ((local (in-theory (enable hons-assoc-equal)))) + + (b* ((args (vl-nonatom->args x)) + (from (first args)) + (index (second args)) + + ((unless (and (vl-idexpr-p from) + (vl-expr-resolved-p index) + (natp (vl-resolved->val index)))) + (mv nil + (fatal :type :vl-bad-expr + :msg "Expected a simple name and resolved index, but found ~ + a0." + :args (list x)) + nil)) + + (name (vl-idexpr->name from)) + (index (vl-resolved->val index)) + (entry (hons-get name walist)) + + ((unless entry) + (mv nil + (fatal :type :vl-bad-expr + :msg "No wire-alist entry for ~w0." + :args (list name)) + nil)) + + (wires (mbe :logic (list-fix (cdr entry)) + :exec (cdr entry))) + (plain-name (vl-plain-wire-name name)) + + ((when (equal wires (list plain-name))) + ;; Special case. This is a select of a single, non-ranged wire. The + ;; only valid possibility is that the index is zero, in which case we + ;; are choosing name[0], which is the same as name. BOZO think about + ;; this again. Should maybe warn here. + (if (eql index 0) + (mv t (ok) wires) + (mv nil + (fatal :type :vl-bad-expr + :msg "~w0 is a lone wire, but found ~a1." + :args (list name x)) + nil))) + ;; Ordinary case. We are selecting from some wire with a range. Figure + ;; out what wire we want, and make sure it exists. + (name[i] (make-vl-emodwire :basename name :index index)) + ((unless (member name[i] wires)) + (mv nil + (fatal :type :vl-bad-expr + :msg "Select ~a0 is out of range: the valid bits are ~s1 ~ + through ~s2." + :args (list x (car wires) (car (last wires)))) + nil))) + + (mv t (ok) (list name[i]))) + /// + (more-returns + (bits true-listp :rule-classes :type-prescription))) + + + +(define vl-msb-replicate-bitlist + :parents (vl-msb-expr-bitlist) + :short "@(call vl-msb-replicate-bitlist) appends @('bits') onto itself +repeatedly, making @('n') copies of @('bits') as a single list." + ((n natp) + (bits true-listp)) + :long "This is used for multiple concatenations, e.g., @('{4 +{a,b,c}}').
" + + (if (zp n) + nil + (append bits (vl-msb-replicate-bitlist (- n 1) bits))) + /// + (defthm true-listp-of-vl-msb-replicate-bitlist + (true-listp (vl-msb-replicate-bitlist n bits)) + :rule-classes :type-prescription) + + (defthm vl-emodwirelist-p-of-vl-msb-replicate-bitlist + (implies (vl-emodwirelist-p bits) + (vl-emodwirelist-p (vl-msb-replicate-bitlist n bits)))) + + (defthm len-of-vl-msb-replicate-bitlist + (equal (len (vl-msb-replicate-bitlist n bits)) + (* (nfix n) (len bits)))) + + ;; Simple unit tests. + (local (assert! + (let ((f 'acl2::f)) + (debuggable-and + (equal (vl-msb-replicate-bitlist 0 (list t t f)) + nil) + (equal (vl-msb-replicate-bitlist 1 (list t t f)) + (list t t f)) + (equal (vl-msb-replicate-bitlist 2 (list t t f)) + (list t t f t t f)) + (equal (vl-msb-replicate-bitlist 3 (list t t f)) + (list t t f t t f t t f))))))) + + +(defines vl-msb-expr-bitlist + :parents (vl-wirealist-p) + :short "Produce the E-language, MSB-ordered list of bits for an expression." + + :long "When we translate module and gate instances into E, the arguments +of the instance are Verilog expressions, and we need to convert them into +E-language patterns. By the end of our simplification process, we think that +each such expression should contain only:
+ +This routine is intended to convert arbitrary expressions that include only +the above forms into a list of MSB order bits.
" + :verify-guards nil + + (define vl-msb-expr-bitlist ((x vl-expr-p) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :measure (vl-expr-count x) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (bits vl-emodwirelist-p)) + :flag :expr + + (b* (((when (vl-fast-atom-p x)) + (let ((guts (vl-atom->guts x))) + (case (tag guts) + (:vl-constint (vl-msb-constint-bitlist x warnings)) + (:vl-id (vl-msb-wire-bitlist x walist warnings)) + (otherwise + (mv nil + (fatal :type :vl-unimplemented + :msg "Need to add support for ~x0." + :args (list (tag guts))) + nil))))) + + (op (vl-nonatom->op x)) + (args (vl-nonatom->args x)) + ;; BOZO add additional length checks to the end of these functions. + ((when (eq op :vl-bitselect)) + (vl-msb-bitselect-bitlist x walist warnings)) + ((when (eq op :vl-partselect-colon)) + (vl-msb-partselect-bitlist x walist warnings)) + ((when (eq op :vl-concat)) + (vl-msb-exprlist-bitlist args walist warnings)) + ((when (eq op :vl-multiconcat)) + (b* ((mult (first args)) + (concat (second args)) + ((unless (and (vl-expr-resolved-p mult) + (natp (vl-resolved->val mult)))) + (mv nil + (fatal :type :vl-bad-expr + :msg "Multiple concatenation with unresolved multiplicity: ~a0." + :args (list x)) + nil)) + ((mv successp warnings bits) + (vl-msb-expr-bitlist concat walist warnings)) + ((unless successp) + ;; Already warned + (mv successp warnings bits)) + (replbits + (vl-msb-replicate-bitlist (vl-resolved->val mult) bits))) + (mv t (ok) replbits)))) + (mv nil + (fatal :type :vl-unsupported + :msg "Unsupported operator ~x0." + :args (list op)) + nil))) + + (define vl-msb-exprlist-bitlist ((x vl-exprlist-p) + (walist vl-wirealist-p) + (warnings vl-warninglist-p)) + :measure (vl-exprlist-count x) + :returns (mv (successp booleanp :rule-classes :type-prescription) + (warnings vl-warninglist-p) + (bits vl-emodwirelist-p)) + :flag :list + (b* (((when (atom x)) + (mv t (ok) nil)) + ((mv car-successp warnings car-bits) + (vl-msb-expr-bitlist (car x) walist warnings)) + ((mv cdr-successp warnings cdr-bits) + (vl-msb-exprlist-bitlist (cdr x) walist warnings))) + (mv (and car-successp cdr-successp) + warnings + (append car-bits cdr-bits)))) + + /// + + (defthm-vl-msb-expr-bitlist-flag + (defthm true-listp-of-vl-msb-expr-bitlist-2 + (true-listp (mv-nth 2 (vl-msb-expr-bitlist x walist warnings))) + :rule-classes :type-prescription + :flag :expr) + (defthm true-listp-of-vl-msb-exprlist-bitlist-2 + (true-listp (mv-nth 2 (vl-msb-exprlist-bitlist x walist warnings))) + :rule-classes :type-prescription + :flag :list)) + + (verify-guards vl-msb-expr-bitlist)) + + diff -Nru acl2-7.0/books/centaur/esim/vltoe/zdrivers.lisp acl2-7.1/books/centaur/esim/vltoe/zdrivers.lisp --- acl2-7.0/books/centaur/esim/vltoe/zdrivers.lisp 1970-01-01 00:00:00.000000000 +0000 +++ acl2-7.1/books/centaur/esim/vltoe/zdrivers.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -0,0 +1,221 @@ +; ESIM Symbolic Hardware Simulator +; Copyright (C) 2008-2015 Centaur Technology +; +; Contact: +; Centaur Technology Formal Verification Group +; 7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA. +; http://www.centtech.com/ +; +; License: (An MIT/X11-style license) +; +; Permission is hereby granted, free of charge, to any person obtaining a +; copy of this software and associated documentation files (the "Software"), +; to deal in the Software without restriction, including without limitation +; the rights to use, copy, modify, merge, publish, distribute, sublicense, +; and/or sell copies of the Software, and to permit persons to whom the +; Software is furnished to do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in +; all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +; DEALINGS IN THE SOFTWARE. +; +; Original author: Jared DavisThe @('good-esim-modulep') well-formedness check requires that +every wire of a module is driven by some occurrence (or is an input). But in +Verilog there is no such requirement, e.g., one can legally write a module like +this:
+ +@({ +module does_nothing(out, a, b); + output out; + input a; + input b; + wire internal; +endmodule +}) + +Where there aren't any drivers on @('out') or @('internal').
+ +To correct for this, in our @(see e-conversion) we look for any output bits +and also any internal wires that are used as inputs to a submodule but are +never driven by the preliminary occurrences produced by @(see +modinsts-to-eoccs). For any such bit, we add an explicit @(see acl2::*esim-z*) +module to drive it.
") + + +(defsection vl-make-z-occ + :parents (adding-z-drivers) + :short "Generate an instance of @(see acl2::*esim-z*) to drive an +otherwise-undriven output bit." + + (defund vl-make-z-occ (name out) + (declare (xargs :guard (and (vl-emodwire-p out) + name))) + ;; Note: the I/O here must agree with *esim-z*. + (list :u name + :op acl2::*esim-z* + :i nil + :o (list (list out)))) + + (local (in-theory (enable vl-make-z-occ))) + + (defthm good-esim-occp-of-vl-make-z-occ + (implies (and (force (vl-emodwire-p out)) + (force name)) + (good-esim-occp (vl-make-z-occ name out))) + :hints(("Goal" :in-theory (enable good-esim-occp))))) + + +(defsection vl-make-z-occs + :parents (adding-z-drivers) + :short "Generate instances of @(see acl2::*esim-z*) to drive undriven output +bits." + + :long "Signature: @(call vl-make-z-occs) returns a list of +occurrences.
+ +Signature: @(call vl-add-zdrivers) returns @('occs'').
+ +@('occs') should be the initial list of occurrences that we generate from +the module instances; see for instance @(see vl-modinst-to-eocc).
+ +@('flat-outs') should be the already-flattened list of the module's output +bits, i.e., @('(pat-flatten (gpl :o mod))').
+ +@('flat-ins') should be the already-flattened list of the module's input +bits, i.e., @('(pat-flatten (gpl :i mod))').
+ +@('all-names') must be a @(see vl-emodwirelist-p)s that captures the +module's namespace. We expect it to include at least:
+ +However, as a special exception, @('all-names') may exclude names that we +know cannot have the basename @('vl_zdrive'). This includes, for instance, all +of the wires that are added during @(see vl-add-res-modules), and the special +wires that are added to drive T and F in @(see vl-module-make-esim).
" + + (defund vl-add-zdrivers (all-names flat-ins flat-outs occs) + (declare (xargs :guard (and (vl-emodwirelist-p all-names) + (vl-emodwirelist-p flat-ins) + (vl-emodwirelist-p flat-outs) + (vl-emodwirelist-p (collect-signal-list :i occs)) + (vl-emodwirelist-p (collect-signal-list :o occs))))) + + (b* ((driven-signals + ;; All signals that are already being driven, either by an occurrence + ;; or because they are inputs and hence are being driven by the + ;; superior module. + (union (mergesort flat-ins) + (mergesort (collect-signal-list :o occs)))) + + (consumed-signals + ;; All signals that "need to be" driven, either because they are + ;; feeding an occurrence or because they are outputs that need to + ;; feed something in the superior module. + (union (mergesort flat-outs) + (mergesort (collect-signal-list :i occs)))) + + (signals-that-need-zdrivers + (difference (difference consumed-signals driven-signals) + ;; We also don't want to add drivers for F and T; fixing + ;; them up is the responsibility of vl-module-make-esim. + (mergesort '(acl2::f acl2::t)))) + + ((unless signals-that-need-zdrivers) + ;; Optimization. Most of the time nothing needs to be fixed up so we + ;; don't have to do anything. We can avoid computing the highest + ;; vl_zdrive wire, which can save a lot of string processing. + occs) + + (idx (vl-emodwirelist-highest "vl_zdrive" all-names)) + (new-occs (vl-make-z-occs idx signals-that-need-zdrivers))) + + (append new-occs occs))) + + (local (in-theory (enable vl-add-zdrivers))) + + (defthm good-esim-occsp-of-vl-add-zdrivers + (implies (and (force (vl-emodwirelist-p all-names)) + (force (vl-emodwirelist-p flat-ins)) + (force (vl-emodwirelist-p flat-outs)) + (force (vl-emodwirelist-p (collect-signal-list :i occs))) + (force (vl-emodwirelist-p (collect-signal-list :o occs))) + (force (good-esim-occsp occs))) + (good-esim-occsp (vl-add-zdrivers all-names flat-ins flat-outs occs))) + :hints(("Goal" :in-theory (enable good-esim-occsp))))) + diff -Nru acl2-7.0/books/centaur/fty/basetypes.lisp acl2-7.1/books/centaur/fty/basetypes.lisp --- acl2-7.0/books/centaur/fty/basetypes.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/fty/basetypes.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -82,10 +82,16 @@ (fty::defbasetype number-equiv acl2-numberp :fix fix) - (fty::deffixtype true-list :pred true-listp :fix list-fix :equiv list-equiv) + (fty::deffixtype true-list + :pred true-listp + :fix list-fix + :equiv list-equiv) (local (in-theory (enable streqv))) - (fty::deffixtype string :pred stringp :fix str-fix :equiv streqv) + (fty::deffixtype string + :pred stringp + :fix str-fix + :equiv streqv) (defun true-p (x) (declare (xargs :guard t)) @@ -143,16 +149,27 @@ (implies (posp x) (equal (pos-fix x) x))) + (defun lposfix (x) + ;; enabled + (declare (xargs :guard (posp x))) + (mbe :logic (pos-fix x) :exec x)) + (fty::defbasetype pos-equiv posp :fix pos-fix)) - (fty::deffixtype character :pred characterp :fix char-fix :equiv chareqv) + (fty::deffixtype character + :pred characterp + :fix char-fix + :equiv chareqv) (defun any-p (x) (declare (xargs :guard t) (ignore x)) t) - (fty::deffixtype any :pred any-p :fix identity :equiv equal) + (fty::deffixtype any + :pred any-p + :fix identity + :equiv equal) (defsection bool-equiv-is-just-iff (defund bool-fix (x) @@ -169,7 +186,10 @@ (implies (booleanp x) (equal (bool-fix x) x))) - (fty::deffixtype bool :pred booleanp :fix bool-fix :equiv iff) + (fty::deffixtype bool + :pred booleanp + :fix bool-fix + :equiv iff) (defcong iff equal (bool-fix x) 1)) @@ -205,8 +225,13 @@ (acl2::nat-equiv (maybe-natp-fix x) x) :hints(("Goal" :in-theory (enable maybe-natp-fix)))) - (fty::deffixtype maybe-nat :pred maybe-natp :fix maybe-natp-fix :equiv maybe-nat-equiv - :define t)) + (fty::deffixtype maybe-nat + :pred maybe-natp + :fix maybe-natp-fix + :equiv maybe-nat-equiv + :define t + :inline t + :equal eql)) ;; [Jared] unlocalizing these since this book is now included in std/strings/defs-program diff -Nru acl2-7.0/books/centaur/fty/deftypes.lisp acl2-7.1/books/centaur/fty/deftypes.lisp --- acl2-7.0/books/centaur/fty/deftypes.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/fty/deftypes.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -161,8 +161,138 @@ (program) +;;--------------- Primitive aggregates used below ------------------ + +(def-primitive-aggregate suminfo + (type ;; the superior flextypes object + sum ;; the single flexsum within type + tags ;; possible tags for products within type + )) + +(def-primitive-aggregate flexprod-field + (name ;; field name + acc-body ;; accessor body, without fixing + acc-name ;; accessor function name + type ;; element type, or nil + fix ;; element fix, or nil + equiv ;; element equiv, or nil + ;; require ;; dependent type constraint (term) -- now associated with product, not field + reqfix ;; dependent type fix (term) + default ;; default value + doc ;; not yet used + rule-classes ;; for return type theorem, either empty (default) or of the form (:rule-classes ...) + recp ;; is the field type part of the mutual recursion + )) + +(def-primitive-aggregate flexprod + (kind ;; kind symbol + cond ;; term to check whether x is of this kind, after checking previous ones + guard ;; additional guard for accessors + shape ;; other requirements, given kindcheck + require ;; dependent type requirement (term) + fields ;; flexprod-field list + type-name ;; base for constructing default accessor names + ctor-name ;; constructor function name + ctor-macro ;; constructor macro (keyword args) name + ctor-body ;; constructor body, without fixing + short ;; xdoc + long ;; xdoc + inline ;; inline keywords + extra-binder-names ;; extra x.foo b* binders for not-yet-implemented accessors + count-incr ;; add an extra 1 to count + no-ctor-macros ;; omit maker and changer macros + )) + +(defun flexprods->kinds (prods) + (if (atom prods) + nil + (cons (flexprod->kind (car prods)) + (flexprods->kinds (cdr prods))))) + +(def-primitive-aggregate flexsum + (name ;; name of this type + pred ;; predicate function name + fix ;; fix function name + equiv ;; equiv function name + kind ;; kind function name + kind-body ;; :exec part of kind function + count ;; count function name + case ;; case macro name + prods ;; flexprod structures + measure ;; measure for termination + shape ;; shape for all prods + xvar ;; variable name denoting the object + kwd-alist ;; original keyword arguments + orig-prods ;; original products + inline ;; inline kind, fix functions + recp ;; has a recusive field in some product + typemacro ;; defflexsum, deftagsum, defprod + ) + :tag :sum) + +(def-primitive-aggregate flexlist + (name ;; name of the type + pred ;; preducate function name + fix ;; fix function name + equiv ;; equiv function name + count ;; count function name + elt-type ;; element type name + elt-fix ;; element fixing function + elt-equiv ;; element equiv function + measure ;; termination measure + xvar ;; variable name denoting the object + kwd-alist ;; original keyword alist + true-listp ;; require nil final cdr + elementp-of-nil + cheap ;; passed to std::deflist + recp ;; elt-type is recursive + already-definedp) + :tag :list) + +(def-primitive-aggregate flexalist + (name ;; name of the type + pred ;; predicate function name + fix ;; fix function name + equiv ;; equiv function name + count ;; count function name + key-type ;; key type name + key-fix ;; key fixing function + key-equiv ;; key equiv function + val-type ;; value type name + val-fix ;; value fixing function + val-equiv ;; value equiv function + strategy ;; :fixkeys or :dropkeys + measure ;; termination measure + xvar ;; variable name denoting the object + kwd-alist ;; original keyword alist + keyp-of-nil ;; passed to std::defalist + valp-of-nil ;; passed to std::defalist + ;; get get-fast ;; more fn names + ;; set set-fast + true-listp + recp + already-definedp) + :tag :alist) + +(def-primitive-aggregate flextypes + (name + types ;; flexlist and flexsums + no-count ;; skip the count function + kwd-alist + ;; prepwork + ;; post-pred-events + ;; post-fix-events + ;; post-events + recp)) + + ;; ------------------------- Misc Utilities ------------------------ + +(define get-flextypes (world) + "Get the database of defined flextypes." + (table-alist 'fty::flextypes-table world)) + (defmacro revappend-chars (x y) `(str::revappend-chars ,x ,y)) @@ -219,9 +349,8 @@ (or (find-fixtype-for-typename typename alist) (find-fixtype-for-pred typename alist))) -(defun get-pred/fix/equiv (kwd-alist our-fixtypes fixtypes typekw) - (b* ((type (getarg typekw nil kwd-alist)) - ((unless type) (mv nil nil 'equal nil)) +(defun get-pred/fix/equiv (type our-fixtypes fixtypes) + (b* (((unless type) (mv nil nil 'equal nil)) (fixtype1 (find-fixtype type our-fixtypes)) (fixtype (or fixtype1 (find-fixtype type fixtypes))) ((unless fixtype) @@ -288,20 +417,6 @@ ;; ------------------------- Flexsum Parsing ----------------------- ;; --- Flexprod Fields --- -(def-primitive-aggregate flexprod-field - (name ;; field name - acc-body ;; accessor body, without fixing - acc-name ;; accessor function name - type ;; element type, or nil - fix ;; element fix, or nil - equiv ;; element equiv, or nil - ;; require ;; dependent type constraint (term) -- now associated with product, not field - reqfix ;; dependent type fix (term) - default ;; default value - doc ;; not yet used - rule-classes ;; for return type theorem, either empty (default) or of the form (:rule-classes ...) - recp ;; is the field type part of the mutual recursion - )) (defconst *flexprod-field-keywords* '(:type @@ -333,7 +448,8 @@ (cat (symbol-name type-name) "->" (symbol-name name)) type-name) kwd-alist)) - ((mv type fix equiv recp) (get-pred/fix/equiv kwd-alist our-fixtypes fixtypes :type)) + ((mv type fix equiv recp) (get-pred/fix/equiv (getarg :type nil kwd-alist) + our-fixtypes fixtypes)) (reqfix (getarg :reqfix name kwd-alist))) (make-flexprod-field :name name @@ -357,23 +473,6 @@ (parse-flexprod-fields (cdr x) type-name our-fixtypes fixtypes)))) ;; --- Flexprods --- -(def-primitive-aggregate flexprod - (kind ;; kind symbol - cond ;; term to check whether x is of this kind, after checking previous ones - guard ;; additional guard for accessors - shape ;; other requirements, given kindcheck - require ;; dependent type requirement (term) - fields ;; flexprod-field list - type-name ;; base for constructing default accessor names - ctor-name ;; constructor function name - ctor-macro ;; constructor macro (keyword args) name - ctor-body ;; constructor body, without fixing - short ;; xdoc - long ;; xdoc - inline ;; inline keywords - extra-binder-names ;; extra x.foo b* binders for not-yet-implemented accessors - )) - (defconst *flexprod-keywords* '(:shape :fields @@ -453,26 +552,6 @@ (parse-flexprods (cdr x) sumname sumkind sum-kwds xvar rev-not-prevconds our-fixtypes fixtypes))))) ;; --- Flexsum --- -(def-primitive-aggregate flexsum - (name ;; name of this type - pred ;; predicate function name - fix ;; fix function name - equiv ;; equiv function name - kind ;; kind function name - kind-body ;; :exec part of kind function - count ;; count function name - case ;; case macro name - prods ;; flexprod structures - measure ;; measure for termination - shape ;; shape for all prods - xvar ;; variable name denoting the object - kwd-alist ;; original keyword arguments - orig-prods ;; original products - inline ;; inline kind, fix functions - recp ;; has a recusive field in some product - typemacro ;; defflexsum, deftagsum, defprod - ) - :tag :sum) (defconst *flexsum-keywords* '(:pred :fix :equiv :kind :count ;; function names @@ -867,6 +946,8 @@ (tagsum-prods-to-flexprods (cdr prods) xvar sum-kwds (or have-base-or-override basep) our-fixtypes tagsum-name))))) + + (defconst *tagsum-keywords* '(:pred :fix :equiv :kind :count ;; function names :measure ;; term @@ -883,6 +964,14 @@ :post-events :enable-rules)) + +(defun tagsum-tag-events-post-fix (pred fix xvar name) + `((defthm ,(intern-in-package-of-symbol (cat (symbol-name pred) "-OF-" (symbol-name fix) "-TAG-FORWARD") + name) + (,pred (,fix ,xvar)) + :rule-classes ((:forward-chaining :trigger-terms ((tag (,fix ,xvar)))))))) + + (defun parse-tagsum (x xvar these-fixtypes fixtypes) (b* (((cons name args) x) ((unless (symbolp name)) @@ -928,7 +1017,10 @@ (er hard? 'parse-tagsum "Malformed SUM ~x0: Must have at least one product")) (measure (or (getarg :measure nil kwd-alist) - `(acl2-count ,xvar)))) + `(acl2-count ,xvar))) + (post-fix-events (append (tagsum-tag-events-post-fix + pred fix xvar name) + (cdr (assoc :post-fix-events kwd-alist))))) (make-flexsum :name name :pred pred :fix fix @@ -942,10 +1034,11 @@ :xvar xvar :inline inline :measure measure - :kwd-alist (if post-/// - (cons (cons :///-events post-///) - kwd-alist) - kwd-alist) + :kwd-alist (cons (cons :post-fix-events post-fix-events) + (if post-/// + (cons (cons :///-events post-///) + kwd-alist) + kwd-alist)) :orig-prods orig-prods :recp (flexprods-recursivep prods) :typemacro 'deftagsum))) @@ -1008,7 +1101,8 @@ (cons (flexprod-field->default (car fields)) (flexprod-fields->defaults (cdr fields))))) -(defun defprod-tag-events (pred xvar tag name formals) + +(defun defprod-tag-events-post-pred (pred xvar tag name) (b* ((foop pred) (x xvar)) `((defthmd ,(intern-in-package-of-symbol (cat "TAG-WHEN-" (symbol-name foop)) @@ -1016,7 +1110,7 @@ (implies (,foop ,x) (equal (tag ,x) ,tag)) - :rule-classes ((:rewrite :backchain-limit-lst 0) + :rule-classes ((:rewrite :backchain-limit-lst 1) (:forward-chaining)) :hints(("Goal" :in-theory (enable tag ,foop)))) @@ -1028,18 +1122,25 @@ :rule-classes ((:rewrite :backchain-limit-lst 1)) :hints(("Goal" :in-theory (enable tag ,foop)))) - (defthm ,(intern-in-package-of-symbol (cat "TAG-OF-" (symbol-name name)) - name) - (equal (tag (,name . ,formals)) - ,tag) - :hints (("goal" :in-theory (enable ,name tag)))) - (add-to-ruleset std::tag-reasoning '(,(intern-in-package-of-symbol (cat "TAG-WHEN-" (symbol-name foop)) name) ,(intern-in-package-of-symbol (cat (symbol-name foop) "-WHEN-WRONG-TAG") name)))))) +(defun defprod-tag-events-post-fix (pred fix xvar name) + `((defthm ,(intern-in-package-of-symbol (cat (symbol-name pred) "-OF-" (symbol-name fix) "-TAG-FORWARD") + name) + (,pred (,fix ,xvar)) + :rule-classes ((:forward-chaining :trigger-terms ((tag (,fix ,xvar)))))))) + +(defun defprod-tag-events-post-ctor (tag name formals) + `((defthm ,(intern-in-package-of-symbol (cat "TAG-OF-" (symbol-name name)) + name) + (equal (tag (,name . ,formals)) + ,tag) + :hints (("goal" :in-theory (enable ,name tag)))))) + (defun parse-defprod (x xvar our-fixtypes fixtypes) (b* (((cons name args) x) ((unless (symbolp name)) @@ -1079,9 +1180,19 @@ `(acl2-count ,xvar))) (field-names (flexprod-fields->names (flexprod->fields (car prods)))) (post-events (if tag - (append (defprod-tag-events pred xvar tag name field-names) + (append (defprod-tag-events-post-ctor tag name field-names) (cdr (assoc :post-events kwd-alist))) - (cdr (assoc :post-events kwd-alist))))) + (cdr (assoc :post-events kwd-alist)))) + (post-pred-events (if tag + (append (defprod-tag-events-post-pred + pred xvar tag name) + (cdr (assoc :post-pred-events kwd-alist))) + (cdr (assoc :post-pred-events kwd-alist)))) + (post-fix-events (if tag + (append (defprod-tag-events-post-fix + pred fix xvar name) + (cdr (assoc :post-fix-events kwd-alist))) + (cdr (assoc :post-fix-events kwd-alist))))) (make-flexsum :name name :pred pred :fix fix @@ -1094,31 +1205,533 @@ :measure measure :kwd-alist (list* (cons :///-events post-///) (cons :post-events post-events) + (cons :post-pred-events post-pred-events) + (cons :post-fix-events post-fix-events) kwd-alist) :orig-prods orig-prods :inline inline :recp (flexprods-recursivep prods) :typemacro 'defprod))) +;; --- Defoption parsing --- + +(defconst *option-keywords* + '(:pred :fix :equiv :count ;; function names + :measure ;; term + :measure-debug + :xvar ;; var name + :no-count + :parents :short :long ;; xdoc + :inline + :layout ;; :list, :tree, :alist + :case + :base-case-override + :prepwork + :post-pred-events + :post-fix-events + :post-events + :enable-rules)) + +(defun defoption-post-pred-events (x) + (b* (((flexsum x)) + ((fixtype base) (cdr (assoc :basetype x.kwd-alist))) + (std::mksym-package-symbol x.pred)) + `((defthm ,(std::mksym x.pred '-when- base.pred) + (implies (,base.pred ,x.xvar) + (,x.pred ,x.xvar)) + :hints(("Goal" :in-theory (enable ,x.pred)))) + (defthm ,(std::mksym base.pred '-when- x.pred) + (implies (and (,x.pred ,x.xvar) + (double-rewrite ,x.xvar)) + (,base.pred ,x.xvar)) + :hints(("Goal" :in-theory (enable ,x.pred))))))) + +(defun defoption-post-fix-events (x) + (b* (((flexsum x)) + ((fixtype base) (cdr (assoc :basetype x.kwd-alist))) + (std::mksym-package-symbol x.pred)) + `((local + (defthm ,(intern-in-package-of-symbol + (concatenate 'string + "DEFOPTION-LEMMA-" (symbol-name base.fix) "-NONNIL") + base.fix) + (,base.fix x) + :hints (("goal" :use ((:theorem (,base.pred (,base.fix x))) + (:theorem (not (,base.pred nil)))) + :in-theory '((,base.pred))) + (and stable-under-simplificationp + '(:in-theory (enable)))) + :rule-classes :type-prescription)) + (defthm ,(std::mksym x.fix '-under-iff) + (iff (,x.fix ,x.xvar) ,x.xvar) + :hints(("Goal" :in-theory (enable ,x.fix)))) + (defrefinement ,x.equiv ,base.equiv + :hints (("Goal" :in-theory (enable ,x.fix)) + (and stable-under-simplificationp + '(:in-theory (enable ,base.equiv)))))))) + +(defun parse-option (x xvar these-fixtypes fixtypes) + (b* (((list* name basetype args) x) + ((unless (symbolp name)) + (er hard? 'parse-option + "Malformed option: ~x0: name must be a symbol" x)) + ((unless (symbolp basetype)) + (er hard? 'parse-option + "Malformed option: ~x0: basetype must be a symbol" x)) + (base-fixtype (or (find-fixtype basetype these-fixtypes) + (find-fixtype basetype fixtypes))) + ((mv pre-/// post-///) (std::split-/// 'parse-option args)) + ((mv kwd-alist orig-prods) + (extract-keywords 'parse-option *option-keywords* pre-/// nil)) + (pred (or (getarg :pred nil kwd-alist) + (intern-in-package-of-symbol (cat (symbol-name name) "-P") + name))) + (fix (or (getarg :fix nil kwd-alist) + (intern-in-package-of-symbol (cat (symbol-name name) "-FIX") + name))) + (equiv (or (getarg :equiv nil kwd-alist) + (intern-in-package-of-symbol (cat (symbol-name name) "-EQUIV") + name))) + (case (getarg! :case + (intern-in-package-of-symbol (cat (symbol-name name) "-CASE") + name) + kwd-alist)) + (inline (get-deftypes-inline-opt *inline-defaults* kwd-alist)) + (count (flextype-get-count-fn name kwd-alist)) + (xvar (or (getarg :xvar xvar kwd-alist) + (car (find-symbols-named-x (getarg :measure nil kwd-alist))) + (intern-in-package-of-symbol "X" name))) + (flexprods-in + `((:none :cond (not ,xvar) :ctor-body nil) + (:some :cond t + :fields ((val :type ,basetype :acc-body ,xvar)) + :ctor-body val))) + (prods (parse-flexprods flexprods-in name nil kwd-alist xvar nil these-fixtypes fixtypes)) + (- (flexprods-check-xvar xvar prods)) + ((when (atom prods)) + (er hard? 'parse-option + "Malformed SUM ~x0: Must have at least one product")) + (measure (or (getarg :measure nil kwd-alist) + `(acl2-count ,xvar))) + (kwd-alist (cons (cons :basetype base-fixtype) + (if post-/// + (cons (cons :///-events post-///) + kwd-alist) + kwd-alist))) + (flexsum (make-flexsum :name name + :pred pred + :fix fix + :equiv equiv + :case case + :count count + :prods prods + :shape t + :xvar xvar + :inline inline + :measure measure + :kwd-alist kwd-alist + :orig-prods orig-prods + :recp (flexprods-recursivep prods) + :typemacro 'defoption)) + (post-pred-events + (append (defoption-post-pred-events flexsum) + (cdr (assoc :post-pred-events kwd-alist)))) + (post-fix-events + (append (defoption-post-fix-events flexsum) + (cdr (assoc :post-fix-events kwd-alist)))) + (kwd-alist `((:post-pred-events . ,post-pred-events) + (:post-fix-events . ,post-fix-events) + . ,kwd-alist))) + (change-flexsum flexsum :kwd-alist kwd-alist))) + + + +;; --- Deftranssum parsing --- + +(defconst *transsum-keywords* + '(:pred :fix :equiv :count ;; function names + :measure ;; term + :measure-debug + :xvar ;; var name + :no-count + :parents :short :long ;; xdoc + :inline + :layout ;; :list, :tree, :alist + :case + :base-case-override + :prepwork + :post-pred-events + :post-fix-events + :post-events + :enable-rules)) + + +(define get-flexsum-from-types (name types) + (if (atom types) + nil + (or (and (eq (tag (car types)) :sum) + (eq (flexsum->name (car types)) name) + (car types)) + (get-flexsum-from-types name (cdr types))))) + + + +(define get-flexsum-info (name world) + :returns (suminfo?) + (b* ((table (get-flextypes world)) + (entry (cdr (assoc name table))) + ((unless entry) + (raise "~x0 not found in the flextypes table." name)) + ((unless (flextypes-p entry)) + (raise "flextypes table entry for ~x0 is malformed???" name)) + ((flextypes entry) entry) + ;; ((unless (equal (len entry.types) 1)) + ;; (raise "~x0 doesn't look like a defprod; expected one sum type but found ~x1." + ;; name (len entry.types))) + (sum (get-flexsum-from-types name entry.types)) + ((unless (flexsum-p sum)) + (raise "~x0 doesn't look like a deftagsum: expected a top-level sum but found ~x1." + name sum)) + ((flexsum sum) sum) + ;; ((unless (equal (len sum.prods) 1)) + ;; (raise "~x0 doesn't look like a defprod: expected a single product but found ~x1." + ;; name sum.prods)) + ;; (prod (car sum.prods)) + ;; ((unless (flexprod-p prod)) + ;; (raise "~x0 doesn't look like a defprod: expected a flexprod-p but found ~x1." + ;; name prod)) + ) + (make-suminfo :type entry + :sum sum + :tags (flexprods->kinds sum.prods)))) + +(define get-flexsum-infos (sumnames world) + (if (atom sumnames) + nil + (cons (get-flexsum-info (car sumnames) world) + (get-flexsum-infos (cdr sumnames) world)))) + + +(defxdoc deftranssum + :parents (deftypes) + :short "Introduce a transparent sum of products. (beta)" + :long "BOZO document me.
") + +(defun deftranssum-post-pred-events (x) + (b* (((flexsum x)) + ((fixtype base) (cdr (assoc :basetype x.kwd-alist))) + (std::mksym-package-symbol x.pred)) + `((defthm ,(std::mksym x.pred '-when- base.pred) + (implies (,base.pred ,x.xvar) + (,x.pred ,x.xvar)) + :hints(("Goal" :in-theory (enable ,x.pred)))) + (defthm ,(std::mksym base.pred '-when- x.pred) + (implies (and (,x.pred ,x.xvar) + (double-rewrite ,x.xvar)) + (,base.pred ,x.xvar)) + :hints(("Goal" :in-theory (enable ,x.pred))))))) + +(defun deftranssum-post-fix-events (x) + (b* (((flexsum x)) + ((fixtype base) (cdr (assoc :basetype x.kwd-alist))) + (std::mksym-package-symbol x.pred)) + `((local + (defthm ,(intern-in-package-of-symbol + (concatenate 'string + "DEFTRANSSUM-LEMMA-" (symbol-name base.fix) "-NONNIL") + base.fix) + (,base.fix x) + :hints (("goal" :use ((:theorem (,base.pred (,base.fix x))) + (:theorem (not (,base.pred nil)))) + :in-theory '((,base.pred))) + (and stable-under-simplificationp + '(:in-theory (enable)))) + :rule-classes :type-prescription)) + (defthm ,(std::mksym x.pred '-of- x.fix '-tag-forward) + (,x.pred (,x.fix ,x.xvar)) + :rule-classes ((:forward-chaining :trigger-terms ((tag (,x.fix ,x.xvar)))))) + (defthm ,(std::mksym x.fix '-under-iff) + (iff (,x.fix ,x.xvar) ,x.xvar) + :hints(("Goal" :in-theory (enable ,x.fix)))) + (defrefinement ,x.equiv ,base.equiv + :hints (("Goal" :in-theory (enable ,x.fix)) + (and stable-under-simplificationp + '(:in-theory (enable ,base.equiv)))))))) + +(defun transsum-suminfo->flexprod-def (suminfo xvar base-override our-fixtypes lastp) + (b* (((suminfo suminfo)) + ((flexsum sum) suminfo.sum) + ((when (atom suminfo.tags)) + (er hard? 'deftranssum "Bad suminfo?? ~x0" suminfo) + (mv nil nil)) + (kind (car suminfo.tags)) + (base (if base-override + (and (eq base-override kind) kind) + (and (not (find-fixtype sum.name our-fixtypes)) + kind))) + (tag-cond (if (consp (cdr suminfo.tags)) + `(member (tag ,xvar) ',suminfo.tags) + `(eq (tag ,xvar) ',(car suminfo.tags))))) + (mv base + `(,kind + :cond ,(if lastp + t + (if base + `(or (not (mbt (consp ,xvar))) + ,tag-cond) + tag-cond)) + :fields ((val :type ,sum.name :acc-body ,xvar)) + :ctor-body val)))) + + + + +(defun transsum-flexprods-in (suminfos xvar base-override our-fixtypes) + (b* (((when (atom suminfos)) nil) + ((mv base prod) (transsum-suminfo->flexprod-def + (car suminfos) xvar base-override our-fixtypes + (atom (cdr suminfos))))) + (cons prod (transsum-flexprods-in + (cdr suminfos) xvar (or base-override base) our-fixtypes)))) + + +(define suminfo->pred (x) + (b* ((sum (suminfo->sum x)) + (pred (flexsum->pred sum))) + pred)) + +(define suminfo->fix (x) + (b* ((sum (suminfo->sum x)) + (fix (flexsum->fix sum))) + fix)) + + +(defun dts-member-implies-sum-thm (x suminfo) + + ;; This sumuces theorems like this: + ;; (defthm vl-atomguts-p-when-vl-constint-p + ;; (implies (vl-constint-p x) + ;; (vl-atomguts-p x))) + + (b* (((flexsum x)) + (sum-name x.pred) + (mem-name (suminfo->pred suminfo)) + (thm-name (intern-in-package-of-symbol + (concatenate 'string (symbol-name sum-name) "-WHEN-" + (symbol-name mem-name)) + x.pred))) + `(defthm ,thm-name + (implies (,mem-name ,x.xvar) + (,sum-name ,x.xvar)) + :hints(("Goal" :in-theory (enable ,sum-name))) + ;; Without this we got KILLED by vl-modelement-p reasoning in the proofs + ;; of sizing, etc. + :rule-classes ((:rewrite :backchain-limit-lst 1))))) + +(defun dts-member-implies-sum-thms (x suminfos) + (if (atom suminfos) + nil + (cons (dts-member-implies-sum-thm x (car suminfos)) + (dts-member-implies-sum-thms x (cdr suminfos))))) + +(defun dts-tag-equalities (xvar tags) + (if (atom tags) + nil + (cons `(equal (tag ,xvar) ,(car tags)) + (dts-tag-equalities xvar (cdr tags))))) + +(defun dts-by-tag-thm (x suminfo) + + ;; This sumuces theorems like this: + ;; (defthm vl-constint-p-by-tag-when-vl-atomguts-p + ;; (implies (and (equal (tag x) :vl-constint) + ;; (vl-atomguts-p x)) + ;; (vl-constint-p x))) + + (b* (((flexsum x)) + (sum-name x.pred) + (mem-name (suminfo->pred suminfo)) + (mem-tags (suminfo->tags suminfo)) + (thm-name (intern-in-package-of-symbol + (concatenate 'string (symbol-name mem-name) + "-BY-TAG-WHEN-" + (symbol-name sum-name)) + x.name))) + `(defthm ,thm-name + (implies (and (or . ,(dts-tag-equalities x.xvar mem-tags)) + (,sum-name ,x.xvar)) + (,mem-name ,x.xvar)) + :hints(("Goal" :in-theory (enable ,sum-name)))))) + +(defun dts-by-tag-thms (x suminfos) + (if (atom suminfos) + nil + (cons (dts-by-tag-thm x (car suminfos)) + (dts-by-tag-thms x (cdr suminfos))))) + + +(defun dts-when-invalid-tag-hyps (xvar suminfos) + (b* (((when (atom suminfos)) + nil) + (tags (suminfo->tags (car suminfos)))) + (cons `(not (or . ,(dts-tag-equalities xvar tags))) + (dts-when-invalid-tag-hyps xvar (cdr suminfos))))) + +(defun dts-when-invalid-tag-thm (x suminfos) + ;; Generates a theorem like: + ;; (defthm vl-atomicstmt-p-when-invalid-tag + ;; (implies (and (not (equal (tag x) :vl-nullstmt)) + ;; (not (equal (tag x) :vl-assignstmt)) + ;; (not (equal (tag x) :vl-deassignstmt)) + ;; (not (equal (tag x) :vl-enablestmt)) + ;; (not (equal (tag x) :vl-disablestmt)) + ;; (not (equal (tag x) :vl-eventtriggerstmt))) + ;; (not (vl-atomicstmt-p x))) + ;; :rule-classes ((:rewrite :backchain-limit-lst 0))) + (b* (((flexsum x)) + (sum-name x.pred) + (thm-name (intern-in-package-of-symbol + (concatenate 'string (symbol-name sum-name) + "-WHEN-INVALID-TAG") + x.name))) + `(defthm ,thm-name + (implies (and . ,(dts-when-invalid-tag-hyps x.xvar suminfos)) + (not (,sum-name ,x.xvar))) + :hints(("Goal" :in-theory (enable ,sum-name))) + :rule-classes ((:rewrite :backchain-limit-lst 0))))) + + +(defun dts-fwd-disjuncts (xvar suminfos) + (b* (((when (atom suminfos)) + nil) + (tags (fty::suminfo->tags (car suminfos)))) + (append (dts-tag-equalities xvar tags) + (dts-fwd-disjuncts xvar (cdr suminfos))))) + +(defun dts-fwd-thm (x suminfos) + ;; Generates a theorem like: + ;; (defthm tag-when-vl-genelement-p-forward + ;; (implies (vl-genelement-p x) + ;; (or (equal (tag x) :vl-genbase) + ;; (equal (tag x) :vl-genif) + ;; (equal (tag x) :vl-gencase) + ;; (equal (tag x) :vl-genloop) + ;; (equal (tag x) :vl-genblock) + ;; (equal (tag x) :vl-genarray))) + ;; :rule-classes :forward-chaining) + (b* (((flexsum x)) + (sum-name x.pred) + (thm-name (intern-in-package-of-symbol + (concatenate 'string + "TAG-WHEN-" (symbol-name sum-name) "-FORWARD") + x.name))) + `(defthm ,thm-name + (implies (,sum-name ,x.xvar) + (or . ,(dts-fwd-disjuncts x.xvar suminfos))) + :hints(("Goal" :by ,(intern-in-package-of-symbol + (concatenate 'string (symbol-name sum-name) + "-WHEN-INVALID-TAG") + x.name))) + :rule-classes ((:forward-chaining))))) + + +(defun dts-post-pred-thms (x suminfos) + (append (dts-member-implies-sum-thms x suminfos) + (dts-by-tag-thms x suminfos) + (list (dts-when-invalid-tag-thm x suminfos) + (dts-fwd-thm x suminfos)))) + + +(defun parse-transsum (x xvar these-fixtypes fixtypes state) + (b* (((cons name args) x) + ((unless (symbolp name)) + (er hard? 'parse-transsum + "Malformed transsum: ~x0: name must be a symbol" x)) + ((mv pre-/// post-///) (std::split-/// 'parse-transsum args)) + ((mv kwd-alist other-args) + (extract-keywords 'parse-transsum *transsum-keywords* pre-/// nil)) + ((unless (eql (len other-args) 1)) + (er hard? 'parse-transsum + "Extra non-keyword arguments in transsum ~x0" x)) + (sumnames (car other-args)) + (suminfos (get-flexsum-infos sumnames (w state))) + + (pred (or (getarg :pred nil kwd-alist) + (intern-in-package-of-symbol (cat (symbol-name name) "-P") + name))) + (fix (or (getarg :fix nil kwd-alist) + (intern-in-package-of-symbol (cat (symbol-name name) "-FIX") + name))) + (equiv (or (getarg :equiv nil kwd-alist) + (intern-in-package-of-symbol (cat (symbol-name name) "-EQUIV") + name))) + (kind (getarg! :kind + (intern-in-package-of-symbol (cat (symbol-name name) "-KIND") + name) + kwd-alist)) + (case (getarg! :case + (intern-in-package-of-symbol (cat (symbol-name name) "-CASE") + name) + kwd-alist)) + (inline (get-deftypes-inline-opt *inline-defaults* kwd-alist)) + (count (flextype-get-count-fn name kwd-alist)) + (xvar (or (getarg :xvar xvar kwd-alist) + (car (find-symbols-named-x (getarg :measure nil kwd-alist))) + (intern-in-package-of-symbol "X" name))) + (base-override (getarg :base-case-override nil kwd-alist)) + + (flexprods-in (transsum-flexprods-in suminfos xvar base-override these-fixtypes)) + (prods (parse-flexprods flexprods-in name kind kwd-alist xvar nil these-fixtypes fixtypes)) + (- (flexprods-check-xvar xvar prods)) + ((when (atom prods)) + (er hard? 'parse-transsum + "Malformed SUM ~x0: Must have at least one product")) + (measure (or (getarg :measure nil kwd-alist) + `(acl2-count ,xvar))) + (kwd-alist (if post-/// + (cons (cons :///-events post-///) + kwd-alist) + kwd-alist)) + (flexsum (make-flexsum :name name + :pred pred + :fix fix + :equiv equiv + :case case + :count count + :prods prods + :shape `(consp ,xvar) + :xvar xvar + :kind kind + :inline inline + :measure measure + :kwd-alist kwd-alist + :recp (flexprods-recursivep prods) + :typemacro 'deftranssum)) + (post-pred-events + (append (dts-post-pred-thms flexsum suminfos) + (cdr (assoc :post-pred-events kwd-alist)))) + (enable-rules + (cons 'std::tag-reasoning + (cdr (assoc :enable-rules kwd-alist)))) + (kwd-alist `((:post-pred-events . ,post-pred-events) + (:enable-rules . ,enable-rules) + . ,kwd-alist))) + (change-flexsum flexsum :kwd-alist kwd-alist))) + + + + + + + + + + + + + + ;; ------------------------- Deflist Parsing ----------------------- -(def-primitive-aggregate flexlist - (name ;; name of the type - pred ;; preducate function name - fix ;; fix function name - equiv ;; equiv function name - count ;; count function name - elt-type ;; element type name - elt-fix ;; element fixing function - elt-equiv ;; element equiv function - measure ;; termination measure - xvar ;; variable name denoting the object - kwd-alist ;; original keyword alist - true-listp ;; require nil final cdr - elementp-of-nil - cheap ;; passed to std::deflist - recp ;; elt-type is recursive - already-definedp) - :tag :list) (defconst *flexlist-keywords* '(:pred :fix :equiv :count @@ -1191,7 +1804,7 @@ (er hard? 'parse-flexlist "Bad flexlist ~x0: Element type must be a symbol" x)) ((mv elt-type elt-fix elt-equiv recp) - (get-pred/fix/equiv kwd-alist our-fixtypes fixtypes :elt-type)) + (get-pred/fix/equiv (getarg :elt-type nil kwd-alist) our-fixtypes fixtypes)) (pred (or (getarg :pred nil kwd-alist) (intern-in-package-of-symbol (cat (symbol-name name) "-P") name))) @@ -1233,30 +1846,6 @@ :already-definedp already-defined))) ;; ------------------------- Defalist Parsing ----------------------- -(def-primitive-aggregate flexalist - (name ;; name of the type - pred ;; predicate function name - fix ;; fix function name - equiv ;; equiv function name - count ;; count function name - key-type ;; key type name - key-fix ;; key fixing function - key-equiv ;; key equiv function - val-type ;; value type name - val-fix ;; value fixing function - val-equiv ;; value equiv function - strategy ;; :fixkeys or :dropkeys - measure ;; termination measure - xvar ;; variable name denoting the object - kwd-alist ;; original keyword alist - keyp-of-nil ;; passed to std::defalist - valp-of-nil ;; passed to std::defalist - ;; get get-fast ;; more fn names - ;; set set-fast - true-listp - recp - already-definedp) - :tag :alist) (defconst *flexalist-keywords* '(:pred :fix :equiv :count @@ -1293,13 +1882,13 @@ (er hard? 'parse-flexalist "Bad flexalist ~x0: Element type must be a symbol" x)) ((mv key-type key-fix key-equiv key-recp) - (get-pred/fix/equiv kwd-alist our-fixtypes fixtypes :key-type)) + (get-pred/fix/equiv (getarg :key-type nil kwd-alist) our-fixtypes fixtypes)) (val-type (getarg :val-type nil kwd-alist)) ((unless (symbolp val-type)) (er hard? 'parse-flexalist "Bad flexalist ~x0: Element type must be a symbol" x)) ((mv val-type val-fix val-equiv val-recp) - (get-pred/fix/equiv kwd-alist our-fixtypes fixtypes :val-type)) + (get-pred/fix/equiv (getarg :val-type nil kwd-alist) our-fixtypes fixtypes)) (pred (or (getarg :pred nil kwd-alist) (intern-in-package-of-symbol (cat (symbol-name name) "-P") name))) @@ -1408,6 +1997,8 @@ (defflexsum (parse-flexsum (cdar x) xvar our-fixtypes fixtypes)) (defprod (parse-defprod (cdar x) xvar our-fixtypes fixtypes)) (deftagsum (parse-tagsum (cdar x) xvar our-fixtypes fixtypes)) + (defoption (parse-option (cdar x) xvar our-fixtypes fixtypes)) + (deftranssum (parse-transsum (cdar x) xvar our-fixtypes fixtypes state)) (deflist (parse-flexlist (cdar x) xvar our-fixtypes fixtypes state)) (defalist (parse-flexalist (cdar x) xvar our-fixtypes fixtypes state)) (defmap (change-flexalist @@ -1447,16 +2038,6 @@ (cons (flextype-form->fixtype (car x)) (collect-flextypelist-fixtypes (cdr X))))) -(def-primitive-aggregate flextypes - (name - types ;; flexlist and flexsums - no-count ;; skip the count function - kwd-alist - ;; prepwork - ;; post-pred-events - ;; post-fix-events - ;; post-events - recp)) (defconst *flextypes-keywords* '(:xvar :no-count @@ -1703,12 +2284,6 @@ ;; --------------- Kind function & case macro (sums) ---------- -(defun flexprods->kinds (prods) - (if (atom prods) - nil - (cons (flexprod->kind (car prods)) - (flexprods->kinds (cdr prods))))) - ;; returns something like: ;; (((not x) :null) ;; ((atom x) :var) @@ -1793,7 +2368,9 @@ (defun flexsum-case-macro-fn (var-or-binding rest-args sum) (b* (((flexsum sum) sum) - (var (if (consp var-or-binding) (car var-or-binding) var-or-binding)) + ((when (consp var-or-binding)) + (er hard? 'flexsum-case-macro "Requires a variable, rather than ~x0" var-or-binding)) + (var var-or-binding) (kinds (flexprods->kinds sum.prods)) (allowed-keywordlist-keys (append kinds '(:otherwise))) (allowed-parenthesized-keys (append kinds '(acl2::otherwise :otherwise acl2::&))) @@ -2072,16 +2649,20 @@ (stdx (intern-in-package-of-symbol "X" x.pred)) (stda (intern-in-package-of-symbol "A" x.pred))) `((deffixcong ,x.equiv ,x.elt-equiv (car x) x + :pkg ,x.equiv :hints (("goal" :expand ((,x.fix x)) :in-theory (enable acl2::default-car)))) (deffixcong ,x.equiv ,x.equiv (cdr x) x + :pkg ,x.equiv :hints (("goal" :expand ((,x.fix x))))) (deffixcong ,x.elt-equiv ,x.equiv (cons x y) x + :pkg ,x.equiv :hints (("goal" :Expand ((:free (a b) (,x.fix (cons a b))))))) (deffixcong ,x.equiv ,x.equiv (cons x y) y + :pkg ,x.equiv :hints (("goal" :Expand ((:free (a b) (,x.fix (cons a b))))))) (defthm ,(intern-in-package-of-symbol (cat "CONSP-OF-" (symbol-name x.fix)) @@ -2131,13 +2712,16 @@ (stdx (intern-in-package-of-symbol "X" x.pred))) `(,@(and x.key-type (eq x.strategy :fix-keys) `((deffixcong ,x.key-equiv ,x.equiv (cons (cons k v) x) k + :pkg ,x.equiv :hints (("goal" :Expand ((:free (a b) (,x.fix (cons a b))))))))) ,@(and x.val-type `((deffixcong ,x.val-equiv ,x.equiv (cons (cons k v) x) v + :pkg ,x.equiv :hints (("goal" :Expand ((:free (a b) (,x.fix (cons a b))))))))) (deffixcong ,x.equiv ,x.equiv (cons x y) y + :pkg ,x.equiv :hints (("goal" :Expand ((:free (a b) (,x.fix (cons a b))))))) (defthm ,(intern-in-package-of-symbol (cat (symbol-name x.fix) "-OF-ACONS") @@ -3441,6 +4025,7 @@ (defun deftagsum-prod-doc (sum ; the containing sum type prod ; one of the products within it + parents ; usually (sum.name) base-pkg state) ;; Returns (mv events state) (b* (((flexsum sum) sum) @@ -3456,7 +4041,7 @@ (acc (revappend-chars (or prod.long "") acc)) (long (rchars-to-string acc)) (top-doc `((defxdoc ,prod.type-name - :parents (,sum.name) + :parents ,parents :short ,prod.short :long ,long))) (make/change (defprod-ctor-autodoc prod)) @@ -3472,12 +4057,12 @@ ) state))) -(defun deftagsum-prods-doc (sum prods base-pkg state) +(defun deftagsum-prods-doc (sum prods parents base-pkg state) ;; Returns (mv events state) (b* (((when (atom prods)) (mv nil state)) - ((mv events1 state) (deftagsum-prod-doc sum (car prods) base-pkg state)) - ((mv events2 state) (deftagsum-prods-doc sum (cdr prods) base-pkg state))) + ((mv events1 state) (deftagsum-prod-doc sum (car prods) parents base-pkg state)) + ((mv events2 state) (deftagsum-prods-doc sum (cdr prods) parents base-pkg state))) (mv (append events1 events2) state))) @@ -3535,13 +4120,14 @@ :parents ,parents :short ,short :long ,long))) + (type-names (flexprodlist->type-names x.prods)) ((mv prods-doc state) - (deftagsum-prods-doc x x.prods base-pkg state))) + (deftagsum-prods-doc x x.prods (list x.name) base-pkg state))) (mv (append main-doc prods-doc `((xdoc::order-subtopics ,x.name (,x.pred ,x.fix ,x.kind ,x.equiv ,x.count - . ,(flexprodlist->type-names x.prods))))) + . ,type-names)))) state))) (defun defflexsum->defxdoc (x parents kwd-alist base-pkg state) @@ -3564,15 +4150,68 @@ :parents ,parents :short ,short :long ,long))) + (type-names (flexprodlist->type-names x.prods)) + (sum-name-shared-with-prod-name (member x.name type-names)) + (parents (if sum-name-shared-with-prod-name parents (list x.name))) ((mv prods-doc state) - (deftagsum-prods-doc x x.prods base-pkg state))) - (mv (append main-doc + (deftagsum-prods-doc x x.prods parents base-pkg state))) + (mv (append (and (not sum-name-shared-with-prod-name) main-doc) prods-doc `((xdoc::order-subtopics ,x.name (,x.pred ,x.fix ,x.kind ,x.equiv ,x.count - . ,(flexprodlist->type-names x.prods))))) + . ,type-names)))) + state))) + +(defun defoption->defxdoc (x parents kwd-alist base-pkg state) + ;; Returns (mv events state) + (declare (ignorable x parents base-pkg)) + (b* (((flexsum x) x) + (short (cdr (assoc :short kwd-alist))) + (long (cdr (assoc :long kwd-alist))) + (acc nil) + ((fixtype base) (cdr (assoc :basetype x.kwd-alist))) + (acc (revappend-chars "This is an option type based on @(see " acc)) + (acc (revappend-chars (symbol-name base.name) acc)) + (acc (revappend-chars "), introduced by @(see fty::defoption).
" acc)) + (acc (cons #\Newline acc)) + (acc (revappend-chars (or long "") acc)) + (long (rchars-to-string acc)) + (main-doc `((defxdoc ,x.name + :parents ,parents + :short ,short + :long ,long)))) + (mv (append main-doc + `((xdoc::order-subtopics ,x.name + (,x.pred ,x.fix ,x.equiv ,x.count)))) + state))) + +(defun deftranssum->defxdoc (x parents kwd-alist base-pkg state) + ;; Returns (mv events state) + (declare (ignorable x parents base-pkg)) + (b* (((flexsum x) x) + (short (cdr (assoc :short kwd-alist))) + (long (cdr (assoc :long kwd-alist))) + (acc nil) + ((fixtype base) (cdr (assoc :basetype x.kwd-alist))) + (acc (revappend-chars + "This is a transparent sum type using @(see + fty::deftranssum).
" + acc)) + (acc (cons #\Newline acc)) + (acc (revappend-chars (or long "") acc)) + (long (rchars-to-string acc)) + (main-doc `((defxdoc ,x.name + :parents ,parents + :short ,short + :long ,long)))) + (mv (append main-doc + `((xdoc::order-subtopics ,x.name + (,x.pred ,x.fix ,x.equiv ,x.count)))) state))) + + + (defun flexsum->defxdoc (x parents kwd-alist state) ;; Returns (mv events state) (b* ((__function__ 'flexsum->defxdoc) @@ -3585,6 +4224,8 @@ (defprod (defprod->defxdoc x parents kwd-alist base-pkg state)) (deftagsum (deftagsum->defxdoc x parents kwd-alist base-pkg state)) (defflexsum (defflexsum->defxdoc x parents kwd-alist base-pkg state)) + (defoption (defoption->defxdoc x parents kwd-alist base-pkg state)) + (deftranssum (deftranssum->defxdoc x parents kwd-alist base-pkg state)) (t (mv (raise "~x0: unknown typemacro" x.name) state))))) (defun flextype->defxdoc (x parents kwd-alist state) @@ -3867,36 +4508,34 @@ (append (cdr (assoc :enable-rules (flextypes->kwd-alist x))) (flextypelist-collect-enable-rules (flextypes->types x)))) -(defun find-type-prescription-rule-for-rune (rune type-prescriptions) - (if (atom type-prescriptions) - nil - (if (equal rune (acl2::access acl2::type-prescription (car type-prescriptions) :rune)) - (car type-prescriptions) - (find-type-prescription-rule-for-rune rune (cdr type-prescriptions))))) - -(defun find-type-prescription-rule-in-props (rune props) - (cond ((endp props) nil) - ((eq (cadar props) 'acl2::type-prescriptions) - (or (find-type-prescription-rule-for-rune rune (cddar props)) - (find-type-prescription-rule-in-props rune (cdr props)))) - (t (find-type-prescription-rule-in-props rune (cdr props))))) - -(defun collect-uncond-type-prescriptions (runic-theory wrld) - (if (atom runic-theory) +(defun collect-uncond-type-prescriptions-from-list (x ens) + (if (atom x) nil - (b* ((rune (car runic-theory)) - ((unless (eq (car rune) :type-prescription)) - (collect-uncond-type-prescriptions (cdr runic-theory) wrld)) - (name (cadr rune)) - (suffix (cdr (acl2::decode-logical-name name wrld))) - (segment (acl2::world-to-next-event suffix)) - (props (acl2::actual-props segment nil nil)) - (type-prescription (find-type-prescription-rule-in-props rune props)) - ((when (and type-prescription - (eq (acl2::access acl2::type-prescription type-prescription :hyps) nil))) - (cons rune (collect-uncond-type-prescriptions (cdr runic-theory) wrld)))) - (collect-uncond-type-prescriptions (cdr runic-theory) wrld)))) - + (if (and (acl2::enabled-numep + (acl2::access acl2::type-prescription (car x) :nume) ens) + (not (acl2::access acl2::type-prescription (car x) :hyps))) + (let ((rune (acl2::access acl2::type-prescription (car x) :rune))) + (if (eq (car rune) :type-prescription) + (cons rune + (collect-uncond-type-prescriptions-from-list (cdr x) ens)) + (collect-uncond-type-prescriptions-from-list (cdr x) ens))) + (collect-uncond-type-prescriptions-from-list (cdr x) ens)))) + + +(defun collect-uncond-type-prescriptions (wrld ens fns-seen) + (declare (xargs :guard (plist-worldp wrld))) + (if (atom wrld) + nil + (b* (((list* sym key val) (car wrld)) + ((unless (eq key 'acl2::type-prescriptions)) + (collect-uncond-type-prescriptions (cdr wrld) ens fns-seen)) + ((when (hons-get sym fns-seen)) + (collect-uncond-type-prescriptions (cdr wrld) ens fns-seen))) + (append (collect-uncond-type-prescriptions-from-list val ens) + (collect-uncond-type-prescriptions + (cdr wrld) ens (hons-acons sym t fns-seen)))))) + + @@ -3909,21 +4548,25 @@ (encapsulate nil ;; was: defsection ,x.name (with-output :summary (acl2::form) (progn + (local (std::set-returnspec-mrec-default-hints nil)) + (local (std::set-returnspec-default-hints nil)) + (local (fty::set-deffixequiv-default-hints nil)) + (local (fty::set-deffixequiv-mutual-default-hints nil)) + (local (deftheory deftypes-orig-theory (current-theory :here))) ,@(flextype-collect-events :prepwork x.kwd-alist x.types) (set-bogus-defun-hints-ok t) (set-ignore-ok t) (set-irrelevant-formals-ok t) - (local (deftheory deftypes-orig-theory (current-theory :here))) + (local (make-event + `(deftheory deftypes-type-theory + ',(collect-uncond-type-prescriptions + (w state) (acl2::ens state) nil)))) (progn . ,temp-thms) (local (in-theory (disable deftypes-orig-theory))) - (local (make-event - (let ((acl2::world (w state))) - `(in-theory (enable - . ,(collect-uncond-type-prescriptions - (theory 'deftypes-orig-theory) acl2::world)))))) - (local (in-theory (enable deftypes-theory - ,@(flextypes-collect-enable-rules x) - . ,enable-rules))) + (local (in-theory (enable deftypes-type-theory))) + (local (in-theory (acl2::enable* deftypes-theory + ,@(flextypes-collect-enable-rules x) + . ,enable-rules))) (local (set-default-hints '((and stable-under-simplificationp '(:in-theory (enable deftypes-orig-theory)))))) @@ -4070,6 +4713,61 @@ (declare (ignore args)) `(make-event (deftagsum-fn ',form state))) +(defun defoption-fn (whole state) + (b* ((fixtype (flextype-form->fixtype whole)) + (fixtype-al (cons fixtype + (get-fixtypes-alist (w state)))) + (x (parse-option (cdr whole) nil (list fixtype) fixtype-al)) + (x (if (or (flexsum->recp x) + (member :count (cdr whole))) + x + ;; don't make a count if it's not recursive + (change-flexsum x :count nil))) + ((flexsum x) x) + (flextypes (make-flextypes :name x.name + :types (list x) + :no-count (not x.count) + :kwd-alist nil + :recp x.recp))) + (deftypes-events flextypes state))) + +(defxdoc defoption + :parents (fty deftypes) + :short "Define an option type." + :long "BOZO document me. There used to be documentation for this when +it was part of VL. See @(see vl::defoption). I don't know how much of it +is the same...
") + +(defmacro defoption (&whole form &rest args) + (declare (ignore args)) + `(make-event (defoption-fn ',form state))) + + +(defun deftranssum-fn (whole state) + (b* ((fixtype (flextype-form->fixtype whole)) + (fixtype-al (cons fixtype + (get-fixtypes-alist (w state)))) + (x (parse-transsum (cdr whole) nil (list fixtype) fixtype-al state)) + (x (if (or (flexsum->recp x) + (member :count (cdr whole))) + x + ;; don't make a count if it's not recursive + (change-flexsum x :count nil))) + ((flexsum x) x) + (flextypes (make-flextypes :name x.name + :types (list x) + :no-count (not x.count) + :kwd-alist nil + :recp x.recp))) + (deftypes-events flextypes state))) + +(defmacro deftranssum (&whole form &rest args) + (declare (ignore args)) + `(make-event (deftranssum-fn ',form state))) + + + + (defun defprod-fn (whole state) (b* ((fixtype (flextype-form->fixtype whole)) (fixtype-al (cons fixtype @@ -4144,8 +4842,8 @@ particular, this means:The following form may be used to explicitly specify what to do with each argument, or to give hints for each argument's proof. If a type is given -explicitly for each argument, then this can work on a functino not created +explicitly for each argument, then this can work on a function not created using @(see define):
@({ @@ -153,7 +153,7 @@ uses these to prove the constant-normalization and congruence theorems. (These three theorems are discussed in @(see deffixequiv). -As with @(see deffixequiv), you have the choice of either provinding +
As with @(see deffixequiv), you have the choice of either providing @(':omit'), @('args'), or both. However, for @('deffixequiv-mutual') the syntax of these parameters is extended, as shown in the following examples:
@@ -513,11 +513,11 @@ (defun mutual-fixequivs->fix-thm (fixequiv-al defines-entry kwd-alist world) (b* ((thm-macro (std::defines-guts->flag-defthm-macro defines-entry)) (gutslist (std::defines-guts->gutslist defines-entry)) - (fns (defgutslist->names gutslist)) + (fn1 (std::defguts->name-fn (car gutslist))) (hints-look (assoc :hints kwd-alist)) (hints (if hints-look (cdr hints-look) - (deffixequiv-mutual-default-hints (car fns) world)))) + (deffixequiv-mutual-default-hints fn1 world)))) `(with-output :stack :pop (,thm-macro ,@(mutual-fixequivs->inductive-fix-thms diff -Nru acl2-7.0/books/centaur/fty/fixtype.lisp acl2-7.1/books/centaur/fty/fixtype.lisp --- acl2-7.0/books/centaur/fty/fixtype.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/fty/fixtype.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -126,24 +126,59 @@ :pred widget-p :fix widget-fix :equiv widget-equiv - ;; optional: - :executablep nil ;; t by default - :define t ;; nil by default: define the equivalence as equal of fix + ;; optional: + :executablep nil ;; t by default + :define t ;; nil by default: define the equivalence as equal of fix + :inline inline-p ;; t by default: use defun-inline for the equivalence + :equal {eq,eql,...} ;; equal by default: the comparison to use + :forward t ;; nil by default: produce forward-chaining + ;; rules about the equivalence + :hints (...) ;; hints for proving that the equivalence is canonical + :verbosep t ;; nil by default: print verbose output + ) })The optional arguments:
In the event that one is performing a very large decomposition proof (e.g., the theorem @('boothmul-decomp-is-boothmul-via-GL') in book -@('centaur/tutorial/boothmul.lisp'), one should consider using book +@('centaur/esim/tutorial/boothmul.lisp'), one should consider using book @('centaur/esim/stv/stv-decomp-proofs').
") diff -Nru acl2-7.0/books/centaur/gl/eval-f-i-cp.lisp acl2-7.1/books/centaur/gl/eval-f-i-cp.lisp --- acl2-7.0/books/centaur/gl/eval-f-i-cp.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/gl/eval-f-i-cp.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -30,7 +30,7 @@ (in-package "GL") (include-book "gl-util") -(include-book "tools/bstar" :dir :system) +(include-book "std/util/bstar" :dir :system) (include-book "tools/mv-nth" :dir :system) (include-book "misc/hons-help2" :dir :system) (include-book "clause-processors/join-thms" :dir :system) diff -Nru acl2-7.0/books/centaur/gl/factor-fns.lisp acl2-7.1/books/centaur/gl/factor-fns.lisp --- acl2-7.0/books/centaur/gl/factor-fns.lisp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/gl/factor-fns.lisp 2015-05-08 18:07:33.000000000 +0000 @@ -29,7 +29,7 @@ ; Original author: Sol SwordsTshell is an alternative to things like ACL2's @(see -sys-call) or Lisp-specific tools like CCL's @('run-program') that offers -some nice features:
- -Tshell is an ACL2 wrapper around the Shellpool library for +Common Lisp, which is available via @(see quicklisp). It allows you to run +external programs from within ACL2, and has many nice features for handling +output, etc.
+ +Shellpool has its own API +documentation, which you may find useful.
-Note that Tshell requires a trust tag because its implementation requires -some raw Lisp code. The book to load is:
+Note that Tshell requires @(see trust-tag)s because its implementation +requires some raw Lisp code. The book to load is:
@({ - (include-book \"centaur/misc/tshell\" :dir :system) + (include-book \"centaur/misc/tshell\" :dir :system) }) -After loading this book, the first step is then to launch a tshell, -e.g.,
+After loading this book, the first step is then to launch one or more +shells, e.g.,
@({ - (value-triple (tshell-ensure)) + (value-triple (tshell-ensure)) }) -This will launch the subsidiary bash shell that tshell will use to run -programs (actually three bash shells: one to launch programs, one to kill them, -and one for background jobs). This step requires forking ACL2 itself, so you -typically want to do this early in your ACL2 session, before you have allocated -tons of memory.
+This is a thin wrapper around @('shellpool:ensure'). It launches the +subsidiary bash shells that tshell/shellpool will use to run programs. This +step requires forking ACL2 itself, so you typically want to do this early in +your ACL2 session, before you have allocated tons of memory.
After that, you can start launching programs using @(see tshell-call) or @(see tshell-run-background). For instance,
@@ -101,25 +81,13 @@ ACL2 !>(tshell-call \"echo hello\") (tshell-call \"echo hello\") hello ;; <-- output from subprogram, streamed - (T 0 (\"hello\")) ;; <-- finished ok, exit code 0, output lines + (0 (\"hello\")) ;; <-- exit code 0, output lines })") -(define tshell-stop () - :parents (tshell) - :short "Stop any subsidiary bash processes that tshell is running." - :returns (nil) - :long "You could call this when you're done using tshell. We typically -don't bother, since the shells get closed when ACL2 exits anyway.
" - - (cw "Warning: under-the-hood definition of ~s0 not installed?" - __function__)) - - -(define tshell-start () +(define tshell-start (&optional ((n posp "How many shells to start.") '1)) :parents (tshell) - :short "Stop any subsidiary bash processes that tshell is running, then -start new ones. (always forks ACL2)" + :short "Start additional shells for running sub-processes (forks ACL2)." :returns (nil) :long "We usually instead use @(see tshell-ensure), which only starts up new bash processes if they aren't already running.
@@ -127,16 +95,20 @@If you want to use this in a book, you can wrap it in a @(see value-triple), e.g.,
-@({ (value-triple (tshell-start)) })" +@({ (value-triple (tshell-start)) }) + +This is essentially just @('shellpool:start'); see the Shellpool +API documentation for details.
" + (declare (ignorable n)) (cw "Warning: under-the-hood definition of ~s0 not installed?" __function__)) -(define tshell-ensure () +(define tshell-ensure (&optional ((n posp "How many shells to start.") '1)) :parents (tshell) - :short "Starts up the subsidiary bash processes for tshell, but only if they -are not already running. (sometimes forks ACL2)" + :short "Ensure that shells are available for running sub-processes (may fork ACL2)." :returns (nil) :long "If you want to use this in a book, you can wrap it in a @(see value-triple), e.g.,
@@ -145,13 +117,17 @@It's also typically useful to put this before calls of @(see tshell-call) or @(see tshell-run-background), to start up the shells if the user hadn't already -gotten them started earlier.
" +gotten them started earlier. +This is essentially just @('shellpool:ensure'); see the Shellpool +API documentation for details.
" + + (declare (ignorable n)) (cw "Warning: under-the-hood definition of ~s0 not installed?" __function__)) - (defun tshell-useless-clauseproc (clause) (list clause)) @@ -160,6 +136,7 @@ (defsection tshell-call-fn1 :parents (tshell) :short "Logical story for @(see tshell-call)." + :long "We use the @(':partial-theory') feature of @(see define-trusted-clause-processor) to introduce a function, @('tshell-call-fn1'), about which we assume nothing.
@@ -174,17 +151,16 @@ (tshell-call-fn1) :partial-theory (encapsulate - (((tshell-call-fn1 * * *) => (mv * * *))) + (((tshell-call-fn1 * * *) => (mv * *))) (local (defun tshell-call-fn1 (x y z) (declare (ignorable x y z)) - (mv nil 0 nil))) + (mv 0 nil))) (defthm return-type-of-tshell-call-fn1 - (b* (((mv finishedp status lines) + (b* (((mv status lines) (tshell-call-fn1 cmd print save))) - (and (booleanp finishedp) - (natp status) + (and (natp status) (string-listp lines))))))) @@ -194,34 +170,26 @@ forks ACL2)." ((cmd stringp - "This should be an ordinary shell command that takes no input and does - not attempt to do any I/O redirection. It can have arguments, e.g., - you can write something like @('\"echo hello\"') here. But it won't - work to do something like @('\"echo < foo.txt\"').") + "This is the command to run. It can actually be a full-blown shell script. + It should not require any input from the user.") &key - ((print symbolp "This says whether we should print the lines produced by @('cmd') as - they are produced. @('nil') means print nothing, @('t') means - print everything, and any other symbol @('fn') means call the raw - Lisp function @('fn') to do the printing. Using a custom output - function is an advanced feature; see @('tshell-raw.lsp') to - understand how to write such functions.") + they are produced. @('nil') means print nothing, @('t') means print + everything, and any other symbol @('fn') means call the raw Lisp + function @('fn') to do the printing. Custom output functions are an + advanced feature; see @('tshell-raw.lsp') for details.") 't) ((save booleanp - "This says whether we should capture the output lines produced by - @('cmd') and return them as the @('lines') output. If you aren't - going to analyze the program's output, you might want to set this - to @('nil') to cut down on memory usage.") + "This says whether we should capture the stdout/stderr lines produced + by @('cmd') and return them as the @('lines') output. If you aren't + going to analyze the program's output, you might want to set this to + @('nil') to cut down on memory usage.") 't)) :returns - (mv (finishedp booleanp :rule-classes :type-prescription - "This will be @('t') if the command completed normally, or - @('nil') if the command was interrupted.") - - (exit-status natp :rule-classes :type-prescription + (mv (exit-status natp :rule-classes :type-prescription "The exit code from the command. Typically 0 means success and any non-zero value means failure. This is only sensible if @('finishedp') is @('t').") diff -Nru acl2-7.0/books/centaur/misc/tshell-raw.lsp acl2-7.1/books/centaur/misc/tshell-raw.lsp --- acl2-7.0/books/centaur/misc/tshell-raw.lsp 2015-01-13 21:12:30.000000000 +0000 +++ acl2-7.1/books/centaur/misc/tshell-raw.lsp 2015-05-08 18:07:33.000000000 +0000 @@ -31,182 +31,20 @@ (in-package "ACL2") -; NOTE: This file requires that str/strprefixp has been loaded. +; See the Shellpool API documentation to understand all of this. -(defvar *tshell-debug* - ;; Change this to T for verbose debugging information. +(defun tshell-start-fn (n) + (shellpool:start n) nil) -(defmacro tshell-debug (&rest args) - `(when *tshell-debug* (format t ,@args))) - - -; We look for certain strings to know when the program's output ends. This is -; gross, but in practice it should work. - -(defvar *tshell-exit-line* "HORRIBLE_STRING_TO_DETECT_END_OF_TSHELL_COMMAND") -(defvar *tshell-status-line* "HORRIBLE_STRING_TO_DETECT_TSHELL_EXIT_STATUS") -(defvar *tshell-pid-line* "TSHELL_PID") - - -; We actually use two bash processes. *tshell* runs the programs. -; *tshell-killer* is only used to kill programs that *tshell* is running. - -; Bug fix 2013-09-17: these were formerly uninitialized defvars, but Matt -; pointed out that tshell-ensure is assuming they are initialized, so set -; them to nil. - -(defvar *tshell* nil) -(defvar *tshell-killer* nil) - -; I added another bash process for background jobs. This seems easier than -; running them with *tshell*. - -(defvar *tshell-bg* nil) - - -(defun tshell-stop () - ;; Stops any tshell processes that are running. - - #-(and Clozure (not mswindows)) - ;; BOZO maybe eventually add support for other Lisps - nil - - #+(and Clozure (not mswindows)) - (progn (ignore-errors - (when *tshell* - (tshell-debug "TSHELL-STOP: stopping *tshell*~%") - (ccl::signal-external-process *tshell* 9) - (setq *tshell* nil))) - (ignore-errors - (when *tshell-killer* - (tshell-debug "TSHELL-STOP: stopping *tshell-killer*~%") - (ccl::signal-external-process *tshell-killer* 9) - (setq *tshell-killer* nil))) - (ignore-errors - (when *tshell-bg* - (tshell-debug "TSHELL-STOP: stopping *tshell-bg*~%") - (ccl::signal-external-process *tshell-bg* 9) - (setq *tshell-bg* nil))) - nil)) - -(defun tshell-start () - ;; Stops any tshell processes and starts new ones. - - #-(and Clozure (not mswindows)) - ;; BOZO maybe eventually add support for other Lisps - nil - - #+(and Clozure (not mswindows)) - (progn (tshell-debug "TSHELL-START: killing old processes~%") - (tshell-stop) - (tshell-debug "TSHELL-START: starting *tshell*~%") - (setf *tshell* (ccl::run-program "/bin/bash" nil - :wait nil - :input :stream - :output :stream - :error :stream)) - (tshell-debug "TSHELL-START: starting *tshell-killer*~%") - (setf *tshell-killer* (ccl::run-program "/bin/bash" nil - :wait nil - :input :stream - :output :stream - :error :stream)) - (tshell-debug "TSHELL-START: starting *tshell-bg*~%") - (setf *tshell-bg* (ccl::run-program "/bin/bash" nil - :wait nil - :input :stream - :output nil - :error nil)) - nil)) - -(defun tshell-check () - #-(and Clozure (not mswindows)) - t - #+(and Clozure (not mswindows)) - (and (ccl::external-process-p *tshell*) - (ccl::external-process-p *tshell-killer*) - (ccl::external-process-p *tshell-bg*) - (eq (ccl::external-process-status *tshell*) :running) - (eq (ccl::external-process-status *tshell-killer*) :running) - (eq (ccl::external-process-status *tshell-bg*) :running))) - -(defun tshell-ensure () - ;; Stops any tshell processes and starts new ones. - #-(and Clozure (not mswindows)) - ;; BOZO eventually add support for other Lisps - nil - #+(and Clozure (not mswindows)) - (unless (tshell-check) - (tshell-debug "TSHELL-START: starting *tshell*~%") - (setf *tshell* (ccl::run-program "/bin/bash" nil - :wait nil - :input :stream - :output :stream - :error :stream)) - (tshell-debug "TSHELL-START: starting *tshell-killer*~%") - (setf *tshell-killer* (ccl::run-program "/bin/bash" nil - :wait nil - :input :stream - :output :stream - :error :stream)) - (tshell-debug "TSHELL-START: starting *tshell-bg*~%") - (setf *tshell-bg* (ccl::run-program "/bin/bash" nil - :wait nil - :input :stream - :output nil - :error nil))) +(defun tshell-ensure-fn (n) + (shellpool:ensure n) nil) -(defun tshell-parse-status-line (line) - ;; Returns (PREFIX STATUS) - ;; If it's an exit line, PREFIX is anything that was printed before the - ;; exit message stuff (which can happen when the command doesn't print a - ;; newline at the end of its output), and STATUS is an integer that gives - ;; the exit status code. - ;; If it's not an exit line, PREFIX and STATUS are both NIL. - (let ((pos (str::strpos *tshell-status-line* line))) - (if (not pos) - (values nil nil) - (progn - (tshell-debug "Found status line: ~a~%" line) - (let ((prefix (subseq line 0 pos)) - (suffix (subseq line (+ 1 (length *tshell-status-line*) pos)))) - (multiple-value-bind (val next-pos) - (parse-integer suffix) - (declare (ignore next-pos)) - (values prefix val))))))) - -(defun tshell-parse-pid-line (line) - ;; Given a line like TSHELL_PID 1234, we return 1234. - (tshell-debug "Parsing PID line: ~a~%" line) - (unless (str::strprefixp *tshell-pid-line* line) - (error "TSHELL error: bad pid line: ~a." line)) - (multiple-value-bind (val pos) - (parse-integer (subseq line (+ 1 (length *tshell-pid-line*)))) - (declare (ignore pos)) - val)) - -#+(and Clozure (not mswindows)) -(defun tshell-kill (pid) - ;; Use the tshell-killer process to try to kill process PID. - (tshell-debug "TSHELL-KILL: killing ~a.~%" pid) - (let* ((killer-in (ccl::external-process-input-stream *tshell-killer*))) - -; Wow, this is tricky. Want to kill not only the process, but all processes -; that it spawns. To do this: -; 1. First look up the process's parent, i.e., the bash that is running -; inside of *tshell*. -; 2. Find all processes with *tshell* as their parent, removing *tshell* -; itself. -; 3. Kill everything found in 2. - - (format killer-in "PARENT=`ps -o pgrp ~a | tail -1`~%" pid) - (format killer-in "NOT_PARENT=`pgrep -g $PARENT | grep -v $PARENT`~%") - (format killer-in "kill -9 $NOT_PARENT~%") - (force-output killer-in))) - -(defun tshell-echo (line buf stream) +(defun tshell-echo (line ; current line of stderr or stdout output + rlines ; previous lines of output, in reverse order, if :save t + stream ; stream to print to + ) ; This is how tshell prints output from the sub-program using :print t. ; @@ -220,186 +58,26 @@ ; We could probably make this more general. At least it's better than it was ; before. - (declare (ignorable buf)) + (declare (ignorable rlines)) (write-line line stream) (force-output stream)) -(defun tshell-echo-alldone (stream) - (declare (ignorable stream)) - -; Called by tshell after all the output has been printed with tshell-echo, in -; case tshell-echo wants to not print newlines right away. BOZO this doesn't -; really fit into our output filtering scheme. Fortunately it isn't being used -; by anything anymore. (It was used as part of the original AIGPU to implement -; some carriage-return hacks, but that's all deprecated now.) - - nil) - (defun tshell-call-fn (cmd print save) - ;; See the documentation in tshell.lisp. - - (unless (tshell-check) - (error "Invalid *tshell*, *tshell-killer*, or *tshell-bg* -- did you call (tshell-start)?")) - - #-(and Clozure (not mswindows)) - (error "Oops, TSHELL isn't implemented for this Lisp.") - - #+(and Clozure (not mswindows)) - (let* ((tshell-in (ccl::external-process-input-stream *tshell*)) - (tshell-out (ccl::external-process-output-stream *tshell*)) - (tshell-err (ccl::external-process-error-stream *tshell*)) - (pid 0) - (exit-status 1) - (line nil) - (stdout-exit nil) - (stderr-exit nil) - (buf nil) - (print (if (eq print t) 'tshell-echo print)) - (stream (get-output-stream-from-channel *standard-co*)) - - -; To run a command, we basically tell our bash shell to execute: -; -; (cmd < /dev/null 2>&1 ; echo EXIT_STATUS $?) & -; echo TSHELL_PID $! 1>&2 -; wait -; echo END_STRING -; echo END_STRING 1>&2 -; -; The EXIT_STATUS printing must be associated with CMD, so that waiting and -; such will work. -; -; The TSHELL_PID line lets us read the PID for the child process on the first -; line of stderr, and hence we can kill it if we are interrupted. It will -; actually hold the PID for the subshell containing both the command and echo -; statement. -; -; The horrible strings we print are used to determine when we've reached the -; end of the output associated with this command. Of course, there's no -; guarantee that the program itself doesn't emit these strings, but in practice -; it won't happen. - - (nl (coerce (list #\Newline) 'string)) - (cmd (concatenate 'string - "(" cmd " < /dev/null 2>&1 ; echo " *tshell-status-line* " $? ) &" nl - "echo " *tshell-pid-line* " $! 1>&2" nl - "wait" nl - "echo " *tshell-exit-line* nl - "echo " *tshell-exit-line* " 1>&2" nl))) - - (tshell-debug "TSHELL_RUN~%~a~%" cmd) - - (write-line cmd tshell-in) - (finish-output tshell-in) - - (setq pid (tshell-parse-pid-line (read-line tshell-err))) - - (tshell-debug "PID is ~a.~%" pid) - - (unwind-protect - - (progn - ;; Read command output until we find the exit line. - (loop do - (block continue - (setq line (read-line tshell-out)) - (tshell-debug "** raw tshell stdout line: ~a~%" line) - - (multiple-value-bind - (prefix code) - (tshell-parse-status-line line) - (tshell-debug "** attempt to parse exit status: prefix=~a, code=~a~%" - prefix code) - (when code - (tshell-debug "TSHELL_STATUS is ~a.~%" code) - (setq exit-status code) - - ;; Gah, so totally gross -- keep in sync with 'line' - ;; handling below - (unless (equal prefix "") - (when print - (funcall print prefix buf stream)) - (when save - (push prefix buf))) - (return-from continue))) - - (when (equal line *tshell-exit-line*) - (tshell-debug "TSHELL_EXIT on STDOUT~%") - (setq stdout-exit t) - (loop-finish)) - - ;; Keep in sync with 'prefix' handling above - (when print - (funcall print line buf stream)) - (when save - (push line buf)))) - - ;; Read stderr until we find the exit line. - (loop do - (setq line (read-line tshell-err)) - (tshell-debug "** raw tshell stderr line: ~a~%" line) - (when (equal line *tshell-exit-line*) - (tshell-debug "TSHELL_EXIT on STDERR: ~a~%" line) - (setq stderr-exit t) - (loop-finish)) - (tshell-debug "TSHELL_ERR: ~a.~%" line))) - - (progn - ;; Cleanup in case of interrupts. - (when (not stdout-exit) - (format t "~%; Note: tshell shutting down process ~a.~%" pid) - (tshell-kill pid) - (loop do - (setq line (read-line tshell-out)) - (when (str::strsuffixp *tshell-exit-line* line) - ;; We used to try to match *tshell-exit-line* exactly, but - ;; then we found that if we interrupt while the program has - ;; printed partial output, we can end up with a situation - ;; like: - ;;