"*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"
--- /dev/null
+;;;; 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.)
+\f
+(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))
;; 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"
\f
;;;; 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.
(defknown %fun-name (function) t (flushable))
(defknown (setf %fun-name) (t function) t (unsafe))
+
+(defknown policy-quality (policy symbol) policy-quality
+ (flushable))
(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))))
(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"))
(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))
;;; 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
(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
(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
;;; 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.
;;; 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
;;;
;;; 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))
+
(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)
(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.
;;; 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"
+
projects / sbcl.git / commitdiff