ANSI fix: PARSE-NAMESTRING signals TYPE-ERROR on host mismatch.
various cleanups in optimization policy machinery..
renamed COOKIE to POLICY
used *POLICY-QUALITY-SLOTS* in POLICY-related def'ns
simplified POLICY macro: no implicit AND
factored out MAYBE-FP-WAIT policy dependence in float.lisp
the previous SPEED policy. This bug will probably get fixed in
0.6.9.x in a general cleanup of optimization policy.
+72:
+ (DECLAIM (OPTIMIZE ..)) doesn't work inside LOCALLY.
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
"!READER-COLD-INIT"
"STREAM-COLD-INIT-OR-RESET" "!LOADER-COLD-INIT"
"!PACKAGE-COLD-INIT" "SIGNAL-COLD-INIT-OR-REINIT"
- "!SET-SANE-COOKIE-DEFAULTS" "!VM-TYPE-COLD-INIT"
+ "!SET-SANE-POLICY-DEFAULTS" "!VM-TYPE-COLD-INIT"
"!BACKQ-COLD-INIT" "!SHARPM-COLD-INIT"
"!CLASS-FINALIZE" "GC-COLD-INIT-OR-REINIT"
(class-layout (class-layout class))
(subclasses (class-subclasses class)))
- ;; Attempting to register ourselves with a temporary cookie is
- ;; almost certainly a programmer error. (I should know, I did it.)
- ;; -- WHN 19990927
+ ;; Attempting to register ourselves with a temporary undefined
+ ;; class placeholder is almost certainly a programmer error. (I
+ ;; should know, I did it.) -- WHN 19990927
(assert (not (undefined-class-p class)))
;; This assertion dates from classic CMU CL. The rationale is
(show-and-call !package-cold-init)
;; Set sane values for our toplevel forms.
- (show-and-call !set-sane-cookie-defaults)
+ (show-and-call !set-sane-policy-defaults)
;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't
;; fixups be done separately? Wouldn't that be clearer and better?
;; Set sane values again, so that the user sees sane values instead of
;; whatever is left over from the last DECLAIM.
- (show-and-call !set-sane-cookie-defaults)
+ (show-and-call !set-sane-policy-defaults)
;; Only do this after top level forms have run, 'cause that's where
;; DEFTYPEs are.
:code-location loc :form form :frame frame))
(funcall res frame))))))
+;;; Evaluate FORM in the lexical context of FRAME's current code
+;;; location, returning the results of the evaluation.
(defun eval-in-frame (frame form)
(declare (type frame frame))
- #!+sb-doc
- "Evaluate Form in the lexical context of Frame's current code location,
- returning the results of the evaluation."
(funcall (preprocess-for-eval form (frame-code-location frame)) frame))
\f
;;;; breakpoints
;;;; user-visible interface
+;;; Create and return a breakpoint. When program execution encounters
+;;; the breakpoint, the system calls HOOK-FUNCTION. HOOK-FUNCTION takes the
+;;; current frame for the function in which the program is running and the
+;;; breakpoint object.
+;;;
+;;; WHAT and KIND determine where in a function the system invokes
+;;; HOOK-FUNCTION. WHAT is either a code-location or a debug-function.
+;;; KIND is one of :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END.
+;;; Since the starts and ends of functions may not have code-locations
+;;; representing them, designate these places by supplying WHAT as a
+;;; debug-function and KIND indicating the :FUNCTION-START or
+;;; :FUNCTION-END. When WHAT is a debug-function and kind is
+;;; :FUNCTION-END, then hook-function must take two additional
+;;; arguments, a list of values returned by the function and a
+;;; FUNCTION-END-COOKIE.
+;;;
+;;; INFO is information supplied by and used by the user.
+;;;
+;;; FUNCTION-END-COOKIE is a function. To implement :FUNCTION-END
+;;; breakpoints, the system uses starter breakpoints to establish the
+;;; :FUNCTION-END breakpoint for each invocation of the function. Upon
+;;; each entry, the system creates a unique cookie to identify the
+;;; invocation, and when the user supplies a function for this
+;;; argument, the system invokes it on the frame and the cookie. The
+;;; system later invokes the :FUNCTION-END breakpoint hook on the same
+;;; cookie. The user may save the cookie for comparison in the hook
+;;; function.
+;;;
+;;; Signal an error if WHAT is an unknown code-location.
(defun make-breakpoint (hook-function what
&key (kind :code-location) info function-end-cookie)
- #!+sb-doc
- "This creates and returns a breakpoint. When program execution encounters
- the breakpoint, the system calls hook-function. Hook-function takes the
- current frame for the function in which the program is running and the
- breakpoint object.
- What and kind determine where in a function the system invokes
- hook-function. What is either a code-location or a debug-function. Kind is
- one of :code-location, :function-start, or :function-end. Since the starts
- and ends of functions may not have code-locations representing them,
- designate these places by supplying what as a debug-function and kind
- indicating the :function-start or :function-end. When what is a
- debug-function and kind is :function-end, then hook-function must take two
- additional arguments, a list of values returned by the function and a
- function-end-cookie.
- Info is information supplied by and used by the user.
- Function-end-cookie is a function. To implement :function-end breakpoints,
- the system uses starter breakpoints to establish the :function-end breakpoint
- for each invocation of the function. Upon each entry, the system creates a
- unique cookie to identify the invocation, and when the user supplies a
- function for this argument, the system invokes it on the frame and the
- cookie. The system later invokes the :function-end breakpoint hook on the
- same cookie. The user may save the cookie for comparison in the hook
- function.
- This signals an error if what is an unknown code-location."
(etypecase what
(code-location
(when (code-location-unknown-p what)
;; This is the debug-function associated with the cookie.
debug-fun)
-;;; This maps bogus-lra-components to cookies, so
+;;; This maps bogus-lra-components to cookies, so that
;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the
;;; breakpoint hook.
(defvar *function-end-cookies* (make-hash-table :test 'eq))
(let ((fun (breakpoint-cookie-fun bpt)))
(when fun (funcall fun frame cookie))))))))))
+;;; This takes a FUNCTION-END-COOKIE and a frame, and it returns
+;;; whether the cookie is still valid. A cookie becomes invalid when
+;;; the frame that established the cookie has exited. Sometimes cookie
+;;; holders are unaware of cookie invalidation because their
+;;; :FUNCTION-END breakpoint hooks didn't run due to THROW'ing.
+;;;
+;;; This takes a frame as an efficiency hack since the user probably
+;;; has a frame object in hand when using this routine, and it saves
+;;; repeated parsing of the stack and consing when asking whether a
+;;; series of cookies is valid.
(defun function-end-cookie-valid-p (frame cookie)
- #!+sb-doc
- "This takes a function-end-cookie and a frame, and it returns whether the
- cookie is still valid. A cookie becomes invalid when the frame that
- established the cookie has exited. Sometimes cookie holders are unaware
- of cookie invalidation because their :function-end breakpoint hooks didn't
- run due to THROW'ing. This takes a frame as an efficiency hack since the
- user probably has a frame object in hand when using this routine, and it
- saves repeated parsing of the stack and consing when asking whether a
- series of cookies is valid."
(let ((lra (function-end-cookie-bogus-lra cookie))
(lra-sc-offset (sb!c::compiled-debug-function-return-pc
(compiled-debug-function-compiler-debug-fun
#!+gengc sb!vm::ra-save-offset
lra-sc-offset)))
(return t)))))
-
+\f
;;;; ACTIVATE-BREAKPOINT
+;;; Cause the system to invoke the breakpoint's hook-function until
+;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
+;;; system invokes breakpoint hook functions in the opposite order
+;;; that you activate them.
(defun activate-breakpoint (breakpoint)
- #!+sb-doc
- "This causes the system to invoke the breakpoint's hook-function until the
- next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The system invokes
- breakpoint hook functions in the opposite order that you activate them."
(when (eq (breakpoint-status breakpoint) :deleted)
(error "cannot activate a deleted breakpoint: ~S" breakpoint))
(unless (eq (breakpoint-status breakpoint) :active)
(compiled-debug-function
(let ((starter (breakpoint-start-helper breakpoint)))
(unless (eq (breakpoint-status starter) :active)
- ;; May already be active by some other :function-end breakpoint.
+ ;; may already be active by some other :FUNCTION-END breakpoint
(activate-compiled-function-start-breakpoint starter)))
(setf (breakpoint-status breakpoint) :active))
(interpreted-debug-function
(setf (breakpoint-data-breakpoints data)
(append (breakpoint-data-breakpoints data) (list breakpoint)))
(setf (breakpoint-internal-data breakpoint) data)))
-
+\f
;;;; DEACTIVATE-BREAKPOINT
(defun deactivate-breakpoint (breakpoint)
(delete-breakpoint-data data))))
(setf (breakpoint-status breakpoint) :inactive)
breakpoint)
-
+\f
;;;; BREAKPOINT-INFO
(defun breakpoint-info (breakpoint)
(let ((other (breakpoint-unknown-return-partner breakpoint)))
(when other
(setf (breakpoint-%info other) value))))
-
+\f
;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
(defun breakpoint-active-p (breakpoint)
(breakpoint-what breakpoint))
nil))))))
breakpoint)
-
+\f
;;;; C call out stubs
;;; This actually installs the break instruction in the component. It
(stack-ref ocfp arg-num))
results)))
(nreverse results)))
-
+\f
;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints)
(defconstant
(let ((fun-name (symbolicate name "-CACHE-CLEAR")))
(forms
`(defun ,fun-name ()
- (/show0 ,(concatenate 'string "entering " (string fun-name)))
(do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
(,n-cache ,var-name))
((minusp ,n-index))
`(setf (svref ,n-cache ,i) ,val))
(values-indices)
default-values))
- (/show0 ,(concatenate 'string "leaving " (string fun-name)))
(values)))
(forms `(,fun-name)))
;; list of null environment forms
(print-after () :type list))
-;;; This is a list of conses (function-end-cookie .
-;;; condition-satisfied), which we use to note distinct dynamic
-;;; entries into functions. When we enter a traced function, we add a
-;;; entry to this list holding the new end-cookie and whether the
-;;; trace condition was satisfied. We must save the trace condition so
-;;; that the after breakpoint knows whether to print. The length of
-;;; this list tells us the indentation to use for printing TRACE
-;;; messages.
+;;; This is a list of conses (function-end-cookie . condition-satisfied),
+;;; which we use to note distinct dynamic entries into functions. When
+;;; we enter a traced function, we add a entry to this list holding
+;;; the new end-cookie and whether the trace condition was satisfied.
+;;; We must save the trace condition so that the after breakpoint
+;;; knows whether to print. The length of this list tells us the
+;;; indentation to use for printing TRACE messages.
;;;
;;; This list also helps us synchronize the TRACE facility dynamically
;;; for detecting non-local flow of control. Whenever execution hits a
-;;; :function-end breakpoint used for TRACE'ing, we look for the
-;;; function-end-cookie at the top of *traced-entries*. If it is not
+;;; :FUNCTION-END breakpoint used for TRACE'ing, we look for the
+;;; FUNCTION-END-COOKIE at the top of *TRACED-ENTRIES*. If it is not
;;; there, we discard any entries that come before our cookie.
;;;
;;; When we trace using encapsulation, we bind this variable and add
source, the result of evaluating each top-level form is printed.
The default is *LOAD-PRINT*."
- (let ((sb!c::*default-cookie* sb!c::*default-cookie*)
- (sb!c::*default-interface-cookie* sb!c::*default-interface-cookie*)
+ (let ((sb!c::*default-policy* sb!c::*default-policy*)
+ (sb!c::*default-interface-policy* sb!c::*default-interface-policy*)
(*package* (sane-package))
(*readtable* *readtable*)
(*load-depth* (1+ *load-depth*))
;;; A pathname is logical if the host component is a logical host.
;;; This constructor is used to make an instance of the correct type
;;; from parsed arguments.
-(defun %make-pathname-object (host device directory name type version)
+(defun %make-maybe-logical-pathname (host device directory name type version)
;; We canonicalize logical pathname components to uppercase. ANSI
;; doesn't strictly require this, leaving it up to the implementor;
;; but the arguments given in the X3J13 cleanup issue
;; case, and uppercase is the ordinary way to do that.
(flet ((upcase-maybe (x) (typecase x (string (string-upcase x)) (t x))))
(if (typep host 'logical-host)
- (%make-logical-pathname
- host :unspecific
- (mapcar #'upcase-maybe directory)
- (upcase-maybe name) (upcase-maybe type) version)
+ (%make-logical-pathname host
+ :unspecific
+ (mapcar #'upcase-maybe directory)
+ (upcase-maybe name)
+ (upcase-maybe type)
+ version)
(%make-pathname host device directory name type version))))
;;; Hash table searching maps a logical pathname's host to its
;; A pattern is only matched by an identical pattern.
(and (pattern-p wild) (pattern= thing wild)))
(integer
- ;; an integer (version number) is matched by :WILD or the same
- ;; integer. This branch will actually always be NIL as long as the
- ;; version is a fixnum.
+ ;; An integer (version number) is matched by :WILD or the
+ ;; same integer. This branch will actually always be NIL as
+ ;; long as the version is a fixnum.
(eql thing wild)))))
-;;; A predicate for comparing two pathname slot component sub-entries.
+;;; a predicate for comparing two pathname slot component sub-entries
(defun compare-component (this that)
(or (eql this that)
(typecase this
(stream (file-name ,pd0)))))
,@body)))
-;;; Converts the var, a host or string name for a host, into a logical-host
-;;; structure or nil if not defined.
+;;; Convert the var, a host or string name for a host, into a
+;;; LOGICAL-HOST structure or nil if not defined.
;;;
;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
(and default-host pathname-host
(not (eq (host-customary-case default-host)
(host-customary-case pathname-host))))))
- (%make-pathname-object
+ (%make-maybe-logical-pathname
(or pathname-host default-host)
(or (%pathname-device pathname)
(maybe-diddle-case (%pathname-device defaults)
;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
;; string (as a logical-host) for the host part. We map that
;; string into the corresponding logical host structure.
-
+ ;;
;; pw@snoopy.mv.com:
;; HyperSpec says for the arg to MAKE-PATHNAME;
;; "host---a valid physical pathname host. ..."
;; that is recognized by the implementation as the name of a host."
;; "valid logical pathname host n. a string that has been defined
;; as the name of a logical host. ..."
- ;; HS is silent on what happens if the :host arg is NOT one of these.
+ ;; HS is silent on what happens if the :HOST arg is NOT one of these.
;; It seems an error message is appropriate.
(host (typecase host
(host host) ; A valid host, use it.
diddle-defaults))
(t
nil))))
- (%make-pathname-object host
- dev ; forced to :unspecific when logical-host
- dir
- (pick name namep %pathname-name)
- (pick type typep %pathname-type)
- ver))))
+ (%make-maybe-logical-pathname host
+ dev ; forced to :UNSPECIFIC when logical
+ dir
+ (pick name namep %pathname-name)
+ (pick type typep %pathname-type)
+ ver))))
(defun pathname-host (pathname &key (case :local))
#!+sb-doc
(multiple-value-bind (new-host device directory file type version)
(funcall (host-parse parse-host) namestr start end)
(when (and host new-host (not (eq new-host host)))
- (error "The host in the namestring, ~S,~@
- does not match the explicit host argument: ~S"
- host))
+ (error 'simple-type-error
+ :datum new-host
+ ;; Note: ANSI requires that this be a TYPE-ERROR,
+ ;; but there seems to be no completely correct
+ ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
+ ;; Instead, we return a sort of "type error allowed
+ ;; type", trying to say "it would be OK if you
+ ;; passed NIL as the host value" but not mentioning
+ ;; that a matching string would be OK too.
+ :expected-type 'null
+ :format-control
+ "The host in the namestring, ~S,~@
+ does not match the explicit HOST argument, ~S."
+ :format-arguments (list new-host host)))
(let ((pn-host (or new-host parse-host)))
- (values (%make-pathname-object
+ (values (%make-maybe-logical-pathname
pn-host device directory file type version)
end))))))
-;;; If namestr begins with a colon-terminated, defined, logical host,
+;;; If NAMESTR begins with a colon-terminated, defined, logical host,
;;; then return that host, otherwise return NIL.
(defun extract-logical-host-prefix (namestr start end)
(declare (type simple-base-string namestr)
(if (eq result :error)
(error "~S doesn't match ~S." source from)
result))))
- (%make-pathname-object
+ (%make-maybe-logical-pathname
(or to-host source-host)
(frob %pathname-device)
(frob %pathname-directory translate-directories)
(name (required-argument) :type simple-string)
;; T if this search-list has been defined. Otherwise NIL.
(defined nil :type (member t nil))
- ;; The list of expansions for this search-list. Each expansion is the list
- ;; of directory components to use in place of this search-list.
+ ;; the list of expansions for this search-list. Each expansion is
+ ;; the list of directory components to use in place of this
+ ;; search-list.
(expansions nil :type list))
(def!method print-object ((sl search-list) stream)
(print-unreadable-object (sl stream :type t)
;;; a hash table mapping search-list names to search-list structures
(defvar *search-lists* (make-hash-table :test 'equal))
-;;; When search-lists are encountered in namestrings, they are converted to
-;;; search-list structures right then, instead of waiting until the search
-;;; list used. This allows us to verify ahead of time that there are no
-;;; circularities and makes expansion much quicker.
+;;; When search-lists are encountered in namestrings, they are
+;;; converted to search-list structures right then, instead of waiting
+;;; until the search list used. This allows us to verify ahead of time
+;;; that there are no circularities and makes expansion much quicker.
(defun intern-search-list (name)
(let ((name (string-downcase name)))
(or (gethash name *search-lists*)
new))))
;;; Clear the definition. Note: we can't remove it from the hash-table
-;;; because there may be pathnames still refering to it. So we just clear
-;;; out the expansions and ste defined to NIL.
+;;; because there may be pathnames still refering to it. So we just
+;;; clear out the expansions and ste defined to NIL.
(defun clear-search-list (name)
#!+sb-doc
"Clear the current definition for the search-list NAME. Returns T if such
(setf (search-list-expansions search-list) nil)
t)))
-;;; Again, we can't actually remove the entries from the hash-table, so we
-;;; just mark them as being undefined.
+;;; As in CLEAR-SEARCH-LIST, we can't actually remove the entries from
+;;; the hash-table, so we just mark them as being undefined.
(defun clear-all-search-lists ()
#!+sb-doc
"Clear the definition for all search-lists. Only use this if you know
nil)
;;; Extract the search-list from PATHNAME and return it. If PATHNAME
-;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
-;;; is true) or return NIL (if FLAME-IF-NONE is false).
+;;; doesn't start with a search-list, then either error (if
+;;; FLAME-IF-NONE is true) or return NIL (if FLAME-IF-NONE is false).
(defun extract-search-list (pathname flame-if-none)
(with-pathname (pathname pathname)
(let* ((directory (%pathname-directory pathname))
(t
nil)))))
-;;; We have to convert the internal form of the search-list back into a
-;;; bunch of pathnames.
+;;; We have to convert the internal form of the search-list back into
+;;; a bunch of pathnames.
(defun search-list (pathname)
#!+sb-doc
"Return the expansions for the search-list starting PATHNAME. If PATHNAME
(with-pathname (pathname pathname)
(search-list-defined (extract-search-list pathname t))))
-;;; Set the expansion for the search-list in PATHNAME. If this would result
-;;; in any circularities, we flame out. If anything goes wrong, we leave the
-;;; old definition intact.
+;;; Set the expansion for the search list in PATHNAME. If this would
+;;; result in any circularities, we flame out. If anything goes wrong,
+;;; we leave the old definition intact.
(defun %set-search-list (pathname values)
(let ((search-list (extract-search-list pathname t)))
(labels
function)))))))
\f
;;;; logical pathname support. ANSI 92-102 specification.
-;;;; As logical-pathname translations are loaded they are canonicalized as
-;;;; patterns to enable rapid efficent translation into physical pathnames.
+;;;;
+;;;; As logical-pathname translations are loaded they are
+;;;; canonicalized as patterns to enable rapid efficent translation
+;;;; into physical pathnames.
;;;; utilities
:wild
x))))))
-;;; Return a list of conses where the cdr is the start position and the car
-;;; is a string (token) or character (punctuation.)
+;;; Return a list of conses where the CDR is the start position and
+;;; the CAR is a string (token) or character (punctuation.)
(defun logical-chunkify (namestr start end)
(collect ((chunks))
(do ((i start (1+ i))
(chunks (cons ch i)))))
(chunks)))
-;;; Break up a logical-namestring, always a string, into its constituent parts.
+;;; Break up a logical-namestring, always a string, into its
+;;; constituent parts.
(defun parse-logical-namestring (namestr start end)
(declare (type simple-base-string namestr)
(type index start end))
(and (not (equal (directory)'(:absolute)))(directory))
name type version))))
-;;; can't defvar here because not all host methods are loaded yet
-(declaim (special *logical-pathname-defaults*))
+;;; We can't initialize this yet because not all host methods are loaded yet.
+(defvar *logical-pathname-defaults*)
(defun logical-pathname (pathspec)
#!+sb-doc
(let ((directory (%pathname-directory pathname)))
(when directory
(ecase (pop directory)
- (:absolute) ;; Nothing special.
+ (:absolute) ; nothing special
(:relative (pieces ";")))
(dolist (dir directory)
(cond ((or (stringp dir) (pattern-p dir))
;; left is what we want, more or less.
(cond ((and (eq (first path-dir) (first def-dir))
(eq (first path-dir) :absolute))
- ;; Both paths are :absolute, so find where the common
- ;; parts end and return what's left
+ ;; Both paths are :ABSOLUTE, so find where the
+ ;; common parts end and return what's left
(do* ((p (rest path-dir) (rest p))
(d (rest def-dir) (rest d)))
((or (endp p) (endp d)
(not (equal (first p) (first d))))
`(:relative ,@p))))
(t
- ;; At least one path is :relative, so just return the
- ;; original path. If the original path is :relative,
+ ;; At least one path is :RELATIVE, so just return the
+ ;; original path. If the original path is :RELATIVE,
;; then that's the right one. If PATH-DIR is
- ;; :absolute, we want to return that except when
- ;; DEF-DIR is :absolute, as handled above. so return
+ ;; :ABSOLUTE, we want to return that except when
+ ;; DEF-DIR is :ABSOLUTE, as handled above. so return
;; the original directory.
path-dir))))
(make-pathname :host (pathname-host pathname)
(defun maybe-weaken-check (type cont)
(declare (type ctype type) (type continuation cont))
(cond ((policy (continuation-dest cont)
- (<= speed safety) (<= space safety) (<= cspeed safety))
+ (and (<= speed safety)
+ (<= space safety)
+ (<= cspeed safety)))
type)
(t
(let ((min-cost (type-test-cost type))
(declare (type clambda fun) (type hash-table var-locs))
(let* ((dfun (dfun-from-fun fun))
(actual-level
- (cookie-debug (lexenv-cookie (node-lexenv (lambda-bind fun)))))
+ (policy-debug (lexenv-policy (node-lexenv (lambda-bind fun)))))
(level (if #!+sb-dyncount *collect-dynamic-statistics*
#!-sb-dyncount nil
(max actual-level 2)
(def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1)))
;;; a value for an optimization declaration
-(def!type sb!c::cookie-quality () '(or (rational 0 3) null))
+(def!type sb!c::policy-quality () '(or (rational 0 3) null))
\f
-;;; A COOKIE holds information about the compilation environment for a
-;;; node. See the LEXENV definition for a description of how it is
-;;; used.
-(def!struct (cookie (:copier nil))
- (speed nil :type cookie-quality)
- (space nil :type cookie-quality)
- (safety nil :type cookie-quality)
- (cspeed nil :type cookie-quality)
- (brevity nil :type cookie-quality)
- (debug nil :type cookie-quality))
-
-;;; KLUDGE: This needs to be executable in cold init toplevel forms,
+;;;; policy stuff
+
+;;; a map from optimization policy quality to corresponding POLICY
+;;; slot name, used to automatically keep POLICY-related definitions
+;;; in sync even if future maintenance changes POLICY slots
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defstruct (policy-quality-slot (:constructor %make-pqs (quality accessor)))
+ ;; the name of the quality
+ (quality (required-argument) :type symbol)
+ ;; the name of the structure slot accessor
+ (accessor (required-argument) :type symbol))
+ (defparameter *policy-quality-slots*
+ (list (%make-pqs 'speed 'policy-speed)
+ (%make-pqs 'space 'policy-space)
+ (%make-pqs 'safety 'policy-safety)
+ (%make-pqs 'cspeed 'policy-cspeed)
+ (%make-pqs 'brevity 'policy-brevity)
+ (%make-pqs 'debug 'policy-debug)))
+ (defun named-policy-quality-slot (name)
+ (find name *policy-quality-slots* :key #'policy-quality-slot-quality)))
+
+;;; A POLICY object holds information about the compilation policy for
+;;; a node. See the LEXENV definition for a description of how it is used.
+#.`(def!struct (policy
+ (:copier nil)) ; (but see DEFUN COPY-POLICY)
+ ,@(mapcar (lambda (pqs)
+ `(,(policy-quality-slot-quality pqs) nil
+ :type policy-quality))
+ *policy-quality-slots*))
+
+;;; an annoyingly hairy way of doing COPY-STRUCTURE on POLICY objects
+;;;
+;;; (We need this explicit, separate, hairy DEFUN only because we need
+;;; to be able to copy POLICY objects in cold init toplevel forms,
;;; earlier than the default copier closure created by DEFSTRUCT
;;; toplevel forms would be available, and earlier than LAYOUT-INFO is
-;;; initialized (which is a prerequisite for COPY-STRUCTURE to work),
-;;; so we define it explicitly using DEFUN, so that it can be
-;;; installed by the cold loader, and using hand-written,
-;;; hand-maintained slot-by-slot copy it doesn't need to call
-;;; COPY-STRUCTURE. -- WHN 19991019
-(defun copy-cookie (cookie)
- (make-cookie :speed (cookie-speed cookie)
- :space (cookie-space cookie)
- :safety (cookie-safety cookie)
- :cspeed (cookie-cspeed cookie)
- :brevity (cookie-brevity cookie)
- :debug (cookie-debug cookie)))
-
-;;; *DEFAULT-COOKIE* holds the current global compiler policy
+;;; initialized (which is a prerequisite for COPY-STRUCTURE to work).)
+#.`(defun copy-policy (policy)
+ (make-policy
+ ,@(mapcan (lambda (pqs)
+ `(,(keywordicate (policy-quality-slot-quality pqs))
+ (,(policy-quality-slot-accessor pqs) policy)))
+ *policy-quality-slots*)))
+
+;;; *DEFAULT-POLICY* holds the current global compiler policy
;;; information. Whenever the policy is changed, we copy the structure
;;; so that old uses will still get the old values.
-;;; *DEFAULT-INTERFACE-COOKIE* holds any values specified by an
+;;; *DEFAULT-INTERFACE-POLICY* holds any values specified by an
;;; OPTIMIZE-INTERFACE declaration.
-;;;
-;;; FIXME: Why isn't COOKIE called POLICY?
-(declaim (type cookie *default-cookie* *default-interface-cookie*))
-(defvar *default-cookie*) ; initialized in cold init
-(defvar *default-interface-cookie*) ; initialized in cold init
-
+(declaim (type policy *default-policy* *default-interface-policy*))
+(defvar *default-policy*) ; initialized in cold init
+(defvar *default-interface-policy*) ; initialized in cold init
+\f
;;; possible values for the INLINE-ness of a function.
(deftype inlinep ()
'(member :inline :maybe-inline :notinline nil))
(defvar *count-vop-usages*)
(defvar *current-path*)
(defvar *current-component*)
-(defvar *default-cookie*)
-(defvar *default-interface-cookie*)
+(defvar *default-policy*)
+(defvar *default-interface-policy*)
(defvar *dynamic-counts-tn*)
(defvar *elsewhere*)
(defvar *event-info*)
cont-atype
(continuation-asserted-type arg))
*empty-type*))
- (eq (lexenv-cookie (node-lexenv dest))
- (lexenv-cookie (node-lexenv (continuation-dest arg)))))
+ (eq (lexenv-policy (node-lexenv dest))
+ (lexenv-policy (node-lexenv (continuation-dest arg)))))
(assert (member (continuation-kind arg)
'(:block-start :deleted-block-start :inside-block)))
(assert-continuation-type arg cont-atype)
(return-from ir1-optimize-mv-call)))
(let ((count (cond (total-nvals)
- ((and (policy node (zerop safety)) (eql min max))
+ ((and (policy node (zerop safety))
+ (eql min max))
min)
(t nil))))
(when count
(optimize
(make-lexenv
:default res
- :cookie (process-optimize-declaration spec (lexenv-cookie res))))
+ :policy (process-optimize-declaration spec (lexenv-policy res))))
(optimize-interface
(make-lexenv
:default res
- :interface-cookie (process-optimize-declaration
+ :interface-policy (process-optimize-declaration
spec
- (lexenv-interface-cookie res))))
+ (lexenv-interface-policy res))))
(type
(process-type-declaration (cdr spec) res vars))
(sb!pcl::class
(reference-leaf start fun-cont fun)
(let ((*lexenv* (if interface
(make-lexenv
- :cookie (make-interface-cookie *lexenv*))
+ :policy (make-interface-policy *lexenv*))
*lexenv*)))
(ir1-convert-combination-args fun-cont cont
(list (first aux-vals))))))
:where-from (leaf-where-from var)
:specvar (lambda-var-specvar var)))
fvars))
- (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*)))
+ (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))
(fun
(ir1-convert-lambda-body
`((%funcall ,fun ,@(reverse vals) ,@defaults))
(n-count (gensym "N-COUNT-"))
(count-temp (make-lambda-var :name n-count
:type (specifier-type 'index)))
- (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*))))
+ (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))))
(arg-vars context-temp count-temp)
`(,(car x) .
(macro . ,(coerce (cdr x) 'function))))
macros)
- :cookie (lexenv-cookie *lexenv*)
- :interface-cookie (lexenv-interface-cookie *lexenv*))))
+ :policy (lexenv-policy *lexenv*)
+ :interface-policy (lexenv-interface-policy *lexenv*))))
(ir1-convert-lambda `(lambda ,@body) name))))
;;; Return a lambda that has been "closed" with respect to ENV,
options
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
- (cookie (lexenv-cookie default))
- (interface-cookie (lexenv-interface-cookie default)))
+ (policy (lexenv-policy default))
+ (interface-policy (lexenv-interface-policy default)))
(macrolet ((frob (var slot)
`(let ((old (,slot default)))
(if ,var
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
- lambda cleanup cookie interface-cookie
+ lambda cleanup policy interface-policy
(frob options lexenv-options))))
-;;; Return a cookie that defaults any unsupplied optimize qualities in
-;;; the Interface-Cookie with the corresponding ones from the Cookie.
-(defun make-interface-cookie (lexenv)
+;;; Return a POLICY that defaults any unsupplied optimize qualities in
+;;; the INTERFACE-POLICY with the corresponding ones from the POLICY.
+(defun make-interface-policy (lexenv)
(declare (type lexenv lexenv))
- (let ((icookie (lexenv-interface-cookie lexenv))
- (cookie (lexenv-cookie lexenv)))
- (make-cookie
- :speed (or (cookie-speed icookie) (cookie-speed cookie))
- :space (or (cookie-space icookie) (cookie-space cookie))
- :safety (or (cookie-safety icookie) (cookie-safety cookie))
- :cspeed (or (cookie-cspeed icookie) (cookie-cspeed cookie))
- :brevity (or (cookie-brevity icookie) (cookie-brevity cookie))
- :debug (or (cookie-debug icookie) (cookie-debug cookie)))))
+ (let ((ipolicy (lexenv-interface-policy lexenv))
+ (policy (lexenv-policy lexenv)))
+ (make-policy
+ :speed (or (policy-speed ipolicy) (policy-speed policy))
+ :space (or (policy-space ipolicy) (policy-space policy))
+ :safety (or (policy-safety ipolicy) (policy-safety policy))
+ :cspeed (or (policy-cspeed ipolicy) (policy-cspeed policy))
+ :brevity (or (policy-brevity ipolicy) (policy-brevity policy))
+ :debug (or (policy-debug ipolicy) (policy-debug policy)))))
\f
;;;; flow/DFO/component hackery
-;;; Join Block1 and Block2.
+;;; Join BLOCK1 and BLOCK2.
#!-sb-fluid (declaim (inline link-blocks))
(defun link-blocks (block1 block2)
(declare (type cblock block1 block2))
(:constructor make-null-lexenv ())
(:constructor internal-make-lexenv
(functions variables blocks tags type-restrictions
- lambda cleanup cookie
- interface-cookie options)))
- ;; Alist (name . what), where What is either a Functional (a local function),
+ lambda cleanup policy
+ interface-policy options)))
+ ;; Alist (NAME . WHAT), where WHAT is either a Functional (a local function),
;; a DEFINED-FUNCTION, representing an INLINE/NOTINLINE declaration, or
;; a list (MACRO . <function>) (a local macro, with the specifier
- ;; expander.) Note that Name may be a (SETF <name>) function.
+ ;; expander.) Note that NAME may be a (SETF <name>) function.
(functions nil :type list)
;; an alist translating variable names to LEAF structures. A special
;; binding is indicated by a :SPECIAL GLOBAL-VAR leaf. Each special
;; FIXME: This should be :TYPE (OR CLEANUP NULL), but it was too hard
;; to get CLEANUP defined in time for the cross-compiler.
(cleanup nil)
- ;; The representation of the current OPTIMIZE policy.
- (cookie *default-cookie* :type cookie)
+ ;; the current OPTIMIZE policy
+ (policy *default-policy* :type policy)
;; the policy that takes effect in XEPs and related syntax parsing
- ;; functions. Slots in this cookie may be null to indicate that the
+ ;; functions. Slots in this policy may be null to indicate that the
;; normal value in effect.
- (interface-cookie *default-interface-cookie* :type cookie)
+ (interface-policy *default-interface-policy* :type policy)
;; an alist of miscellaneous options that are associated with the
;; lexical environment
(options nil :type list))
(declare (type functional fun))
(assert (not (functional-entry-function fun)))
(with-ir1-environment (lambda-bind (main-entry fun))
- (let* ((*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*)))
+ (let* ((*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))
(res (ir1-convert-lambda (make-xep-lambda fun))))
(setf (functional-kind res) :external)
(setf (leaf-ever-used res) t)
;;; reference a fresh copy. We return whichever function we decide to
;;; reference.
(defun maybe-expand-local-inline (fun ref call)
- (if (and (policy call (>= speed space) (>= speed cspeed))
+ (if (and (policy call
+ (and (>= speed space) (>= speed cspeed)))
(not (eq (functional-kind (node-home-lambda call)) :external))
(not *converting-for-interpreter*)
(inline-expansion-ok call))
;;; Return the policies keyword indicated by the node policy.
(defun translation-policy (node)
(declare (type node node))
- (let* ((cookie (lexenv-cookie (node-lexenv node)))
- (safety (cookie-safety cookie))
- (space (max (cookie-space cookie)
- (cookie-cspeed cookie)))
- (speed (cookie-speed cookie)))
+ (let* ((policy (lexenv-policy (node-lexenv node)))
+ (safety (policy-safety policy))
+ (space (max (policy-space policy)
+ (policy-cspeed policy)))
+ (speed (policy-speed policy)))
(if (zerop safety)
(if (>= speed space) :fast :small)
(if (>= speed space) :fast-safe :safe))))
(declaim (special *wild-type* *universal-type* *compiler-error-context*))
-;;; An INLINEP value describes how a function is called. The values have these
-;;; meanings:
-;;; NIL No declaration seen: do whatever you feel like, but don't dump
-;;; an inline expansion.
+;;; An INLINEP value describes how a function is called. The values
+;;; have these meanings:
+;;; NIL No declaration seen: do whatever you feel like, but don't
+;;; dump an inline expansion.
;;; :NOTINLINE NOTINLINE declaration seen: always do full function call.
-;;; :INLINE INLINE declaration seen: save expansion, expanding to it if
-;;; policy favors.
+;;; :INLINE INLINE declaration seen: save expansion, expanding to it
+;;; if policy favors.
;;; :MAYBE-INLINE
;;; Retain expansion, but only use it opportunistically.
(deftype inlinep () '(member :inline :maybe-inline :notinline nil))
\f
;;;; the POLICY macro
-(defparameter *policy-parameter-slots*
- '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety)
- (cspeed . cookie-cspeed) (brevity . cookie-brevity)
- (debug . cookie-debug)))
-
-;;; Find all the policy parameters which are actually mentioned in Stuff,
-;;; returning the names in a list. We assume everything is evaluated.
+;;; a helper function for the POLICY macro: Return a list of
+;;; POLICY-QUALITY-SLOT objects corresponding to the qualities which
+;;; appear in EXPR.
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun find-used-parameters (stuff)
- (if (atom stuff)
- (if (assoc stuff *policy-parameter-slots*) (list stuff) ())
- (collect ((res () nunion))
- (dolist (arg (cdr stuff) (res))
- (res (find-used-parameters arg))))))
-) ; EVAL-WHEN
-
-;;; This macro provides some syntactic sugar for querying the settings
-;;; of the compiler policy parameters.
+ (defun policy-quality-slots-used-by (expr)
+ (let ((result nil))
+ (labels ((recurse (x)
+ (if (listp x)
+ (map nil #'recurse x)
+ (let ((pqs (named-policy-quality-slot x)))
+ (when pqs
+ (pushnew pqs result))))))
+ (recurse expr)
+ result))))
+
+;;; syntactic sugar for querying optimization policy qualities
;;;
-;;; Test whether some conditions apply to the current compiler policy
-;;; for Node. Each condition is a predicate form which accesses the
-;;; policy values by referring to them as the variables SPEED, SPACE,
-;;; SAFETY, CSPEED, BREVITY and DEBUG. The results of all the
-;;; conditions are combined with AND and returned as the result.
+;;; 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 *DEFAULT-POLICY* and *CURRENT-POLICY*. (Using NODE=NIL is only
+;;; well-defined during IR1 conversion.)
;;;
-;;; NODE is a form which is evaluated to obtain the node which the
-;;; policy is for. If NODE is NIL, then we use the current policy as
-;;; defined by *DEFAULT-COOKIE* and *CURRENT-COOKIE*. This option is
-;;; only well defined during IR1 conversion.
-(defmacro policy (node &rest conditions)
- (let* ((form `(and ,@conditions))
- (n-cookie (gensym))
+;;; EXPR is a form which accesses the policy values by referring to
+;;; them by name, e.g. SPEED.
+(defmacro policy (node expr)
+ (let* ((n-policy (gensym))
(binds (mapcar
- #'(lambda (name)
- (let ((slot (cdr (assoc name *policy-parameter-slots*))))
- `(,name (,slot ,n-cookie))))
- (find-used-parameters form))))
- `(let* ((,n-cookie (lexenv-cookie
+ (lambda (pqs)
+ `(,(policy-quality-slot-quality pqs)
+ (,(policy-quality-slot-accessor pqs) ,n-policy)))
+ (policy-quality-slots-used-by expr))))
+ (/show "in POLICY" expr binds)
+ `(let* ((,n-policy (lexenv-policy
,(if node
`(node-lexenv ,node)
'*lexenv*)))
,@binds)
- ,form)))
+ ,expr)))
\f
;;;; source-hacking defining forms
;;; the values of *PACKAGE* and policy when compilation started
(defvar *initial-package*)
-(defvar *initial-cookie*)
-(defvar *initial-interface-cookie*)
+(defvar *initial-policy*)
+(defvar *initial-interface-policy*)
;;; The source-info structure for the current compilation. This is null
;;; globally to indicate that we aren't currently in any identifiable
(defun byte-compiling ()
(if (eq *byte-compiling* :maybe)
(or (eq *byte-compile* t)
- (policy nil (zerop speed) (<= debug 1)))
+ (policy nil (and (zerop speed) (<= debug 1))))
(and *byte-compile* *byte-compiling*)))
;;; Delete components with no external entry points before we try to
(:maybe
(dolist (fun (component-lambdas component) t)
(unless (policy (lambda-bind fun)
- (zerop speed) (<= debug 1))
+ (and (zerop speed) (<= debug 1)))
(return nil)))))))
(when sb!xc:*compile-print*
(cond ((source-info-stream info))
(t
(setq *package* *initial-package*)
- (setq *default-cookie* (copy-cookie *initial-cookie*))
- (setq *default-interface-cookie*
- (copy-cookie *initial-interface-cookie*))
+ (setq *default-policy* (copy-policy *initial-policy*))
+ (setq *default-interface-policy*
+ (copy-policy *initial-interface-policy*))
(let* ((finfo (first (source-info-current-file info)))
(name (file-info-name finfo)))
(setq sb!xc:*compile-file-truename* name)
;;; *TOP-LEVEL-LAMBDAS* instead.
(defun convert-and-maybe-compile (form path)
(declare (list path))
- (let* ((*lexenv* (make-lexenv :cookie *default-cookie*
- :interface-cookie *default-interface-cookie*))
+ (let* ((*lexenv* (make-lexenv :policy *default-policy*
+ :interface-policy *default-interface-policy*))
(tll (ir1-top-level form path nil)))
(cond ((eq *block-compile* t) (push tll *top-level-lambdas*))
(t (compile-top-level (list tll) nil)))))
;;; Process a top-level use of LOCALLY. We parse declarations and then
;;; recursively process the body.
;;;
-;;; Binding *DEFAULT-xxx-COOKIE* is pretty much of a hack, since it
+;;; Binding *DEFAULT-xxx-POLICY* is pretty much of a hack, since it
;;; causes LOCALLY to "capture" enclosed proclamations. It is
;;; necessary because CONVERT-AND-MAYBE-COMPILE uses the value of
-;;; *DEFAULT-COOKIE* as the policy. The need for this hack is due to
-;;; the quirk that there is no way to represent in a cookie that an
+;;; *DEFAULT-POLICY* as the policy. The need for this hack is due to
+;;; the quirk that there is no way to represent in a POLICY that an
;;; optimize quality came from the default.
;;; FIXME: Ideally, something should be done so that DECLAIM inside LOCALLY
;;; works OK. Failing that, at least we could issue a warning instead
(multiple-value-bind (forms decls) (sb!sys:parse-body (cdr form) nil)
(let* ((*lexenv*
(process-decls decls nil nil (make-continuation)))
- (*default-cookie* (lexenv-cookie *lexenv*))
- (*default-interface-cookie* (lexenv-interface-cookie *lexenv*)))
+ (*default-policy* (lexenv-policy *lexenv*))
+ (*default-interface-policy* (lexenv-interface-policy *lexenv*)))
(process-top-level-progn forms path))))
;;; Force any pending top-level forms to be compiled and dumped so
(*block-compile* *block-compile-argument*)
(*package* (sane-package))
(*initial-package* (sane-package))
- (*initial-cookie* *default-cookie*)
- (*initial-interface-cookie* *default-interface-cookie*)
- (*default-cookie* (copy-cookie *initial-cookie*))
- (*default-interface-cookie*
- (copy-cookie *initial-interface-cookie*))
+ (*initial-policy* *default-policy*)
+ (*initial-interface-policy* *default-interface-policy*)
+ (*default-policy* (copy-policy *initial-policy*))
+ (*default-interface-policy* (copy-policy *initial-interface-policy*))
(*lexenv* (make-null-lexenv))
(*converting-for-interpreter* nil)
(*source-info* info)
(in-package "SB!C")
-;;; !COLD-INIT calls this twice to initialize the cookies, once before
+;;; !COLD-INIT calls this twice to initialize policy, once before
;;; any toplevel forms are executed, then again to undo any lingering
;;; effects of toplevel DECLAIMs.
(!begin-collecting-cold-init-forms)
(!cold-init-forms
- (setf *default-cookie*
- (make-cookie :safety 1
+ (setf *default-policy*
+ (make-policy :safety 1
:speed 1
:space 1
:cspeed 1
;; value", and it seems natural for the neutral value to
;; be the default.
:debug 1))
- (setf *default-interface-cookie*
- (make-cookie)))
-(!defun-from-collected-cold-init-forms !set-sane-cookie-defaults)
+ (setf *default-interface-policy*
+ (make-policy)))
+(!defun-from-collected-cold-init-forms !set-sane-policy-defaults)
;;; A list of UNDEFINED-WARNING structures representing references to unknown
;;; stuff which came up in a compilation unit.
(let ((old (gethash name *free-variables*)))
(when old (vars old))))))
-;;; Return a new cookie containing the policy information represented
+;;; Return a new POLICY containing the policy information represented
;;; by the optimize declaration SPEC. Any parameters not specified are
-;;; defaulted from COOKIE.
-(declaim (ftype (function (list cookie) cookie) process-optimize-declaration))
-(defun process-optimize-declaration (spec cookie)
- (let ((res (copy-cookie cookie)))
+;;; defaulted from the POLICY argument.
+(declaim (ftype (function (list policy) policy) process-optimize-declaration))
+(defun process-optimize-declaration (spec policy)
+ (let ((res (copy-policy policy)))
(dolist (quality (cdr spec))
(let ((quality (if (atom quality) (list quality 3) quality)))
(if (and (consp (cdr quality)) (null (cddr quality))
(typep (second quality) 'real) (<= 0 (second quality) 3))
(let ((value (rational (second quality))))
(case (first quality)
- (speed (setf (cookie-speed res) value))
- (space (setf (cookie-space res) value))
- (safety (setf (cookie-safety res) value))
- (compilation-speed (setf (cookie-cspeed res) value))
+ (speed (setf (policy-speed res) value))
+ (space (setf (policy-space res) value))
+ (safety (setf (policy-safety res) value))
+ (compilation-speed (setf (policy-cspeed res) value))
;; FIXME: BREVITY is an undocumented name for it,
;; should go away. And INHIBIT-WARNINGS is a
;; misleading name for it. Perhaps BREVITY would be
;; of suppressing only optimization-related notes,
;; which I think is the behavior. Perhaps
;; INHIBIT-NOTES?
- ((inhibit-warnings brevity) (setf (cookie-brevity res) value))
- ((debug-info debug) (setf (cookie-debug res) value))
+ ((inhibit-warnings brevity) (setf (policy-brevity res) value))
+ ((debug-info debug) (setf (policy-debug res) value))
(t
(compiler-warning "unknown optimization quality ~S in ~S"
(car quality) spec))))
(declare (ignore layout))
(setf (class-state subclass) :sealed))))))))
(optimize
- (setq *default-cookie*
- (process-optimize-declaration form *default-cookie*)))
+ (setq *default-policy*
+ (process-optimize-declaration form *default-policy*)))
(optimize-interface
- (setq *default-interface-cookie*
- (process-optimize-declaration form *default-interface-cookie*)))
+ (setq *default-interface-policy*
+ (process-optimize-declaration form *default-interface-policy*)))
((inline notinline maybe-inline)
(dolist (name args)
(proclaim-as-function-name name)
(op-tn (tn-ref-tn op))
(*compiler-error-context* op-node))
(cond ((eq (tn-kind op-tn) :constant))
- ((policy op-node (<= speed brevity) (<= space brevity)))
+ ((policy op-node (and (<= speed brevity) (<= space brevity))))
((member (template-name (vop-info op-vop)) *suppress-note-vops*))
((null dest-tn)
(let* ((op-info (vop-info op-vop))
(give-up-ir1-transform))
(let ((n (continuation-value n)))
(when (> n
- (if (policy node (= speed 3) (= space 0))
+ (if (policy node (and (= speed 3) (= space 0)))
*extreme-nthcdr-open-code-limit*
*default-nthcdr-open-code-limit*))
(give-up-ir1-transform))
((= nargs 1) `(progn ,@args t))
((= nargs 2)
`(if (,predicate ,(first args) ,(second args)) nil t))
- ((not (policy nil (>= speed space) (>= speed cspeed)))
+ ((not (policy nil (and (>= speed space) (>= speed cspeed))))
(values nil t))
(t
(let ((vars (make-gensym-list nargs)))
(defun ea-for-lf-stack (tn)
(ea-for-xf-stack tn :long)))
-;;; Complex float stack EAs
+;;; Telling the FPU to wait is required in order to make signals occur
+;;; at the expected place, but naturally slows things down.
+;;;
+;;; NODE is the node whose compilation policy controls the decision
+;;; whether to just blast through carelessly or carefully emit wait
+;;; instructions and whatnot.
+;;;
+;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
+;;; #'NOTE-NEXT-INSTRUCTION.
+(defun maybe-fp-wait (node &optional note-next-instruction)
+ (when (policy node (or (= debug 3) (> safety speed))))
+ (when note-next-instruction
+ (note-next-instruction note-next-instruction :internal-error))
+ (inst wait))
+
+;;; complex float stack EAs
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
`(make-ea
:dword :base ,base
;; This may not be necessary as ST0 is likely invalid now.
(inst fxch x))))
-;;; The i387 has instructions to load some useful constants.
-;;; This doesn't save much time but might cut down on memory
-;;; access and reduce the size of the constant vector (CV).
-;;; Intel claims they are stored in a more precise form on chip.
-;;; Anyhow, might as well use the feature. It can be turned
-;;; off by hacking the "immediate-constant-sc" in vm.lisp.
+;;; The i387 has instructions to load some useful constants. This
+;;; doesn't save much time but might cut down on memory access and
+;;; reduce the size of the constant vector (CV). Intel claims they are
+;;; stored in a more precise form on chip. Anyhow, might as well use
+;;; the feature. It can be turned off by hacking the
+;;; "immediate-constant-sc" in vm.lisp.
(define-move-function (load-fp-constant 2) (vop x y)
((fp-constant) (single-reg double-reg #!+long-float long-reg))
(let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
(inst fldlg2))
((= value (log 2l0 2.718281828459045235360287471352662L0))
(inst fldln2))
- (t (warn "Ignoring bogus i387 Constant ~A" value))))))
+ (t (warn "ignoring bogus i387 constant ~A" value))))))
\f
;;;; complex float move functions
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
:offset (1+ (tn-offset x))))
-;;; x is source, y is destination
+;;; x is source, y is destination.
(define-move-function (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((real-tn (complex-single-reg-real-tn y)))
\f
;;;; move VOPs
-;;; Float register to register moves.
+;;; float register to register moves
(define-vop (float-move)
(:args (x))
(:results (y))
(define-move-vop move-from-fp-constant :move
(fp-constant) (descriptor-reg))
-;;; Move from a descriptor to a float register
+;;; Move from a descriptor to a float register.
(define-vop (move-to-single)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (single-reg)))
(inst fldl (ea-for-lf-desc x)))))
#!+long-float
(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
-
\f
;;; Move from complex float to a descriptor reg. allocating a new
;;; complex float object in the process.
(define-move-vop move-from-complex-long :move
(complex-long-reg) (descriptor-reg))
-;;; Move from a descriptor to a complex float register
+;;; Move from a descriptor to a complex float register.
(macrolet ((frob (name sc format)
`(progn
(define-vop (,name)
(frob move-to-complex-double complex-double-reg :double)
#!+long-float
(frob move-to-complex-double complex-long-reg :long))
-
\f
-;;;; The move argument vops.
+;;;; the move argument vops
;;;;
-;;;; Note these are also used to stuff fp numbers onto the c-call stack
-;;;; so the order is different than the lisp-stack.
+;;;; Note these are also used to stuff fp numbers onto the c-call
+;;;; stack so the order is different than the lisp-stack.
-;;; The general move-argument vop
+;;; the general move-argument vop
(macrolet ((frob (name sc stack-sc format)
`(progn
(define-vop (,name)
#!+long-float
(frob move-long-float-argument long-reg long-stack :long))
-;;;; Complex float move-argument vop
+;;;; complex float move-argument vop
(macrolet ((frob (name sc stack-sc format)
`(progn
(define-vop (,name)
\f
;;;; arithmetic VOPs
-;;; dtc: The floating point arithmetic vops.
+;;; dtc: the floating point arithmetic vops
;;;
;;; Note: Although these can accept x and y on the stack or pointed to
;;; from a descriptor register, they will work with register loading
(inst fld (ea-for-sf-desc y)))))
;; ST(i) = ST(i) op ST0
(inst ,fop-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
+ (maybe-fp-wait node vop))
;; y and r are the same register.
((and (sc-is y single-reg) (location= y r))
(cond ((zerop (tn-offset r))
(inst fld (ea-for-sf-desc x)))))
;; ST(i) = ST(0) op ST(i)
(inst ,fopr-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
- ;; The default case
+ (maybe-fp-wait node vop))
+ ;; the default case
(t
;; Get the result to ST0.
(note-next-instruction vop :internal-error)
- ;; Finally save the result
+ ;; Finally save the result.
(sc-case r
(single-reg
(cond ((zerop (tn-offset r))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst r))))
(single-stack
(:save-p :compute-only)
(:node-var node)
(:generator ,dcost
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; x, y, and r are the same register.
((and (sc-is x double-reg) (location= x r) (location= y r))
(inst fldd (ea-for-df-desc y)))))
;; ST(i) = ST(i) op ST0
(inst ,fop-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
+ (maybe-fp-wait node vop))
;; y and r are the same register.
((and (sc-is y double-reg) (location= y r))
(cond ((zerop (tn-offset r))
(inst fldd (ea-for-df-desc x)))))
;; ST(i) = ST(0) op ST(i)
(inst ,fopr-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
- ;; The default case
+ (maybe-fp-wait node vop))
+ ;; the default case
(t
;; Get the result to ST0.
(note-next-instruction vop :internal-error)
- ;; Finally save the result
+ ;; Finally save the result.
(sc-case r
(double-reg
(cond ((zerop (tn-offset r))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst r))))
(double-stack
(:save-p :compute-only)
(:node-var node)
(:generator ,lcost
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; x, y, and r are the same register.
((and (location= x r) (location= y r))
(copy-fp-reg-to-fr0 y))
;; ST(i) = ST(i) op ST0
(inst ,fop-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
+ (maybe-fp-wait node vop))
;; y and r are the same register.
((location= y r)
(cond ((zerop (tn-offset r))
(copy-fp-reg-to-fr0 x))
;; ST(i) = ST(0) op ST(i)
(inst ,fopr-sti r)))
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst wait)))
+ (maybe-fp-wait node vop))
;; the default case
(t
;; Get the result to ST0.
;; Finally save the result.
(cond ((zerop (tn-offset r))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst r))))))))))
(unless (zerop (tn-offset x))
(inst fxch x) ; x to top of stack
(unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,inst) ; clobber st0
+ (inst fst x))) ; Maybe save it.
+ (inst ,inst) ; Clobber st0.
(unless (zerop (tn-offset y))
(inst fst y))))))
(y :scs (long-reg)))
(:arg-types long-float long-float))
-
(define-vop (<single-float)
(:translate <)
(:args (x :scs (single-reg single-stack descriptor-reg))
(:note "inline float comparison")
(:ignore temp)
(:generator 3
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; y is ST0.
((and (sc-is y single-reg) (zerop (tn-offset y)))
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45))
- ;; General case when y is not in ST0.
+ ;; general case when y is not in ST0
(t
;; x to ST0
(sc-case x
(:note "inline float comparison")
(:ignore temp)
(:generator 3
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; y is ST0.
((and (sc-is y single-reg) (zerop (tn-offset y)))
(inst and ah-tn #x45)
(inst cmp ah-tn #x01))
- ;; General case when y is not in ST0.
+ ;; general case when y is not in ST0
(t
;; x to ST0
(sc-case x
(:note "inline float comparison")
(:ignore temp)
(:generator 3
- ;; Handle a few special cases
+ ;; Handle a few special cases.
(cond
;; y is ST0.
((and (sc-is y double-reg) (zerop (tn-offset y)))
(inst and ah-tn #x45)
(inst cmp ah-tn #x01))
- ;; General case when y is not in ST0.
+ ;; general case when y is not in ST0
(t
;; x to ST0
(sc-case x
#!+long-float
(frob %long-float/unsigned %long-float long-reg long-float))
-;;; These should be no-ops but the compiler might want to move
-;;; some things around
+;;; These should be no-ops but the compiler might want to move some
+;;; things around.
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
`(define-vop (,name)
(:args (x :scs (,from-sc) :target y))
;; Catch any pending FPE exceptions.
(inst wait)))
(,(if round-p 'progn 'pseudo-atomic)
- ;; normal mode (for now) is "round to best"
+ ;; Normal mode (for now) is "round to best".
(with-tn@fp-top (x)
,@(unless round-p
- '((inst fnstcw scw) ; save current control word
+ '((inst fnstcw scw) ; save current control word
(move rcw scw) ; into 16-bit register
(inst or rcw (ash #b11 10)) ; CHOP
(move stack-temp rcw)
'((note-this-location vop :internal-error)
;; Catch any pending FPE exceptions.
(inst wait)))
- ;; normal mode (for now) is "round to best"
+ ;; Normal mode (for now) is "round to best".
(unless (zerop (tn-offset x))
(copy-fp-reg-to-fr0 x))
,@(unless round-p
(:temporary (:sc unsigned-reg :offset eax-offset :target res
:to :result) eax)
(:generator 8
- (inst sub esp-tn npx-env-size) ; make space on stack
- (inst wait) ; Catch any pending FPE exceptions
+ (inst sub esp-tn npx-env-size) ; Make space on stack.
+ (inst wait) ; Catch any pending FPE exceptions
(inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
- (inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state
- ;; Current status to high word
+ (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
+ ;; Move current status to high word.
(inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
- ;; Exception mask to low word
+ ;; Move exception mask to low word.
(inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
- (inst add esp-tn npx-env-size) ; Pop stack
- (inst xor eax #x3f) ; Flip exception mask to trap enable bits
+ (inst add esp-tn npx-env-size) ; Pop stack.
+ (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
(move res eax)))
(define-vop (set-floating-point-modes)
(:temporary (:sc unsigned-reg :offset eax-offset
:from :eval :to :result) eax)
(:generator 3
- (inst sub esp-tn npx-env-size) ; make space on stack
- (inst wait) ; Catch any pending FPE exceptions
+ (inst sub esp-tn npx-env-size) ; Make space on stack.
+ (inst wait) ; Catch any pending FPE exceptions.
(inst fstenv (make-ea :dword :base esp-tn))
(inst mov eax new)
- (inst xor eax #x3f) ; turn trap enable bits into exception mask
+ (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
(inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
(inst shr eax 16) ; position status word
(inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
(inst fldenv (make-ea :dword :base esp-tn))
- (inst add esp-tn npx-env-size) ; Pop stack
+ (inst add esp-tn npx-env-size) ; Pop stack.
(move res new)))
\f
#!-long-float
(inst fst x))) ; maybe save it
(inst ,op) ; clobber st0
(cond ((zerop (tn-offset y))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst y)))))))
(case (tn-offset r)
((0 1))
(t (inst fstd r)))))
-
-) ; progn #!-long-float
-
+) ; PROGN #!-LONG-FLOAT
\f
-
#!+long-float
(progn
(inst fst x))) ; maybe save it
(inst ,op) ; clobber st0
(cond ((zerop (tn-offset y))
- (when (policy node (or (= debug 3) (> safety speed)))
- (inst wait)))
+ (maybe-fp-wait node))
(t
(inst fst y)))))))
- ;; Quick versions of fsin and fcos that require the argument to be
+ ;; Quick versions of FSIN and FCOS that require the argument to be
;; within range 2^63.
(frob fsin-quick %sin-quick fsin)
(frob fcos-quick %cos-quick fcos)
((0 1))
(t (inst fstd r)))))
-) ; progn #!+long-float
-
+) ; PROGN #!+LONG-FLOAT
\f
-;;;; Complex float VOPs
+;;;; complex float VOPs
(define-vop (make-complex-single-float)
(:translate complex)
(1 (ea-for-clf-imag-desc x)))))))
(with-empty-tn@fp-top(r)
(inst fldl ea))))
- (t (error "Complex-float-value VOP failure")))))
+ (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
(define-vop (realpart/complex-single-float complex-float-value)
(:translate realpart)
(:result-types long-float)
(:note "complex float imagpart")
(:variant 1))
-
\f
-;;; A hack dummy VOP to bias the representation selection of its
-;;; argument towards a FP register which can help avoid consing at
-;;; inappropriate locations.
-
+;;; hack dummy VOPs to bias the representation selection of their
+;;; arguments towards a FP register, which can help avoid consing at
+;;; inappropriate locations
(defknown double-float-reg-bias (double-float) (values))
(define-vop (double-float-reg-bias)
(:translate double-float-reg-bias)
(:note "inline dummy FP register bias")
(:ignore x)
(:generator 0))
-
(defknown single-float-reg-bias (single-float) (values))
(define-vop (single-float-reg-bias)
(:translate single-float-reg-bias)
(in-package "CL-USER")
-(eval-when (:compile-toplevel :load-toplevel :execute)
+;;(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro grab-condition (&body body)
`(nth-value 1
- (ignore-errors ,@body))))
+ (ignore-errors ,@body)))
+;;)
(setf (logical-pathname-translations "demo0")
'(("**;*.*.*" "/tmp/")))
(translate-logical-pathname
"FOO:")))
+;;; ANSI says PARSE-NAMESTRING returns TYPE-ERROR on host mismatch.
+(let ((cond (grab-condition (parse-namestring "foo:jeamland" "demo2"))))
+ (assert (typep cond 'type-error)))
+
;;; ANSI, in its wisdom, specifies that it's an error (specifically a
;;; TYPE-ERROR) to query the system about the translations of a string
;;; which doesn't have any translations. It's not clear why we don't
(assert (string= compiled-file-name expected-file-name)))
(sb-ext:quit :unix-status 52)
EOF
-if [ $? ~= 52 ]; then
+if [ $? != 52 ]; then
echo test failed: $?
exit 1
fi
;;; 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.9.9"
+"0.6.9.10"
projects / sbcl.git / commitdiff