;; 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
(in-package "SB-IMPL")
-;; byte-compile this file
-(declaim (optimize (speed 0) (safety 1)))
+(declaim #.*optimize-byte-compilation*)
\f
(defvar *describe-indentation-step* 3
(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)
(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
;;; 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"))
(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
(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.
(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
(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))
(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)
(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))))
;;; 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)
(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)
;;; 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)
;;; 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)
;;; 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*)
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)
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)))
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)))
(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
-;;;; 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.
:format-control "~@<~A: ~2I~_~A~:>"
:format-arguments (list prefix-string (strerror errno))
other-condition-args))
+\f
+;;;; 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))))
;; 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"
;; 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)
(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*)
(:start index)
(:end sequence-end)
(:junk-allowed t))
- (values (or pathname null) index)
+ (values (or pathname null) sequence-end)
())
(defknown merge-pathnames
(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
(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
(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
(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))
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)
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)))
`(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)."))
(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)))
(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)
(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))
;;; 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
;; 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))
(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))))
(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))))
(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)))
(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))
(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.")
(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)
(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.
(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)
(entry-analyze component)
(ir2-convert component)
- (when (policy nil (>= speed compilation-speed))
+ (when (policy *lexenv* (>= speed compilation-speed))
(maybe-mumble "copy ")
(copy-propagate component))
*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.
(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
(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)
;; *UNDEFINED-WARNING-LIMIT* calls.
(warnings () :type list))
\f
+;;; 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))
+\f
;;;; Freeze some structure types to speed type testing.
#!-sb-fluid
(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)
;;; 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)
;;; 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)))
((= 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)))
(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
(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))
;;; 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))
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
(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)))))
(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)
(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))
+\f
+
(define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
(:translate +)
(:args (x :target r :scs (signed-reg signed-stack)))
(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) ()
(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))
--- /dev/null
+;;;; 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)))
;;; 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"
projects / sbcl.git / commitdiff