From: William Harold Newman Date: Wed, 20 Dec 2000 22:42:34 +0000 (+0000) Subject: 0.6.9.10: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=64bf93a97814ea1caf62bbdcc7ef43e2fbfc8f73;p=sbcl.git 0.6.9.10: 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 --- diff --git a/BUGS b/BUGS index 8c08638..9cba6dc 100644 --- a/BUGS +++ b/BUGS @@ -883,6 +883,9 @@ Error in function C::GET-LAMBDA-TO-COMPILE: 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 47eb5f6..6e5bad0 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1198,7 +1198,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "!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" diff --git a/src/code/class.lisp b/src/code/class.lisp index 4e928a0..909d869 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -464,9 +464,9 @@ (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 diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 11bb6b8..ede85fd 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -137,7 +137,7 @@ (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? @@ -192,7 +192,7 @@ ;; 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. diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index a7856e9..52703f2 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -3121,43 +3121,47 @@ :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)) ;;;; 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) @@ -3217,7 +3221,7 @@ ;; 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)) @@ -3260,16 +3264,17 @@ (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 @@ -3283,14 +3288,14 @@ #!+gengc sb!vm::ra-save-offset lra-sc-offset))) (return t))))) - + ;;;; 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) @@ -3317,7 +3322,7 @@ (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 @@ -3365,7 +3370,7 @@ (setf (breakpoint-data-breakpoints data) (append (breakpoint-data-breakpoints data) (list breakpoint))) (setf (breakpoint-internal-data breakpoint) data))) - + ;;;; DEACTIVATE-BREAKPOINT (defun deactivate-breakpoint (breakpoint) @@ -3406,7 +3411,7 @@ (delete-breakpoint-data data)))) (setf (breakpoint-status breakpoint) :inactive) breakpoint) - + ;;;; BREAKPOINT-INFO (defun breakpoint-info (breakpoint) @@ -3419,7 +3424,7 @@ (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (setf (breakpoint-%info other) value)))) - + ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT (defun breakpoint-active-p (breakpoint) @@ -3453,7 +3458,7 @@ (breakpoint-what breakpoint)) nil)))))) breakpoint) - + ;;;; C call out stubs ;;; This actually installs the break instruction in the component. It @@ -3632,7 +3637,7 @@ (stack-ref ocfp arg-num)) results))) (nreverse results))) - + ;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints) (defconstant diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 25ae528..857e0a0 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -216,7 +216,6 @@ (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)) @@ -229,7 +228,6 @@ `(setf (svref ,n-cache ,i) ,val)) (values-indices) default-values)) - (/show0 ,(concatenate 'string "leaving " (string fun-name))) (values))) (forms `(,fun-name))) diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index 54afe69..9e54bf2 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -81,19 +81,18 @@ ;; 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 diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 654a6a7..5667e03 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -170,8 +170,8 @@ 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*)) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 458174e..357d711 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -64,7 +64,7 @@ ;;; 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 @@ -72,10 +72,12 @@ ;; 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 @@ -211,12 +213,12 @@ ;; 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 @@ -264,8 +266,8 @@ (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. @@ -390,7 +392,7 @@ (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) @@ -466,7 +468,7 @@ a host-structure or string." ;; 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. ..." @@ -479,7 +481,7 @@ a host-structure or string." ;; 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. @@ -516,12 +518,12 @@ a host-structure or string." 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 @@ -615,15 +617,26 @@ a host-structure or string." (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) @@ -1034,7 +1047,7 @@ a host-structure or string." (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) @@ -1053,8 +1066,9 @@ a host-structure or string." (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) @@ -1063,10 +1077,10 @@ a host-structure or string." ;;; 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*) @@ -1075,8 +1089,8 @@ a host-structure or string." 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 @@ -1088,8 +1102,8 @@ a host-structure or string." (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 @@ -1102,8 +1116,8 @@ a host-structure or string." 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)) @@ -1115,8 +1129,8 @@ a host-structure or string." (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 @@ -1141,9 +1155,9 @@ a host-structure or string." (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 @@ -1213,8 +1227,10 @@ a host-structure or string." function))))))) ;;;; 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 @@ -1298,8 +1314,8 @@ a host-structure or string." :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)) @@ -1322,7 +1338,8 @@ a host-structure or string." (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)) @@ -1414,8 +1431,8 @@ a host-structure or string." (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 @@ -1439,7 +1456,7 @@ a host-structure or string." (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)) @@ -1478,19 +1495,19 @@ a host-structure or string." ;; 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) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 2a91eda..8e9365d 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -90,7 +90,9 @@ (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)) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 949219c..8ae879b 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -499,7 +499,7 @@ (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) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 54fe4cf..4e75b23 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -40,46 +40,61 @@ (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)) -;;; 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 + ;;; possible values for the INLINE-ness of a function. (deftype inlinep () '(member :inline :maybe-inline :notinline nil)) @@ -118,8 +133,8 @@ (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*) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 9fea38c..67c719f 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1121,8 +1121,8 @@ 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) @@ -1387,7 +1387,8 @@ (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 diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 67f5c45..15e93f1 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1014,13 +1014,13 @@ (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 @@ -1298,7 +1298,7 @@ (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)))))) @@ -1431,7 +1431,7 @@ :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)) @@ -1524,7 +1524,7 @@ (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) @@ -3029,8 +3029,8 @@ `(,(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, diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 220bf09..86a7b8d 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -323,8 +323,8 @@ 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 @@ -336,26 +336,26 @@ (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))))) ;;;; 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)) diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 7bbaaf5..ae3ffba 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -22,12 +22,12 @@ (: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 . ) (a local macro, with the specifier - ;; expander.) Note that Name may be a (SETF ) function. + ;; expander.) Note that NAME may be a (SETF ) 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 @@ -61,12 +61,12 @@ ;; 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)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 6e3289a..42325f9 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -177,7 +177,7 @@ (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) @@ -285,7 +285,8 @@ ;;; 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)) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 7a33cc8..ae6d48f 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -18,11 +18,11 @@ ;;; 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)))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 9d310cc..e510d5b 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -13,62 +13,57 @@ (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)) ;;;; 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))) ;;;; source-hacking defining forms diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 5078353..24dc333 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -103,8 +103,8 @@ ;;; 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 @@ -463,7 +463,7 @@ (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 @@ -492,7 +492,7 @@ (: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* @@ -813,9 +813,9 @@ (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) @@ -893,8 +893,8 @@ ;;; *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))))) @@ -917,11 +917,11 @@ ;;; 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 @@ -931,8 +931,8 @@ (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 @@ -1358,11 +1358,10 @@ (*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) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 6232e72..990c6ce 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -14,13 +14,13 @@ (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 @@ -32,9 +32,9 @@ ;; 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. @@ -87,22 +87,22 @@ (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 @@ -110,8 +110,8 @@ ;; 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)))) @@ -223,11 +223,11 @@ (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) diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index 4f893d6..0155b2f 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -354,7 +354,7 @@ (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)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index fc82d67..6365cf1 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -127,7 +127,7 @@ (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)) @@ -3262,7 +3262,7 @@ ((= 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))) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index c0d2055..d8ea764 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -52,7 +52,22 @@ (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 @@ -155,12 +170,12 @@ ;; 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)))) @@ -179,7 +194,7 @@ (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)))))) ;;;; complex float move functions @@ -207,7 +222,7 @@ (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))) @@ -282,7 +297,7 @@ ;;;; move VOPs -;;; Float register to register moves. +;;; float register to register moves (define-vop (float-move) (:args (x)) (:results (y)) @@ -439,7 +454,7 @@ (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))) @@ -468,7 +483,6 @@ (inst fldl (ea-for-lf-desc x))))) #!+long-float (define-move-vop move-to-long :move (descriptor-reg) (long-reg)) - ;;; Move from complex float to a descriptor reg. allocating a new ;;; complex float object in the process. @@ -530,7 +544,7 @@ (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) @@ -557,14 +571,13 @@ (frob move-to-complex-double complex-double-reg :double) #!+long-float (frob move-to-complex-double complex-long-reg :long)) - -;;;; 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) @@ -616,7 +629,7 @@ #!+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) @@ -702,7 +715,7 @@ ;;;; 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 @@ -792,9 +805,7 @@ (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)) @@ -820,10 +831,8 @@ (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. @@ -872,12 +881,11 @@ (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 @@ -900,7 +908,7 @@ (: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)) @@ -938,9 +946,7 @@ (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)) @@ -966,10 +972,8 @@ (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. @@ -1018,12 +1022,11 @@ (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 @@ -1045,7 +1048,7 @@ (: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)) @@ -1069,9 +1072,7 @@ (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)) @@ -1083,9 +1084,7 @@ (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. @@ -1111,8 +1110,7 @@ ;; 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)))))))))) @@ -1152,8 +1150,8 @@ (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)))))) @@ -1221,7 +1219,6 @@ (y :scs (long-reg))) (:arg-types long-float long-float)) - (define-vop ( safety speed))) - (inst wait))) + (maybe-fp-wait node)) (t (inst fst y))))))) @@ -3229,11 +3225,8 @@ (case (tn-offset r) ((0 1)) (t (inst fstd r))))) - -) ; progn #!-long-float - +) ; PROGN #!-LONG-FLOAT - #!+long-float (progn @@ -3265,12 +3258,11 @@ (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) @@ -4317,10 +4309,9 @@ ((0 1)) (t (inst fstd r))))) -) ; progn #!+long-float - +) ; PROGN #!+LONG-FLOAT -;;;; Complex float VOPs +;;;; complex float VOPs (define-vop (make-complex-single-float) (:translate complex) @@ -4514,7 +4505,7 @@ (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) @@ -4577,12 +4568,10 @@ (:result-types long-float) (:note "complex float imagpart") (:variant 1)) - -;;; 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) @@ -4592,7 +4581,6 @@ (: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) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 703fdb0..7fd7e3a 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -16,10 +16,11 @@ (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/"))) @@ -90,6 +91,10 @@ (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 diff --git a/tests/side-effectful-pathnames.test.sh b/tests/side-effectful-pathnames.test.sh index 1b57d8e..dfd56b1 100644 --- a/tests/side-effectful-pathnames.test.sh +++ b/tests/side-effectful-pathnames.test.sh @@ -31,7 +31,7 @@ sbcl --noinform --noprint --sysinit /dev/null --userinit /dev/null <