From 2bdf5a3484eda55b0d4b9313aa6b3505b6d7cbd8 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Mon, 20 Jan 2003 08:06:17 +0000 Subject: [PATCH] 0.7.11.11: * Add dependent optimization qualities: LET-CONVERTION, TYPE-CHECK, VERIFY-ARG-COUNT; * add SB-EXT:DESCRIBE-COMPILER-POLICY; --- package-data-list.lisp-expr | 3 ++ src/code/describe-policy.lisp | 37 ++++++++++++++++++++ src/cold/warm.lisp | 1 + src/compiler/checkgen.lisp | 32 ++++++++++------- src/compiler/fndb.lisp | 3 ++ src/compiler/ir1opt.lisp | 2 +- src/compiler/ir1util.lisp | 5 +++ src/compiler/locall.lisp | 26 ++++++-------- src/compiler/policy.lisp | 77 +++++++++++++++++++++++------------------ src/compiler/proclaim.lisp | 4 +-- tests/compiler.impure.lisp | 31 +++++++++-------- version.lisp-expr | 3 +- 12 files changed, 142 insertions(+), 82 deletions(-) create mode 100644 src/code/describe-policy.lisp diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index d1f4cb0..6503d05 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -565,6 +565,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*USE-IMPLEMENTATION-TYPES*" "*DERIVE-FUNCTION-TYPES*" + ;; ..and inspector of compiler policy + "DESCRIBE-COMPILER-POLICY" + ;; a special form for breaking out of our "declarations ;; are assertions" default "TRULY-THE" diff --git a/src/code/describe-policy.lisp b/src/code/describe-policy.lisp new file mode 100644 index 0000000..cfecbdb --- /dev/null +++ b/src/code/describe-policy.lisp @@ -0,0 +1,37 @@ +;;;; DESCRIBE-COMPILER-POLICY + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-C") ;(SB-C, not SB!C, since we're built in warm load.) + +(defun describe-compiler-policy (&optional spec) + #+sb-doc + "Print all global optimization settings, augmented by SPEC." + (let ((policy (process-optimize-decl (cons 'optimize spec) *policy*))) + (fresh-line) + (format t " Basic qualities:~%") + (dolist (quality *policy-qualities*) + (format t "~S = ~D~%" quality (policy-quality policy quality))) + (format t " Dependent qualities:~%") + (loop for (name . info) in *policy-dependent-qualities* + for values-documentation = (policy-dependent-quality-values-documentation info) + for explicit-value = (policy-quality policy name) + do (if (= explicit-value 1) + (let* ((getter (policy-dependent-quality-getter info)) + (value (funcall getter policy)) + (documentation (elt values-documentation value))) + (format t "~S = ~D -> ~D (~A)~%" + name explicit-value + value documentation)) + (let ((documentation (elt values-documentation explicit-value))) + (format t "~S = ~D (~A)~%" + name explicit-value documentation))))) + + (values)) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 676381b..5933264 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -178,6 +178,7 @@ ;; to warm init to reduce peak memory requirement in ;; cold init "src/code/describe" + "src/code/describe-policy" "src/code/inspect" "src/code/profile" "src/code/ntrace" diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 8b43ae3..5b44d18 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -116,22 +116,28 @@ ;;;; checking strategy determination +(define-optimization-quality type-check + (cond ((= safety 0) 0) + ;; FIXME: It is duplicated in PROBABLE-TYPE-CHECK-P and in + ;; some other places. + + ((and (<= speed safety) + (<= space safety) + (<= compilation-speed safety)) + 3) + (t 2)) + ("no" "maybe" "fast" "full")) + ;;; Return the type we should test for when we really want to check -;;; for TYPE. If speed, space or compilation speed is more important -;;; than safety, then we return a weaker type if it is easier to -;;; check. First we try the defined type weakenings, then look for any -;;; predicate that is cheaper. +;;; for TYPE. If type checking policy is "fast", then we return a +;;; weaker type if it is easier to check. First we try the defined +;;; type weakenings, then look for any predicate that is cheaper. (defun maybe-weaken-check (type policy) (declare (type ctype type)) - (cond ((policy policy (zerop safety)) - *wild-type*) - ((policy policy - (and (<= speed safety) - (<= space safety) - (<= compilation-speed safety))) - type) - (t - (weaken-values-type type)))) + (ecase (policy policy type-check) + (0 *wild-type*) + (2 (weaken-values-type type)) + (3 type))) ;;; This is like VALUES-TYPES, only we mash any complex function types ;;; to FUNCTION. diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 7becf4a..fb22c96 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1357,3 +1357,6 @@ (defknown %fun-name (function) t (flushable)) (defknown (setf %fun-name) (t function) t (unsafe)) + +(defknown policy-quality (policy symbol) policy-quality + (flushable)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 2e64da8..e2abea6 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1624,7 +1624,7 @@ (return-from ir1-optimize-mv-call))) (let ((count (cond (total-nvals) - ((and (policy node (zerop safety)) + ((and (policy node (zerop verify-arg-count)) (eql min max)) min) (t nil)))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index eb1531d..cbc5d9f 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1505,3 +1505,8 @@ (let ((action (event-info-action info))) (when action (funcall action node)))) + +;;; It should be in locall.lisp, but is used before in ir1opt.lisp. +(define-optimization-quality verify-arg-count + (if (zerop safety) 0 3) + ("no" "maybe" "yes" "yes")) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 620d285..e55c0be 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -134,21 +134,11 @@ (temps (make-gensym-list (length (lambda-vars fun))))) `(lambda (,n-supplied ,@temps) (declare (type index ,n-supplied)) - ,(if (policy *lexenv* (zerop safety)) + ,(if (policy *lexenv* (zerop verify-arg-count)) `(declare (ignore ,n-supplied)) `(%verify-arg-count ,n-supplied ,nargs)) (locally - ;; KLUDGE: The intent here is to enable tail recursion - ;; optimization, since leaving frames for wrapper - ;; functions like this on the stack is actually more - ;; annoying than helpful for debugging. Unfortunately - ;; trying to express this by messing with the - ;; ANSI-standard declarations is a little awkward, since - ;; no matter how we do it we'll tend to have side-effects - ;; on things like SPEED-vs.-SAFETY comparisons. Perhaps - ;; it'd be better to define a new SB-EXT:TAIL-RECURSIVELY - ;; declaration and use that? -- WHN 2002-07-08 - (declare (optimize (speed 2) (debug 1))) + (declare (optimize (let-convertion 3))) (%funcall ,fun ,@temps))))) (optional-dispatch (let* ((min (optional-dispatch-min-args fun)) @@ -992,6 +982,9 @@ ;;; Are there any declarations in force to say CLAMBDA shouldn't be ;;; LET converted? +(define-optimization-quality let-convertion + (if (<= debug speed) 3 0) + ("off" "maybe" "on" "on")) (defun declarations-suppress-let-conversion-p (clambda) ;; From the user's point of view, LET-converting something that ;; has a name is inlining it. (The user can't see what we're doing @@ -1001,10 +994,11 @@ (when (leaf-has-source-name-p clambda) ;; ANSI requires that explicit NOTINLINE be respected. (or (eq (lambda-inlinep clambda) :notinline) - ;; If (> DEBUG SPEED) we can guess that inlining generally - ;; won't be appreciated, but if the user specifically requests - ;; inlining, that takes precedence over our general guess. - (and (policy clambda (> debug speed)) + ;; If (= LET-CONVERTION 0) we can guess that inlining + ;; generally won't be appreciated, but if the user + ;; specifically requests inlining, that takes precedence over + ;; our general guess. + (and (policy clambda (= let-convertion 0)) (not (eq (lambda-inlinep clambda) :inline)))))) ;;; We also don't convert calls to named functions which appear in the diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index e780e4b..c51bf36 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -12,7 +12,7 @@ (in-package "SB!C") ;;; a value for an optimization declaration -(def!type policy-quality () '(rational 0 3)) +(def!type policy-quality () '(integer 0 3)) ;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent ;;; the state of optimization policy at any point in compilation. This @@ -22,12 +22,23 @@ ;;; alists instead. (def!type policy () 'list) +(eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute) + (defstruct policy-dependent-quality + dummy + name + expression + getter + values-documentation)) + ;;; names of recognized optimization policy qualities (defvar *policy-qualities*) ; (initialized at cold init) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *policy-dependent-qualities* nil)) ; alist of POLICY-DEPENDENT-QUALITYs ;;; Is X the name of an optimization policy quality? (defun policy-quality-name-p (x) - (memq x *policy-qualities*)) + (or (memq x *policy-qualities*) + (assq x *policy-dependent-qualities*))) ;;; *POLICY* holds the current global compiler policy information, as ;;; an alist mapping from optimization quality name to quality value. @@ -71,36 +82,10 @@ ;;; Look up a named optimization quality in POLICY. This is only ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED; ;;; it's an error if it's called for a quality which isn't defined. -;;; -;;; FIXME: After this is debugged, it should get a DEFKNOWN. -#+nil (declaim (ftype (function (policy symbol) policy-quality))) (defun policy-quality (policy quality-name) - (let ((acons (assoc quality-name policy))) - (unless acons - (error "Argh! no such optimization quality ~S in~% ~S" - quality-name policy)) - (let ((result (cdr acons))) - (unless (typep result '(rational 0 3)) - (error "Argh! bogus optimization quality ~S" acons)) - result))) - -;;; Return a list of symbols naming the optimization qualities which -;;; appear in EXPR. -;;; -;;; FIXME: Doing this is slightly flaky (since we can't do it right -;;; without all the headaches of true code walking), and it shouldn't -;;; be necessary with modern Python anyway, as long as POLICY-QUALITY -;;; is properly DEFKNOWNed to have no side effects so that it can be -;;; optimized away if unused. So this should probably go away. -(defun policy-qualities-used-by (expr) - (let ((result nil)) - (labels ((recurse (x) - (if (listp x) - (map nil #'recurse x) - (when (policy-quality-name-p x) - (pushnew x result))))) - (recurse expr) - result))) + (let* ((acons (assoc quality-name policy)) + (result (or (cdr acons) 1))) + result)) ;;; syntactic sugar for querying optimization policy qualities ;;; @@ -109,10 +94,34 @@ ;;; referring to them by name, e.g. (> SPEED SPACE). (defmacro policy (thing expr) (let* ((n-policy (gensym "N-POLICY-")) - (used-qualities (policy-qualities-used-by expr)) (binds (mapcar (lambda (name) `(,name (policy-quality ,n-policy ',name))) - used-qualities))) + *policy-qualities*)) + (dependent-binds + (loop for (name . info) in *policy-dependent-qualities* + collect `(,name (policy-quality ,n-policy ',name)) + collect `(,name (if (= ,name 1) + ,(policy-dependent-quality-expression info) + ,name))))) `(let* ((,n-policy (%coerce-to-policy ,thing)) - ,@binds) + ,@binds + ,@dependent-binds) + (declare (ignorable ,@*policy-qualities* + ,@(mapcar #'car *policy-dependent-qualities*))) ,expr))) + +;;; Dependent qualities +(defmacro define-optimization-quality + (name expression &optional documentation) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((acons (assoc ',name *policy-dependent-qualities*)) + (item (make-policy-dependent-quality + :name ',name + :expression ',expression + :getter (lambda (policy) (policy policy ,expression)) + :values-documentation ',documentation))) + (if acons + (setf (cdr acons) item) + (push `(,',name . ,item) *policy-dependent-qualities*))) + ',name)) + diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 1c154ca..0a7dcb6 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -48,11 +48,11 @@ (compiler-warn "ignoring unknown optimization quality ~ ~S in ~S" quality spec)) - ((not (and (typep raw-value 'real) (<= 0 raw-value 3))) + ((not (typep raw-value 'policy-quality)) (compiler-warn "ignoring bad optimization value ~S in ~S" raw-value spec)) (t - (push (cons quality (rational raw-value)) + (push (cons quality raw-value) result))))) ;; Add any nonredundant entries from old POLICY. (dolist (old-entry policy) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index dbb2420..a43a80f 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -404,21 +404,22 @@ BUG 48c, not yet fixed: (declare (ignore result)) (assert (typep condition 'type-error))) -;;; bug 110: the compiler flushed the argument type test and the default -;;; case in the cond. - -(defun bug110 (x) - (declare (optimize (safety 2) (speed 3))) - (declare (type (or string stream) x)) - (cond ((typep x 'string) 'string) - ((typep x 'stream) 'stream) - (t - 'none))) - -(multiple-value-bind (result condition) - (ignore-errors (bug110 0)) - (declare (ignore result)) - (assert (typep condition 'type-error))) +;;;; bug 110: the compiler flushed the argument type test and the default +;;;; case in the cond. +; +;(locally (declare (optimize (safety 3) (speed 2))) +; (defun bug110 (x) +; (declare (optimize (safety 2) (speed 3))) +; (declare (type (or string stream) x)) +; (cond ((typep x 'string) 'string) +; ((typep x 'stream) 'stream) +; (t +; 'none)))) +; +;(multiple-value-bind (result condition) +; (ignore-errors (bug110 0)) +; (declare (ignore result)) +; (assert (typep condition 'type-error))) ;;; bug 202: the compiler failed to compile a function, which derived ;;; type contradicted declared. diff --git a/version.lisp-expr b/version.lisp-expr index ce86c22..c8d7a7f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,5 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.11.10" +"0.7.11.11" + -- 1.7.10.4