From 204f2fa9771ad9e55718dc76205afec7d11b3011 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 3 May 2001 22:17:59 +0000 Subject: [PATCH] 0.6.11.45: more MNA byte-compilation patches (sbcl-devel 2001-04-30 and 2001-05-02) --- package-data-list.lisp-expr | 4 ++ src/code/describe.lisp | 8 ++-- src/code/foreign.lisp | 2 +- src/code/inspect.lisp | 7 ++-- src/code/ntrace.lisp | 9 ++--- src/code/profile.lisp | 12 ++++-- src/code/reader.lisp | 4 +- src/code/target-extensions.lisp | 40 +++++++++++++++---- src/cold/warm.lisp | 6 +-- src/compiler/early-c.lisp | 2 + src/compiler/fndb.lisp | 5 +-- src/compiler/gtn.lisp | 5 ++- src/compiler/ir1opt.lisp | 80 ++++++++++++++++++++++++++++++------- src/compiler/ir1tran.lisp | 11 ++--- src/compiler/ir1util.lisp | 14 +++---- src/compiler/locall.lisp | 9 +++-- src/compiler/main.lisp | 80 +++++++++++++++++++++---------------- src/compiler/node.lisp | 16 ++++++++ src/compiler/pack.lisp | 5 ++- src/compiler/policy.lisp | 24 +++++------ src/compiler/srctran.lisp | 5 ++- src/compiler/target-disassem.lisp | 4 +- src/compiler/typetran.lisp | 11 +++-- src/compiler/x86/arith.lisp | 29 ++++++++++++++ src/pcl/defs.lisp | 2 +- src/pcl/describe.lisp | 3 +- tests/interface.pure.lisp | 34 ++++++++++++++++ version.lisp-expr | 2 +- 28 files changed, 310 insertions(+), 123 deletions(-) create mode 100644 tests/interface.pure.lisp diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2e2ee81..60db088 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -637,6 +637,10 @@ retained, possibly temporariliy, because it might be used internally." ;; hash mixing operations "MIX" "MIXF" + + ;; optimization idioms + "*OPTIMIZE-BYTE-COMPILATION*" + "*OPTIMIZE-EXTERNAL-DESPITE-BYTE-COMPILATION*" ;; Arguably there's no one right value for the system ;; prompt. But Common Lisp makes it easy for you to write diff --git a/src/code/describe.lisp b/src/code/describe.lisp index ad2b039..1d064b3 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -12,8 +12,7 @@ (in-package "SB-IMPL") -;; byte-compile this file -(declaim (optimize (speed 0) (safety 1))) +(declaim #.*optimize-byte-compilation*) (defvar *describe-indentation-step* 3 @@ -26,6 +25,7 @@ (defun describe (x &optional (stream-designator *standard-output*)) #+sb-doc "Print a description of the object X." + (declare #.*optimize-external-despite-byte-compilation*) (let ((stream (out-synonym-of stream-designator))) (pprint-logical-block (stream nil) (fresh-line stream) @@ -181,8 +181,8 @@ (ecase (sb-c::debug-source-from source) (:file (format s "~@:_~A~@:_ Created: " (namestring name)) - (sb-int:format-universal-time s (sb-c::debug-source-created - source))) + (format-universal-time s (sb-c::debug-source-created + source))) (:lisp (format s "~@:_~S" name)))))))))) ;;; Describe a compiled function. The closure case calls us to print diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index a9587fc..23b48c5 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -92,7 +92,7 @@ ;;; he probably has the sophistication to write his own after-save ;;; code to reload the libraries without much difficulty. (push (lambda () (setq *tables-from-dlopen* nil)) - sb-int:*after-save-initializations*) + *after-save-initializations*) (defvar *dso-linker* "/usr/bin/ld") (defvar *dso-linker-options* '("-G" "-o")) diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index 8d75975..5f9ce23 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -11,8 +11,7 @@ (in-package "SB-IMPL") -;; byte-compile this file -(declaim (optimize (speed 0) (safety 1))) +(declaim #.*optimize-byte-compilation*) ;;; The inspector views LISP objects as being composed of parts. A ;;; list, for example, would be divided into its members, and a @@ -45,9 +44,11 @@ (nth (+ n parts-offset) parts))) (defun inspect (object) + (declare #.*optimize-external-despite-byte-compilation*) (unwind-protect (input-loop object (describe-parts object) *standard-output*) - (setf *inspect-object-stack* nil))) + (setf *inspect-object-stack* nil)) + (values)) ;;; When *ILLEGAL-OBJECT-MARKER* occurs in a parts list, it indicates ;;; that that slot is unbound. diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index 9e54bf2..3f72462 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -146,7 +146,7 @@ (when (and info (trace-info-named info)) (untrace-1 fname) (trace-1 fname info new-value))))) -(push #'trace-redefined-update sb-int:*setf-fdefinition-hook*) +(push #'trace-redefined-update *setf-fdefinition-hook*) ;;; Annotate some forms to evaluate with pre-converted functions. Each ;;; form is really a cons (exp . function). Loc is the code location @@ -334,8 +334,7 @@ (nth-value 2 (trace-fdefinition definition))) (trace-fdefinition function-or-name)) (when (gethash fun *traced-functions*) - ;; FIXME: should be STYLE-WARNING - (warn "Function ~S is already TRACE'd, retracing it." function-or-name) + (warn "~S is already TRACE'd, untracing it." function-or-name) (untrace-1 fun)) (let* ((debug-fun (sb-di:function-debug-function fun)) @@ -380,7 +379,7 @@ (unless named (error "can't use encapsulation to trace anonymous function ~S" fun)) - (sb-int:encapsulate function-or-name 'trace `(trace-call ',info))) + (encapsulate function-or-name 'trace `(trace-call ',info))) (t (multiple-value-bind (start-fun cookie-fun) (trace-start-breakpoint-fun info) @@ -577,7 +576,7 @@ (t (cond ((trace-info-encapsulated info) - (sb-int:unencapsulate (trace-info-what info) 'trace)) + (unencapsulate (trace-info-what info) 'trace)) (t (sb-di:delete-breakpoint (trace-info-start-breakpoint info)) (sb-di:delete-breakpoint (trace-info-end-breakpoint info)))) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 4bb691c..57b3a5e 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -193,7 +193,6 @@ ;;; will minimize profiling overhead.) (defun profile-encapsulation-lambdas (encapsulated-fun) (declare (type function encapsulated-fun)) - (declare (optimize speed safety)) (let* ((count 0) (ticks 0) (consing 0) @@ -202,7 +201,8 @@ (values ;; ENCAPSULATION-FUN (lambda (sb-c:&more arg-context arg-count) - #+nil (declare (optimize (speed 3) (safety 0))) ; FIXME: remove #+NIL? + (declare (optimize speed safety)) + ;; FIXME: Probably when this is stable, we should optimize (SAFETY 0). (fastbig-incf-pcounter-or-fixnum count 1) (let ((dticks 0) (dconsing 0) @@ -287,6 +287,7 @@ ;;; Profile the named function, which should exist and not be profiled ;;; already. (defun profile-1-unprofiled-function (name) + (declare #.*optimize-byte-compilation*) (let ((encapsulated-fun (fdefinition name))) (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun) (profile-encapsulation-lambdas encapsulated-fun) @@ -302,6 +303,7 @@ ;;; Profile the named function. If already profiled, unprofile first. (defun profile-1-function (name) + (declare #.*optimize-byte-compilation*) (cond ((fboundp name) (when (gethash name *profiled-function-name->info*) (warn "~S is already profiled, so unprofiling it first." name) @@ -313,6 +315,7 @@ ;;; Unprofile the named function, if it is profiled. (defun unprofile-1-function (name) + (declare #.*optimize-byte-compilation*) (let ((pinfo (gethash name *profiled-function-name->info*))) (cond (pinfo (remhash name *profiled-function-name->info*) @@ -337,6 +340,7 @@ reprofile (useful to notice function redefinition.) If a name is undefined, then we give a warning and ignore it. See also UNPROFILE, REPORT and RESET." + (declare #.*optimize-byte-compilation*) (if (null names) `(loop for k being each hash-key in *profiled-function-name->info* collecting k) @@ -349,11 +353,13 @@ a function. A string names all the functions named by symbols in the named package. NAMES defaults to the list of names of all currently profiled functions." + (declare #.*optimize-byte-compilation*) (if names `(mapc-on-named-functions #'unprofile-1-function ',names) `(unprofile-all))) (defun unprofile-all () + (declare #.*optimize-byte-compilation*) (dohash (name profile-info *profiled-function-name->info*) (declare (ignore profile-info)) (unprofile-1-function name))) @@ -399,7 +405,7 @@ approximately adjusted for profiling overhead, but when RAW is true the unadjusted results are reported. The compensation may be somewhat inaccurate when bignums are involved in runtime calculation, as in a very-long-running Lisp process." - (declare (optimize (speed 0))) + (declare #.*optimize-external-despite-byte-compilation*) (unless (boundp '*overhead*) (setf *overhead* (compute-overhead))) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 6d921b1..f91d66a 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -632,11 +632,11 @@ (defvar *read-suppress* nil #!+sb-doc - "Suppresses most interpreting of the reader when T") + "Suppress most interpreting in the reader when T.") (defvar *read-base* 10 #!+sb-doc - "The radix that Lisp reads numbers in.") + "the radix that Lisp reads numbers in") (declaim (type (integer 2 36) *read-base*)) ;;; Modify the read buffer according to READTABLE-CASE, ignoring diff --git a/src/code/target-extensions.lisp b/src/code/target-extensions.lisp index fe2bbfc..b80eb8d 100644 --- a/src/code/target-extensions.lisp +++ b/src/code/target-extensions.lisp @@ -1,10 +1,10 @@ -;;;; This file contains things for the extensions package which can't -;;;; be built at cross-compile time, and perhaps also some things -;;;; which might as well not be built at cross-compile time because -;;;; they're not needed then. Things which can't be built at -;;;; cross-compile time (e.g. because they need machinery which only -;;;; exists inside SBCL's implementation of the LISP package) do not -;;;; belong in this file. +;;;; This file contains things for the extensions packages (SB-EXT and +;;;; also "internal extensions" SB-INT) which can't be built at +;;;; cross-compile time, and perhaps also some things which might as +;;;; well not be built at cross-compile time because they're not +;;;; needed then. Things which can't be built at cross-compile time +;;;; (e.g. because they need machinery which only exists inside SBCL's +;;;; implementation of the LISP package) do not belong in this file. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -63,3 +63,29 @@ :format-control "~@<~A: ~2I~_~A~:>" :format-arguments (list prefix-string (strerror errno)) other-condition-args)) + +;;;; optimization idioms + +(eval-when (:compile-toplevel :load-toplevel :execute) + + ;; Byte compile this thing if possible. + (defvar *optimize-byte-compilation* + '(optimize (speed 0) (safety 1))) + + ;; This thing is externally visible, so compiling meta-information + ;; is more important than byte-compiling it; but it's otherwise + ;; suitable for byte-compilation. + ;; + ;; (As long as the byte compiler isn't capable of compiling + ;; meta-information such as the argument list required by functions + ;; (as in sbcl-0.6.12, anyway), it's not suitable for compiling + ;; externally visible things like CL:INSPECT even if their speed + ;; requirements are small enough that it'd otherwise be OK. If some + ;; later version of the byte compiler learns to compile such + ;; meta-information, we'll probably change the implementation of + ;; this idiom so that it causes byte compilation of the thing after + ;; all.) + (defvar *optimize-external-despite-byte-compilation* + '(optimize (speed 1) + ;; still might as well be as small as possible.. + (space 3)))) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 751e447..a361fde 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -205,8 +205,8 @@ ;; other functionality not needed for cold init, moved ;; to warm init to reduce peak memory requirement in ;; cold init - "src/code/describe" ; FIXME: should be byte compiled - "src/code/inspect" ; FIXME: should be byte compiled + "src/code/describe" + "src/code/inspect" "src/code/profile" "src/code/ntrace" "src/code/foreign" @@ -216,7 +216,7 @@ ;; facility is still used in our ANSI DESCRIBE ;; facility, and should be compiled and loaded after ;; our DESCRIBE facility is compiled and loaded. - "src/pcl/describe")) ; FIXME: should probably be byte compiled + "src/pcl/describe")) (let ((fullname (concatenate 'string stem ".lisp"))) (sb-int:/show "about to compile" fullname) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index c707b51..cbfbe8e 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -73,10 +73,12 @@ (defvar *compiler-warning-count*) (defvar *compiler-style-warning-count*) (defvar *compiler-note-count*) +(defvar *constraint-number*) (defvar *converting-for-interpreter*) (defvar *count-vop-usages*) (defvar *current-path*) (defvar *current-component*) +(defvar *delayed-ir1-transforms*) (defvar *policy*) (defvar *dynamic-counts-tn*) (defvar *elsewhere*) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 2baedb4..a3d4f15 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1058,7 +1058,7 @@ (:start index) (:end sequence-end) (:junk-allowed t)) - (values (or pathname null) index) + (values (or pathname null) sequence-end) ()) (defknown merge-pathnames @@ -1185,11 +1185,10 @@ (defknown describe (t &optional (or stream (member t nil))) (values)) (defknown inspect (t) (values)) - (defknown room (&optional (member t nil :default)) (values)) (defknown ed (&optional (or symbol cons filename) &key (:init t) (:display t)) t) -(defknown dribble (&optional filename &key (:if-exists t)) t) +(defknown dribble (&optional filename &key (:if-exists t)) (values)) (defknown apropos (stringable &optional package-designator t) (values)) (defknown apropos-list (stringable &optional package-designator t) list diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 6795bd2..e2520f8 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -127,8 +127,9 @@ (defun return-value-efficency-note (tails) (declare (type tail-set tails)) (let ((funs (tail-set-functions tails))) - (when (policy (lambda-bind (first funs)) (> (max speed space) - inhibit-warnings)) + (when (policy (lambda-bind (first funs)) + (> (max speed space) + inhibit-warnings)) (dolist (fun funs (let ((*compiler-error-context* (lambda-bind (first funs)))) (compiler-note diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 79a89ed..25b0b69 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -981,7 +981,10 @@ (record-optimization-failure node transform args)) (setf (gethash node table) (remove transform (gethash node table) :key #'car))) - t)))) + t) + (:delayed + (remhash node table) + nil)))) ((and flame (valid-function-use node type @@ -993,25 +996,74 @@ (t t)))) -;;; Just throw the severity and args... +;;; When we don't like an IR1 transform, we throw the severity/reason +;;; and args. +;;; +;;; GIVE-UP-IR1-TRANSFORM is used to throw out of an IR1 transform, +;;; aborting this attempt to transform the call, but admitting the +;;; possibility that this or some other transform will later succeed. +;;; If arguments are supplied, they are format arguments for an +;;; efficiency note. +;;; +;;; ABORT-IR1-TRANSFORM is used to throw out of an IR1 transform and +;;; force a normal call to the function at run time. No further +;;; optimizations will be attempted. +;;; +;;; DELAY-IR1-TRANSFORM is used to throw out of an IR1 transform, and +;;; delay the transform on the node until later. REASONS specifies +;;; when the transform will be later retried. The :OPTIMIZE reason +;;; causes the transform to be delayed until after the current IR1 +;;; optimization pass. The :CONSTRAINT reason causes the transform to +;;; be delayed until after constraint propagation. +;;; +;;; FIXME: Now (0.6.11.44) that there are 4 variants of this (GIVE-UP, +;;; ABORT, DELAY/:OPTIMIZE, DELAY/:CONSTRAINT) and we're starting to +;;; do CASE operations on the various REASON values, it might be a +;;; good idea to go OO, representing the reasons by objects, using +;;; CLOS methods on the objects instead of CASE, and (possibly) using +;;; SIGNAL instead of THROW. (declaim (ftype (function (&rest t) nil) give-up-ir1-transform)) (defun give-up-ir1-transform (&rest args) - #!+sb-doc - "This function is used to throw out of an IR1 transform, aborting this - attempt to transform the call, but admitting the possibility that this or - some other transform will later succeed. If arguments are supplied, they are - format arguments for an efficiency note." (throw 'give-up-ir1-transform (values :failure args))) (defun abort-ir1-transform (&rest args) - #!+sb-doc - "This function is used to throw out of an IR1 transform and force a normal - call to the function at run time. No further optimizations will be - attempted." (throw 'give-up-ir1-transform (values :aborted args))) - -;;; Take the lambda-expression Res, IR1 convert it in the proper +(defun delay-ir1-transform (node &rest reasons) + (let ((assoc (assoc node *delayed-ir1-transforms*))) + (cond ((not assoc) + (setf *delayed-ir1-transforms* + (acons node reasons *delayed-ir1-transforms*)) + (throw 'give-up-ir1-transform :delayed)) + ((cdr assoc) + (dolist (reason reasons) + (pushnew reason (cdr assoc))) + (throw 'give-up-ir1-transform :delayed))))) + +;;; Clear any delayed transform with no reasons - these should have +;;; been tried in the last pass. Then remove the reason from the +;;; delayed transform reasons, and if any become empty then set +;;; reoptimize flags for the node. Return true if any transforms are +;;; to be retried. +(defun retry-delayed-ir1-transforms (reason) + (setf *delayed-ir1-transforms* + (remove-if-not #'cdr *delayed-ir1-transforms*)) + (let ((reoptimize nil)) + (dolist (assoc *delayed-ir1-transforms*) + (let ((reasons (remove reason (cdr assoc)))) + (setf (cdr assoc) reasons) + (unless reasons + (let ((node (car assoc))) + (unless (node-deleted node) + (setf reoptimize t) + (setf (node-reoptimize node) t) + (let ((block (node-block node))) + (setf (block-reoptimize block) t) + (setf (component-reoptimize (block-component block)) t))))))) + reoptimize)) + + +;;; Take the lambda-expression RES, IR1 convert it in the proper ;;; environment, and then install it as the function for the call -;;; Node. We do local call analysis so that the new function is +;;; NODE. We do local call analysis so that the new function is ;;; integrated into the control flow. (defun transform-call (node res) (declare (type combination node) (list res)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 27a7497..307d762 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -829,7 +829,7 @@ type (type-approx-intersection2 old-type type)))) (cond ((eq int *empty-type*) - (unless (policy nil (= inhibit-warnings 3)) + (unless (policy *lexenv* (= inhibit-warnings 3)) (compiler-warning "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) @@ -937,7 +937,7 @@ name "in an inline or notinline declaration"))) (etypecase found (functional - (when (policy nil (>= speed inhibit-warnings)) + (when (policy *lexenv* (>= speed inhibit-warnings)) (compiler-note "ignoring ~A declaration not at ~ definition of local function:~% ~S" sense name))) @@ -1029,7 +1029,7 @@ `(values ,@types)) cont res 'values)))) (dynamic-extent - (when (policy nil (> speed inhibit-warnings)) + (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note "compiler limitation:~ ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) @@ -1510,7 +1510,7 @@ (n-allowp (gensym "N-ALLOWP-")) (n-losep (gensym "N-LOSEP-")) (allowp (or (optional-dispatch-allowp res) - (policy nil (zerop safety))))) + (policy *lexenv* (zerop safety))))) (temps `(,n-index (1- ,n-count)) n-key n-value-temp) (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) @@ -2572,7 +2572,8 @@ (when (null (find-uses cont)) (setf (continuation-asserted-type cont) new)) (when (and (not intersects) - (not (policy nil (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? + (not (policy *lexenv* + (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? (compiler-warning "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S" (type-specifier ctype) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 7bb508d..4b3aaf3 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1630,7 +1630,7 @@ (defun compiler-note (format-string &rest format-args) (unless (if *compiler-error-context* (policy *compiler-error-context* (= inhibit-warnings 3)) - (policy nil (= inhibit-warnings 3))) + (policy *lexenv* (= inhibit-warnings 3))) (incf *compiler-note-count*) (print-compiler-message (format nil "note: ~A" format-string) format-args)) @@ -1731,9 +1731,8 @@ ;;; the compiler, hence the BOUNDP check. (defun note-undefined-reference (name kind) (unless (and - ;; (POLICY NIL ..) isn't well-defined except in IR1 - ;; conversion. This BOUNDP test seems to be a test for - ;; whether IR1 conversion is going on. + ;; Check for boundness so we don't blow up if we're called + ;; when IR1 conversion isn't going on. (boundp '*lexenv*) ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below ;; isn't a good idea; we should have INHIBIT-WARNINGS @@ -1741,7 +1740,7 @@ ;; sure what the BOUNDP '*LEXENV* test above is for; it's ;; likely a good idea, but it probably deserves an ;; explanatory comment. - (policy nil (= inhibit-warnings 3))) + (policy *lexenv* (= inhibit-warnings 3))) (let* ((found (dolist (warning *undefined-warnings* nil) (when (and (equal (undefined-warning-name warning) name) (eq (undefined-warning-kind warning) kind)) @@ -1822,9 +1821,8 @@ (defun %event (info node) (incf (event-info-count info)) (when (and (>= (event-info-level info) *event-note-threshold*) - (if node - (policy node (= inhibit-warnings 0)) - (policy nil (= inhibit-warnings 0)))) + (policy (or node *lexenv*) + (= inhibit-warnings 0))) (let ((*compiler-error-context* node)) (compiler-note (event-info-description info)))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 8c18432..c423a66 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -130,7 +130,7 @@ (temps (make-gensym-list (length (lambda-vars fun))))) `(lambda (,n-supplied ,@temps) (declare (type index ,n-supplied)) - ,(if (policy nil (zerop safety)) + ,(if (policy *lexenv* (zerop safety)) `(declare (ignore ,n-supplied)) `(%verify-argument-count ,n-supplied ,nargs)) (%funcall ,fun ,@temps)))) @@ -873,7 +873,8 @@ (not (functional-entry-function fun))) (let* ((ref-cont (node-cont (first refs))) (dest (continuation-dest ref-cont))) - (when (and (basic-combination-p dest) + (when (and dest + (basic-combination-p dest) (eq (basic-combination-fun dest) ref-cont) (eq (basic-combination-kind dest) :local) (not (block-delete-p (node-block dest))) @@ -964,7 +965,9 @@ (call-fun nil)) (when (and (dolist (ref (leaf-refs fun) t) (let ((dest (continuation-dest (node-cont ref)))) - (when (block-delete-p (node-block dest)) (return nil)) + (when (or (not dest) + (block-delete-p (node-block dest))) + (return nil)) (let ((home (node-home-lambda ref))) (unless (eq home fun) (when call-fun (return nil)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 4bdeb1e..871a27c 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -295,24 +295,42 @@ (setf (component-reanalyze component) nil)) (setf (component-reoptimize component) nil) (ir1-optimize component) - (unless (component-reoptimize component) - (maybe-mumble " ") - (return)) - (incf count) - (when (= count *max-optimize-iterations*) - (event ir1-optimize-maxed-out) - (maybe-mumble "* ") - (setf (component-reoptimize component) nil) - (do-blocks (block component) - (setf (block-reoptimize block) nil)) - (return)) + (cond ((component-reoptimize component) + (incf count) + (when (= count *max-optimize-iterations*) + (maybe-mumble "*") + (cond ((retry-delayed-ir1-transforms :optimize) + (maybe-mumble "+") + (setq count 0)) + (t + (event ir1-optimize-maxed-out) + (setf (component-reoptimize component) nil) + (do-blocks (block component) + (setf (block-reoptimize block) nil)) + (return))))) + ((retry-delayed-ir1-transforms :optimize) + (setf count 0) + (maybe-mumble "+")) + (t + (maybe-mumble " ") + (return))) (maybe-mumble ".")) (when cleared-reanalyze (setf (component-reanalyze component) t))) (values)) (defparameter *constraint-propagate* t) -(defparameter *reoptimize-after-type-check-max* 5) + +;;; KLUDGE: This was bumped from 5 to 10 in a DTC patch ported by MNA +;;; from CMU CL into sbcl-0.6.11.44, the same one which allowed IR1 +;;; transforms to be delayed. Either DTC or MNA or both didn't explain +;;; why, and I don't know what the rationale was. -- WHN 2001-04-28 +;;; +;;; FIXME: It would be good to document why it's important to have a +;;; large value here, and what the drawbacks of an excessively large +;;; value are; and it might also be good to make it depend on +;;; optimization policy. +(defparameter *reoptimize-after-type-check-max* 10) (defevent reoptimize-maxed-out "*REOPTIMIZE-AFTER-TYPE-CHECK-MAX* exceeded.") @@ -334,8 +352,9 @@ (defun ir1-phases (component) (declare (type component component)) (let ((*constraint-number* 0) - (loop-count 1)) - (declare (special *constraint-number*)) + (loop-count 1) + (*delayed-ir1-transforms* nil)) + (declare (special *constraint-number* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) (when (or (component-new-functions component) @@ -346,7 +365,8 @@ (when *constraint-propagate* (maybe-mumble "constraint ") (constraint-propagate component)) - (maybe-mumble "type ") + (when (retry-delayed-ir1-transforms :constraint) + (maybe-mumble "Rtran ")) ;; Delay the generation of type checks until the type ;; constraints have had time to propagate, else the compiler can ;; confuse itself. @@ -354,7 +374,8 @@ (component-reanalyze component) (component-new-functions component) (component-reanalyze-functions component)) - (< loop-count (- *reoptimize-after-type-check-max* 2))) + (< loop-count (- *reoptimize-after-type-check-max* 4))) + (maybe-mumble "type ") (generate-type-checks component) (unless (or (component-reoptimize component) (component-reanalyze component) @@ -396,7 +417,7 @@ (entry-analyze component) (ir2-convert component) - (when (policy nil (>= speed compilation-speed)) + (when (policy *lexenv* (>= speed compilation-speed)) (maybe-mumble "copy ") (copy-propagate component)) @@ -461,11 +482,16 @@ *compile-object*)) (null)))))) - ;; We are done, so don't bother keeping anything around. + ;; We're done, so don't bother keeping anything around. (setf (component-info component) nil) (values)) +(defun policy-byte-compile-p (thing) + (policy thing + (and (zerop speed) + (<= debug 1)))) + ;;; Return our best guess for whether we will byte compile code ;;; currently being IR1 converted. This is only a guess because the ;;; decision is made on a per-component basis. @@ -475,11 +501,7 @@ (defun byte-compiling () (if (eq *byte-compiling* :maybe) (or (eq *byte-compile* t) - ;; FIXME: It's bad to share this expression between this - ;; function and LAMBDA-IS-BYTE-COMPILABLE-P (and who knows - ;; where else?), it should be factored out into some - ;; common function. - (policy nil (and (zerop speed) (<= debug 1)))) + (policy-byte-compile-p *lexenv*)) (and *byte-compile* *byte-compiling*))) ;;; Delete components with no external entry points before we try to @@ -501,22 +523,12 @@ (leaf-refs fun)) (return)))))) -(defun lambda-is-byte-compilable-p (lambda) - #| - (format t "~S SPEED=~S DEBUG=~S~%" ; REMOVEME - lambda - (policy (lambda-bind lambda) speed) - (policy (lambda-bind lambda) debug)) - |# - (policy (lambda-bind lambda) - (and (zerop speed) (<= debug 1)))) - (defun byte-compile-this-component-p (component) (ecase *byte-compile* ((t) t) ((nil) nil) ((:maybe) - (every #'lambda-is-byte-compilable-p (component-lambdas component))))) + (every #'policy-byte-compile-p (component-lambdas component))))) (defun compile-component (component) (let* ((*component-being-compiled* component) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 502d4b5..0615b21 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -1070,6 +1070,22 @@ ;; *UNDEFINED-WARNING-LIMIT* calls. (warnings () :type list)) +;;; a helper for the POLICY macro, defined late here so that the +;;; various type tests can be inlined +(declaim (ftype (function ((or list lexenv node functional)) list) + %coerce-to-policy)) +(defun %coerce-to-policy (thing) + (let ((result (etypecase thing + (list thing) + (lexenv (lexenv-policy thing)) + (node (lexenv-policy (node-lexenv thing))) + (functional (lexenv-policy (functional-lexenv thing)))))) + ;; Test the first element of the list as a rudimentary sanity + ;; that it really does look like a valid policy. + (aver (or (null result) (policy-quality-name-p (caar result)))) + ;; Voila. + result)) + ;;;; Freeze some structure types to speed type testing. #!-sb-fluid diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index 854b974..50e4400 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -1434,8 +1434,9 @@ (defun pack (component) (aver (not *in-pack*)) (let ((*in-pack* t) - (optimize (policy nil (or (>= speed compilation-speed) - (>= space compilation-speed)))) + (optimize (policy *lexenv* + (or (>= speed compilation-speed) + (>= space compilation-speed)))) (2comp (component-info component))) (init-sb-vectors component) diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 40998b1..d4cd154 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -86,6 +86,12 @@ ;;; 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) @@ -98,21 +104,15 @@ ;;; syntactic sugar for querying optimization policy qualities ;;; -;;; Evaluate EXPR in terms of the current optimization policy for -;;; NODE, or if NODE is NIL, in terms of the current policy as defined -;;; by *POLICY*. (Using NODE=NIL is only well-defined during -;;; IR1 conversion.) -;;; -;;; EXPR is a form which accesses the policy values by referring to -;;; them by name, e.g. (> SPEED SPACE). -(defmacro policy (node expr) - (let* ((n-policy (gensym)) +;;; Evaluate EXPR in terms of the optimization policy associated with +;;; THING. EXPR is a form which accesses optimization qualities by +;;; 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))) - `(let* ((,n-policy (lexenv-policy ,(if node - `(node-lexenv ,node) - '*lexenv*))) + `(let* ((,n-policy (%coerce-to-policy ,thing)) ,@binds) ,expr))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index f70c854..a6dbdae 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3279,8 +3279,9 @@ ((= nargs 1) `(progn ,@args t)) ((= nargs 2) `(if (,predicate ,(first args) ,(second args)) nil t)) - ((not (policy nil (and (>= speed space) - (>= speed compilation-speed)))) + ((not (policy *lexenv* + (and (>= speed space) + (>= speed compilation-speed)))) (values nil t)) (t (let ((vars (make-gensym-list nargs))) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 1d105db..bf11bb8 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1599,11 +1599,11 @@ (let ((fun (compiled-function-or-lose object))) (if (typep fun 'sb!kernel:byte-function) (sb!c:disassem-byte-fun fun) - ;; we can't detect closures, so be careful + ;; We can't detect closures, so be careful. (disassemble-function (fun-self fun) :stream stream :use-labels use-labels))) - (values))) + nil)) (defun disassemble-memory (address length diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index b23410c..8e860f4 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -264,7 +264,7 @@ (declare (type hairy-type type)) (let ((spec (hairy-type-specifier type))) (cond ((unknown-type-p type) - (when (policy nil (> speed inhibit-warnings)) + (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note "can't open-code test of unknown type ~S" (type-specifier type))) `(%typep ,object ',spec)) @@ -397,7 +397,7 @@ ;;; generated in byte compiled code. (As of sbcl-0.6.5, they could ;;; sometimes be generated when byte compiling inline functions, but ;;; it's quite uncommon.) -- WHN 20000523 -(deftransform %instance-typep ((object spec) * * :when :both) +(deftransform %instance-typep ((object spec) (* *) * :node node :when :both) (aver (constant-continuation-p spec)) (let* ((spec (continuation-value spec)) (class (specifier-type spec)) @@ -419,6 +419,9 @@ class:~% ~S" class)) (t + ;; Delay the type transform to give type propagation a chance. + (delay-ir1-transform node :constraint) + ;; Otherwise transform the type test. (multiple-value-bind (pred get-layout) (cond @@ -435,7 +438,7 @@ (let ((n-layout (gensym))) `(and (,pred object) (let ((,n-layout (,get-layout object))) - ,@(when (policy nil (>= safety speed)) + ,@(when (policy *lexenv* (>= safety speed)) `((when (layout-invalid ,n-layout) (%layout-invalid-error object ',layout)))) (eq ,n-layout ',layout))))) @@ -445,7 +448,7 @@ (n-layout (gensym))) `(and (,pred object) (let ((,n-layout (,get-layout object))) - ,@(when (policy nil (>= safety speed)) + ,@(when (policy *lexenv* (>= safety speed)) `((when (layout-invalid ,n-layout) (%layout-invalid-error object ',layout)))) (if (eq ,n-layout ',layout) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index f6cbab8..cdadbb2 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -250,6 +250,35 @@ (move r x) (inst add r y))))) + +;;;; Special logand cases: (logand signed unsigned) => unsigned + +(define-vop (fast-logand/signed-unsigned=>unsigned + fast-logand/unsigned=>unsigned) + (:args (x :target r :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types signed-num unsigned-num)) + +(define-vop (fast-logand-c/signed-unsigned=>unsigned + fast-logand-c/unsigned=>unsigned) + (:args (x :target r :scs (signed-reg signed-stack))) + (:arg-types signed-num (:constant (unsigned-byte 32)))) + +(define-vop (fast-logand/unsigned-signed=>unsigned + fast-logand/unsigned=>unsigned) + (:args (x :target r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y signed-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types unsigned-num signed-num)) + + (define-vop (fast-+-c/signed=>signed fast-safe-arith-op) (:translate +) (:args (x :target r :scs (signed-reg signed-stack))) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index ba9ff36..334206d 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -541,7 +541,7 @@ (defclass sb-kernel:funcallable-instance (function) () (:metaclass built-in-class)) -(defclass stream (t) () +(defclass stream (sb-kernel:instance) () (:metaclass built-in-class)) (defclass slot-object (t) () diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index 0356fe6..d9a4e2b 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -26,8 +26,7 @@ (in-package "SB-PCL") -;; byte-compile this file -(declaim (optimize (speed 0) (safety 1))) +(declaim #.*optimize-byte-compilation*) (defmethod slots-to-inspect ((class slot-class) (object slot-object)) (class-slots class)) diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp new file mode 100644 index 0000000..a54492c --- /dev/null +++ b/tests/interface.pure.lisp @@ -0,0 +1,34 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +;;; Check for fbound external symbols in public packages that have no +;;; argument list information. (This can happen if we get carried away +;;; with byte compilation, since at least in sbcl-0.6.12 the byte +;;; compiler can't record argument list information.) +(defvar *public-package-names* + '("SB-ALIEN" "SB-C-CALL" "SB-DEBUG" "SB-EXT" "SB-EXT""SB-GRAY" "SB-MP" + "SB-PROFILE" "SB-PCL" "COMMON-LISP")) +(defun has-arglist-info-p (function) + (and (not (typep function 'sb-c::byte-function)) + (sb-kernel:%function-arglist function))) +(defun check-ext-symbols-arglist (package) + (format t "~% Looking at Package: ~A" package) + (do-external-symbols (ext-sym package) + (when (fboundp ext-sym) + (let ((fun (symbol-function ext-sym))) + (unless (has-arglist-info-p fun) + (error "~%Function ~A (~A) has no argument-list information available, ~%~ + and is probably byte-compiled.~%" ext-sym fun)))))) +(dolist (public-package *public-package-names*) + (when (find-package public-package) + (check-ext-symbols-arglist public-package))) diff --git a/version.lisp-expr b/version.lisp-expr index 1a06f06..cf11c11 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.43" +"0.6.11.45" -- 1.7.10.4