Menu
▾
▴
[Sbcl-commits] CVS: sbcl/tests compiler.impure.lisp, 1.88, 1.89 info.before-xc.lisp, 1.2, 1.3
|
From: Nikodemus S. <de...@us...> - 2008-06-04 12:39:47
|
Update of /cvsroot/sbcl/sbcl/tests In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19220/tests Modified Files: compiler.impure.lisp info.before-xc.lisp Log Message: 1.0.17.24: refactor handling of constants in the compiler * Coalesce non-circular lists, bit-vectors, and non-base-strings in the file-compiler. (We could do more, but these are the "easy" ones.) Takes care of OPTIMIZATIONS #34 in practice: outside the file compiler one can still trick the system into similar behaviour, but that seems a fairly academic concern. * Never go through SYMBOL-VALUE at runtime to fetch the value of a constant variable in compiled code. * Use (SYMBOL-VALUE <NAME>) as the load-form to dump references to named constants into fasls. * Signal a continuable error if an attempt to change the SYMBOL-VALUE of a constant variable is made. * Assignments to undefined variables go through SET, so that one cannot accidentally modify a constant by doing something like: (defun set-foo (x) (setq foo x)) (defconstant foo 42) (set-foo 13) * Gets rid of INFO :VARIABLE :CONSTANT-VALUE, and just uses SYMBOL-VALUE to store constant values. * Move definition of SB!XC:LAMBDA-LIST-KEYWORDS to be beginning of the build, and use it instead of the host LAMBDA-LIST-KEYWORDS where appropriate. * Tests. Index: compiler.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/compiler.impure.lisp,v retrieving revision 1.88 retrieving revision 1.89 diff -u -d -r1.88 -r1.89 --- compiler.impure.lisp 28 May 2008 16:23:13 -0000 1.88 +++ compiler.impure.lisp 4 Jun 2008 12:39:41 -0000 1.89 @@ -1551,17 +1551,88 @@ (not (or c d e f g h i j k l m n o p q r s)))))) (wants-many-values 1 42) -;;; constant coalescing (named and unnamed) +;;; constant coalescing + +(defun count-code-constants (x f) + (let ((code (sb-kernel:fun-code-header f)) + (n 0)) + (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) + do (when (equal x (sb-kernel:code-header-ref code i)) + (incf n))) + n)) + +(defvar *lambda*) + +(defun compile2 (lambda) + (let* ((lisp "compiler-impure-tmp.lisp") + (fasl (compile-file-pathname lisp))) + (unwind-protect + (progn + (with-open-file (f lisp :direction :output) + (prin1 `(setf *lambda* ,lambda) f)) + (multiple-value-bind (fasl warn fail) (compile-file lisp) + (declare (ignore warn)) + (when fail + (error "File-compiling ~S failed." lambda)) + (let ((*lambda* nil)) + (load fasl) + (values *lambda* (compile nil lambda))))) + (ignore-errors (delete-file lisp)) + (ignore-errors (delete-file fasl))))) + +;; named and unnamed (defconstant +born-to-coalesce+ '.born-to-coalesce.) -(let* ((f (compile nil '(lambda () - (let ((x (cons +born-to-coalesce+ nil)) - (y (cons '.born-to-coalesce. nil))) - (list x y))))) - (b-t-c 0) - (code (sb-kernel:fun-code-header f))) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) - do (when (eq '.born-to-coalesce. (sb-kernel:code-header-ref code i)) - (incf b-t-c))) - (assert (= 1 b-t-c))) +(multiple-value-bind (file-fun core-fun) + (compile2 '(lambda () + (let ((x (cons +born-to-coalesce+ nil)) + (y (cons '.born-to-coalesce. nil))) + (list x y)))) + (assert (= 1 (count-code-constants '.born-to-coalesce. file-fun))) + (assert (= 1 (count-code-constants '.born-to-coalesce. core-fun)))) + +;; some things must retain identity under COMPILE, but we want to coalesce them under COMPILE-FILE +(defun assert-coalescing (constant) + (let ((value (copy-seq (symbol-value constant)))) + (multiple-value-bind (file-fun core-fun) + (compile2 `(lambda () + (let ((x (cons ,constant nil)) + (y (cons ',value nil))) + (list x y)))) + (assert (= 1 (count-code-constants value file-fun))) + (assert (= 2 (count-code-constants value core-fun))) + (let* ((l (funcall file-fun)) + (a (car (first l))) + (b (car (second l)))) + (assert (and (equal value a) + (equal a b) + (eq a b)))) + (let* ((l (funcall core-fun)) + (a (car (first l))) + (b (car (second l)))) + (assert (and (equal value a) + (equal a b) + (not (eq a b)))))))) + +(defconstant +born-to-coalesce2+ "maybe coalesce me!") +(assert-coalescing '+born-to-coalesce2+) + +(defconstant +born-to-coalesce3+ #*01101001011101110100011) +(assert-coalescing '+born-to-coalesce3+) + +(defconstant +born-to-coalesce4+ '(foo bar "zot" 123 (nested "quux") #*0101110010)) +(assert-coalescing '+born-to-coalesce4+) + +;;; catch constant modifications thru undefined variables +(defun sneak-set-dont-set-me (x) + (ignore-errors (setq dont-set-me x))) +(defconstant dont-set-me 42) +(assert (not (sneak-set-dont-set-me 13))) +(assert (= 42 dont-set-me)) +(defclass some-constant-thing () ()) +(defun sneak-set-dont-set-me2 (x) + (ignore-errors (setq dont-set-me2 x))) +(defconstant dont-set-me2 (make-instance 'some-constant-thing)) +(assert (not (sneak-set-dont-set-me2 13))) +(assert (typep dont-set-me2 'some-constant-thing)) ;;; success Index: info.before-xc.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/info.before-xc.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- info.before-xc.lisp 14 Jul 2005 16:30:43 -0000 1.2 +++ info.before-xc.lisp 4 Jun 2008 12:39:41 -0000 1.3 @@ -21,9 +21,7 @@ :constant)) ;;; It's possible in general for a constant to have the value NIL, but ;;; not for vector-data-offset, which must be a number: -(multiple-value-bind (value successp) - (sb!int:info :variable :constant-value 'sb!vm:vector-data-offset) - (assert value) - (assert successp)) +(assert (boundp 'sb!vm:vector-data-offset)) +(assert (integerp (symbol-value 'sb!vm:vector-data-offset))) (/show "done with tests/info.before-xc.lisp") |